diff options
Diffstat (limited to 'system')
224 files changed, 87641 insertions, 0 deletions
diff --git a/system/base/1.7.5/source-disk b/system/base/1.7.5/source-disk new file mode 100644 index 0000000..5708023 --- /dev/null +++ b/system/base/1.7.5/source-disk @@ -0,0 +1 @@ +175_src/source-code-1.7.5.img diff --git a/system/base/1.7.5/src/advertising b/system/base/1.7.5/src/advertising new file mode 100644 index 0000000..45f73ef --- /dev/null +++ b/system/base/1.7.5/src/advertising @@ -0,0 +1,35 @@ +(* ------------------- VERSION 1 06.03.86 ------------------- *) +PACKET advertising DEFINES (* Autor: J.Liedtke *) + + eumel must advertise : + + +LET myself id field = 9 ; + + +PROC eumel must advertise : + + IF online AND channel <= 15 + THEN out (""1""4"") ; + IF station is not zero + THEN out (""15"Station: ") ; + out (text (station number)) ; + out (" "14"") + FI ; + cursor (60,1) ; + out (""15"Terminal: ") ; + out (text (channel)) ; + out (" "14"") ; + cursor (22,5) ; + (* out ("E U M E L Pilot-Version /M"13""10""10""10"") *) + out ("E U M E L Version 1.7.5.10 /M+ "13""10""10""10"") + FI . + +station is not zero : pcb (myself id field) >= 256 . + +station number : pcb (myself id field) DIV 256 . + +ENDPROC eumel must advertise ; + +ENDPACKET advertising ; + diff --git a/system/base/1.7.5/src/basic transput b/system/base/1.7.5/src/basic transput new file mode 100644 index 0000000..5608bb1 --- /dev/null +++ b/system/base/1.7.5/src/basic transput @@ -0,0 +1,177 @@ + +PACKET basic transput DEFINES + out , + outsubtext , + outtext , + TIMESOUT , + cout , + display , + inchar , + incharety , + cat input , + pause , + cursor , + get cursor , + channel , + online , + control , + blockout , + blockin : + + + +LET channel field = 4 , + blank times 64 = + " " ; + +LET BLOCKIO = STRUCT (ALIGN page align, ROW 256 INT buffer) , + buffer page = 2 ; + +BOUND BLOCKIO VAR block io ; +DATASPACE VAR block io ds ; +INITFLAG VAR this packet := FALSE ; + + +PROC out (TEXT CONST text ) : + EXTERNAL 60 +ENDPROC out ; + +PROC outsubtext ( TEXT CONST source, INT CONST from ) : + EXTERNAL 62 +END PROC outsubtext; + +PROC outsubtext (TEXT CONST source, INT CONST from, to) : + EXTERNAL 63 +END PROC outsubtext; + +PROC outtext ( TEXT CONST source, INT CONST from, to ) : + out subtext (source, from, to) ; + INT VAR trailing ; + IF from <= LENGTH source + THEN trailing := to - LENGTH source + ELSE trailing := to + 1 - from + FI ; + IF trailing > 0 + THEN trailing TIMESOUT " " + FI +ENDPROC outtext ; + +OP TIMESOUT (INT CONST times, TEXT CONST text) : + + IF text = " " + THEN fast timesout blank + ELSE timesout + FI . + +fast timesout blank : + INT VAR i := 0 ; + WHILE i + 64 < times REP + out (blank times 64) ; + i INCR 64 + PER ; + outsubtext (blank times 64, 1, times - i) . + +timesout : + FOR i FROM 1 UPTO times REP + out(text) + ENDREP . + +ENDOP TIMESOUT ; + +PROC display (TEXT CONST text) : + IF online + THEN out (text) + FI +ENDPROC display ; + +PROC inchar (TEXT VAR character ) : + EXTERNAL 64 +ENDPROC inchar ; + +TEXT PROC incharety : + EXTERNAL 65 +END PROC incharety ; + +TEXT PROC incharety (INT CONST time limit) : + internal pause (time limit) ; + incharety +ENDPROC incharety ; + +PROC pause (INT CONST time limit) : + internal pause (time limit) ; + TEXT CONST dummy := incharety +ENDPROC pause ; + +PROC pause : + TEXT VAR dummy; inchar (dummy) +ENDPROC pause ; + +PROC internal pause (INT CONST time limit) : + EXTERNAL 66 +ENDPROC internal pause ; + +PROC cat input (TEXT VAR t, esc char) : + EXTERNAL 68 +ENDPROC cat input ; + + +PROC cursor (INT CONST x, y) : + out (""6"") ; + out (code(y-1)) ; + out (code(x-1)) ; +ENDPROC cursor ; + +PROC get cursor (INT VAR x, y) : + EXTERNAL 67 +ENDPROC get cursor ; + +PROC cout (INT CONST number) : + EXTERNAL 61 +ENDPROC cout ; + + +INT PROC channel : + pcb (channel field) +ENDPROC channel ; + +BOOL PROC online : + pcb (channel field) <> 0 +ENDPROC online ; + + +PROC control (INT CONST code1, code2, code3, INT VAR return code) : + EXTERNAL 84 +ENDPROC control ; + +PROC blockout (ROW 256 INT CONST block, INT CONST code1, code2, + INT VAR return code) : + + access block io ds ; + block io.buffer := block ; + blockout (block io ds, buffer page, code1, code2, return code) . + +access block io ds : + IF NOT initialized (this packet) + THEN block io ds := nilspace + FI ; + block io := block io ds . + +ENDPROC blockout ; + +PROC blockin (ROW 256 INT VAR block, INT CONST code1, code2, + INT VAR return code) : + + access block io ds ; + blockin (block io ds, buffer page, code1, code2, return code) ; + block := block io.buffer . + +access block io ds : + IF NOT initialized (this packet) + THEN block io ds := nilspace + FI ; + block io := block io ds . + +ENDPROC blockin ; + +ENDPACKET basic transput ; + diff --git a/system/base/1.7.5/src/bits b/system/base/1.7.5/src/bits new file mode 100644 index 0000000..e9e84e7 --- /dev/null +++ b/system/base/1.7.5/src/bits @@ -0,0 +1,78 @@ + +PACKET bits DEFINES + + AND , + OR , + XOR , + bit , + lowest reset , + lowest set , + reset bit , + rotate , + set bit : + +LET bits per int = 16 ; + +ROW bits per int INT VAR bit mask := ROW bits per int INT: + (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,-32767-1) ; + +PROC rotate (INT VAR bits, INT CONST number of bits) : + EXTERNAL 83 +ENDPROC rotate ; + +INT OP AND (INT CONST left, right) : + EXTERNAL 124 +ENDOP AND ; + +INT OP OR (INT CONST left, right) : + EXTERNAL 125 +ENDOP OR ; + +INT OP XOR (INT CONST left, right) : + EXTERNAL 121 +ENDOP XOR ; + +BOOL PROC bit (INT CONST bits, bit no) : + + (bits AND bit mask (bit no+1)) <> 0 + +ENDPROC bit ; + +PROC set bit (INT VAR bits, INT CONST bit no) : + + bits := bits OR bit mask (bit no+1) + +ENDPROC set bit ; + +PROC reset bit (INT VAR bits,INT CONST bit no) : + + bits := bits XOR (bits AND bit mask (bit no+1)) + +ENDPROC reset bit ; + +INT PROC lowest set (INT CONST bits) : + + INT VAR mask index ; + FOR mask index FROM 1 UPTO 16 REP + IF (bits AND bit mask (mask index)) <> 0 + THEN LEAVE lowest set WITH mask index - 1 + FI + PER ; + -1 + +ENDPROC lowest set ; + +INT PROC lowest reset (INT CONST bits) : + + INT VAR mask index ; + FOR mask index FROM 1 UPTO bits per int REP + IF (bits AND bit mask (mask index)) = 0 + THEN LEAVE lowest reset WITH mask index - 1 + FI + PER ; + -1 + +ENDPROC lowest reset ; + +ENDPACKET bits ; + diff --git a/system/base/1.7.5/src/bool b/system/base/1.7.5/src/bool new file mode 100644 index 0000000..5bf1e65 --- /dev/null +++ b/system/base/1.7.5/src/bool @@ -0,0 +1,16 @@ + +PACKET bool DEFINES XOR, true, false : + +BOOL CONST true := TRUE , + false:= FALSE ; + +BOOL OP XOR (BOOL CONST left, right) : + + IF left THEN NOT right + ELSE right + FI + +ENDOP XOR ; + +ENDPACKET bool ; + diff --git a/system/base/1.7.5/src/command dialogue b/system/base/1.7.5/src/command dialogue new file mode 100644 index 0000000..3011187 --- /dev/null +++ b/system/base/1.7.5/src/command dialogue @@ -0,0 +1,123 @@ + +PACKET command dialogue DEFINES (* Autor: J.Liedtke *) + (* Stand: 25.11.83 *) + command dialogue , + say , + yes , + no , + param position , + last param , + std , + QUIET , + quiet : + + +LET up = ""3"" , + right = ""2"" , + cr lf = ""13""10"" , + param pre = " (""" , + param post = """)"13""10"" ; + + +TEXT VAR std param := "" ; + +BOOL VAR dialogue flag := TRUE ; + +INT VAR param x := 0 ; + + +TYPE QUIET = INT ; + +QUIET PROC quiet : + QUIET:(0) +ENDPROC quiet ; + + +BOOL PROC command dialogue : + dialogue flag +ENDPROC command dialogue ; + +PROC command dialogue (BOOL CONST status) : + dialogue flag := status +ENDPROC command dialogue ; + + +BOOL PROC yes (TEXT CONST question) : + + IF dialogue flag + THEN ask question + ELSE TRUE + FI . + +ask question : + out (question) ; + skip previous input chars ; + out (" (j/n) ? ") ; + get answer ; + IF correct answer + THEN out (answer) ; + out (cr lf) ; + positive answer + ELSE out (""7"") ; + LENGTH question + 9 TIMESOUT ""8"" ; + yes (question) + FI . + +get answer : + TEXT VAR answer ; + inchar (answer) . + +correct answer : + pos ("jnyJNY", answer) > 0 . + +positive answer : + pos ("jyJY", answer) > 0 . + +skip previous input chars : + REP UNTIL incharety = "" PER . + +ENDPROC yes ; + +BOOL PROC no (TEXT CONST question) : + + NOT yes (question) + +ENDPROC no ; + +PROC say (TEXT CONST message) : + + IF dialogue flag + THEN out (message) + FI + +ENDPROC say ; + +PROC param position (INT CONST x) : + + param x := x + +ENDPROC param position ; + +TEXT PROC last param : + + IF param x > 0 AND online + THEN out (up) ; + param x TIMESOUT right ; + out (param pre) ; + out (std param) ; + out (param post) + FI ; + std param . + +ENDPROC last param ; + +PROC last param (TEXT CONST new) : + std param := new +ENDPROC last param ; + +TEXT PROC std : + std param +ENDPROC std ; + +ENDPACKET command dialogue ; + diff --git a/system/base/1.7.5/src/command handler b/system/base/1.7.5/src/command handler new file mode 100644 index 0000000..756382b --- /dev/null +++ b/system/base/1.7.5/src/command handler @@ -0,0 +1,290 @@ +(* ------------------- VERSION 2 05.05.86 ------------------- *) +PACKET command handler DEFINES (* Autor: J.Liedtke *) + + get command , + analyze command , + do command , + command error , + cover tracks : + + +LET cr lf = ""4""13""10"" , + esc k = ""27"k" , + command pre = ""4""13" " , + command post = ""13""10" " , + + max command length = 2010 , + + tag type = 1 , + texttype = 4 , + eof type = 7 ; + + +TEXT VAR command handlers own command line := "" , + previous command line := "" , + symbol , + procedure , + pattern , + error note := "" ; + +INT VAR symbol type ; + + +PROC get command (TEXT CONST command text) : + + get command (command text, command handlers own command line) + +ENDPROC get command ; + +PROC get command (TEXT CONST command text, TEXT VAR command line) : + + set line nr (0) ; + error protocoll ; + get command from console . + +error protocoll : + IF is error + THEN put error ; + clear error + ELSE command line := "" ; + FI . + +get command from console : + normalize cursor ; + REP + out (command pre) ; + out (command text) ; + out (command post) ; + editget command + UNTIL command line <> "" PER ; + param position (LENGTH command line) ; + out (command post) . + +editget command : + TEXT VAR exit char ; + REP + get cursor (x, y) ; + editget (command line, max command length, x size - x, + "", "k", exit char) ; + ignore halt errors during editget ; + break quiet if command line is too long ; + IF exit char = esc k + THEN cursor to begin of command input ; + command line := previous command line + ELIF LENGTH command line > 1 + THEN previous command line := command line ; + LEAVE editget command + ELSE LEAVE editget command + FI + PER . + +normalize cursor : + INT VAR x, y; + out (crlf) ; + get cursor (x, y) ; + cursor (x, y) . + +ignore halt errors during editget : + IF is error + THEN clear error + FI . + +break quiet if command line is too long : + IF command line is too long + THEN command line := "break (quiet)" + FI . + +command line is too long : + LENGTH command line = max command length . + +cursor to begin of command input : + out (command pre) . + +ENDPROC get command ; + + +PROC analyze command ( TEXT CONST command list, + INT CONST permitted type, + INT VAR command index, number of params, + TEXT VAR param 1, param 2) : + + analyze command (command list, command handlers own command line, + permitted type, command index, + number of params, param 1, param 2) + +ENDPROC analyze command ; + +PROC analyze command ( TEXT CONST command list, command line, + INT CONST permitted type, + INT VAR command index, number of params, + TEXT VAR param 1, param 2) : + + error note := "" ; + scan (command line) ; + next symbol ; + IF symbol type <> tag type AND symbol <> "?" + THEN error ("Name ungueltig") ; + impossible command + ELIF pos (command list, symbol) > 0 + THEN procedure name ; + parameter list pack option ; + nothing else in command line ; + decode command + ELSE impossible command + FI . + +procedure name : + procedure := symbol ; + next symbol . + +parameter list pack option : + number of params := 0 ; + param 1 := "" ; + param 2 := "" ; + IF symbol = "(" + THEN next symbol ; + parameter list ; + IF symbol <> ")" AND error note = "" + THEN error (") fehlt") + FI + ELIF symbol type <> eof type + THEN error ("( fehlt") + FI . + +parameter list : + parameter (param 1, number of params, permitted type) ; + IF symbol = "," + THEN next symbol ; + parameter (param 2, number of params, permitted type) ; + FI . + +nothing else in command line : + next symbol ; + IF symbol <> "" + THEN error ("Kommando zu schwierig") + FI . + +decode command : + command index := index (command list, procedure, number of params) . + +impossible command : + command index := 0 . + +ENDPROC analyze command ; + +PROC parameter (TEXT VAR param, INT VAR number of params, + INT CONST permitted type) : + + IF symbol type = text type OR symbol type = permitted type + THEN param := symbol ; + number of params INCR 1 ; + next symbol + ELSE error ("Parameter ist kein TEXT ("" fehlt)") + FI + +ENDPROC parameter ; + +INT PROC index (TEXT CONST list, procedure, INT CONST params) : + + pattern := procedure ; + pattern CAT ":" ; + IF procedure name found + THEN get colon pos ; + get dot pos ; + get end pos ; + get command index ; + get param index ; + IF param index >= 0 + THEN command index + param index + ELSE - command index + FI + ELSE 0 + FI . + +procedure name found : + INT VAR index pos := pos (list, pattern) ; + WHILE index pos > 0 REP + IF index pos = 1 COR (list SUB index pos - 1) <= "9" + THEN LEAVE procedure name found WITH TRUE + FI ; + index pos := pos (list, pattern, index pos + 1) + PER ; + FALSE . + +get param index : + INT CONST param index := + pos (list, text (params), dot pos, end pos) - dot pos - 1 . + +get command index : + INT CONST command index := + int ( subtext (list, colon pos + 1, dot pos - 1) ) . + +get colon pos : + INT CONST colon pos := pos (list, ":", index pos) . + +get dot pos : + INT CONST dot pos := pos (list, ".", index pos) . + +get end pos : + INT CONST end pos := dot pos + 4 . + +ENDPROC index ; + +PROC do command : + + do (command handlers own command line) + +ENDPROC do command ; + +PROC error (TEXT CONST message) : + + error note := message ; + scan ("") ; + procedure := "-" + +ENDPROC error ; + +PROC command error : + + disable stop ; + IF error note <> "" + THEN errorstop (error note) ; + error note := "" + FI ; + enable stop + +ENDPROC command error ; + + +PROC next symbol : + + next symbol (symbol, symbol type) + +ENDPROC next symbol ; + + +PROC cover tracks : + + cover tracks (command handlers own command line) ; + cover tracks (previous command line) ; + erase buffers of compiler and do packet . + +erase buffers of compiler and do packet : + do (command handlers own command line) . + +ENDPROC cover tracks ; + +PROC cover tracks (TEXT VAR secret) : + + INT VAR i ; + FOR i FROM 1 UPTO LENGTH secret REP + replace (secret, i, " ") + PER ; + WHILE LENGTH secret < 13 REP + secret CAT " " + PER + +ENDPROC cover tracks ; + +ENDPACKET command handler ; + diff --git a/system/base/1.7.5/src/dataspace b/system/base/1.7.5/src/dataspace new file mode 100644 index 0000000..3045a53 --- /dev/null +++ b/system/base/1.7.5/src/dataspace @@ -0,0 +1,74 @@ +(* ------------------- VERSION 3 22.04.86 ------------------- *) +PACKET dataspace DEFINES + + := , + nilspace , + forget , + type , + heap size , + storage , + ds pages , + next ds page , + blockout , + blockin , + ALIGN : + + +LET myself id field = 9 , + lowest ds number = 4 , + highest ds number = 255 ; + +TYPE ALIGN = ROW 252 INT ; + +OP := (DATASPACE VAR dest, DATASPACE CONST source ) : + EXTERNAL 70 +ENDOP := ; + +DATASPACE PROC nilspace : + EXTERNAL 69 +ENDPROC nilspace ; + +PROC forget (DATASPACE CONST dataspace ) : + EXTERNAL 71 +ENDPROC forget ; + +PROC type (DATASPACE CONST ds, INT CONST type) : + EXTERNAL 72 +ENDPROC type ; + +INT PROC type (DATASPACE CONST ds) : + EXTERNAL 73 +ENDPROC type ; + +INT PROC heap size (DATASPACE CONST ds) : + EXTERNAL 74 +ENDPROC heap size ; + +INT PROC storage (DATASPACE CONST ds) : + (ds pages (ds) + 1) DIV 2 +ENDPROC storage ; + +INT PROC ds pages (DATASPACE CONST ds) : + pages (ds, pcb (myself id field)) +ENDPROC ds pages ; + +INT PROC pages (DATASPACE CONST ds, INT CONST task nr) : + EXTERNAL 88 +ENDPROC pages ; + +INT PROC next ds page (DATASPACE CONST ds, INT CONST page nr) : + EXTERNAL 87 +ENDPROC next ds page ; + +PROC blockout (DATASPACE CONST ds, INT CONST page nr, code1, code2, + INT VAR return code) : + EXTERNAL 85 +ENDPROC blockout ; + +PROC blockin (DATASPACE VAR ds, INT CONST page nr, code1, code2, + INT VAR return code) : + EXTERNAL 86 +ENDPROC blockin ; + +ENDPACKET dataspace ; + diff --git a/system/base/1.7.5/src/date handling b/system/base/1.7.5/src/date handling new file mode 100644 index 0000000..66da110 --- /dev/null +++ b/system/base/1.7.5/src/date handling @@ -0,0 +1,303 @@ +PACKET date handling DEFINES date, time, (* Autor: H. Indenbirken *) + time of day, (* Stand: 02.06.1986 (wk)*) + month, day , year , + hour , + minute, + second : + +LET middle yearlength = 31557380.0, + weeklength = 604800.0, + daylength = 86400.0, + hours = 3600.0, + minutes = 60.0, + seconds = 1.0; + + +(* Tage bis zum Jahr 01.01.1900: 693970.25 5.995903e10 Sekunden *) +(* Dieser Tag ist ein Montag *) + +REAL VAR begin of today := 0.0 , end of today := 0.0 ; + +TEXT VAR today , result ; + + +ROW 12 REAL CONST previous days :: ROW 12 REAL : (0.0, 2678400.0, 5097600.0, + 7776000.0, 10368000.0, 13046400.0, + 15638400.0, 18316800.0, 20995200.0, + 23587200.0, 26265600.0, 28857600.0); + +REAL PROC day: day length END PROC day; +REAL PROC hour: hours END PROC hour; +REAL PROC minute: minutes END PROC minute; +REAL PROC second: seconds END PROC second; + +TEXT PROC date : + + IF clock (1) < begin of today OR end of today <= clock (1) + THEN begin of today := clock (1) ; + end of today := floor (begin of today/daylength)*daylength+daylength; + today := date (begin of today) + FI ; + today + +ENDPROC date ; + +TEXT PROC date (REAL CONST datum): + INT VAR year :: int (datum/middle yearlength), + day :: int (((datum - datum MOD daylength) MOD middle yearlength) / daylength) + 1; + +correct kalendary day; + + calculate month and correct day; + result := daytext; + result CAT monthtext; + result CAT yeartext; + change all (result, " ", "0") ; + result . + +correct kalendary day: + IF day >= 60 AND NOT leapyear + THEN day INCR 1 FI . + +leapyear: + IF year MOD 100 = 0 + THEN year MOD 400 = 0 + ELSE year MOD 4 = 0 + FI. + +calculate month and correct day: + INT VAR month; + IF day > 182 + THEN IF day > 274 + THEN IF day > 305 + THEN IF day > 335 + THEN month := 12; + day DECR 335 + ELSE month := 11; + day DECR 305 + FI + ELSE month := 10; + day DECR 274 + FI + ELSE IF day > 213 + THEN IF day > 244 + THEN month := 9; + day DECR 244 + ELSE month := 8; + day DECR 213 + FI + ELSE month := 7; + day DECR 182 + FI + FI + ELSE IF day > 91 + THEN IF day > 121 + THEN IF day > 152 + THEN month := 6; + day DECR 152 + ELSE month := 5; + day DECR 121 + FI + ELSE month := 4; + day DECR 91 + FI + ELSE IF day > 31 + THEN IF day > 60 + THEN month := 3; + day DECR 60 + ELSE month := 2; + day DECR 31 + FI + ELSE month := 1 FI + FI + FI . + +daytext : + text (day, 2) + "." . + +monthtext : + text (month,2) + "." . + +yeartext: + IF 1900 <= year AND year < 2000 + THEN text (year - 1900, 2) + ELSE text (year, 4) + FI . + +END PROC date; + +TEXT PROC day (REAL CONST datum): + SELECT int ((datum MOD weeklength)/daylength) OF + CASE 1: "Donnerstag" + CASE 2: "Freitag" + CASE 3: "Samstag" + CASE 4: "Sonntag" + CASE 5: "Montag" + CASE 6: "Dienstag" + OTHERWISE "Mittwoch" ENDSELECT . +END PROC day; + +TEXT PROC month (REAL CONST datum): + SELECT int (subtext (date (datum), 4, 5)) OF + CASE 1: "Januar" + CASE 2: "Februar" + CASE 3: "März" + CASE 4: "April" + CASE 5: "Mai" + CASE 6: "Juni" + CASE 7: "Juli" + CASE 8: "August" + CASE 9: "September" + CASE 10: "Oktober" + CASE 11: "November" + OTHERWISE "Dezember" ENDSELECT . + +END PROC month; + +TEXT PROC year (REAL CONST datum) : + + TEXT VAR buffer := subtext (date (datum), 7) ; + IF LENGTH buffer = 2 + THEN "19" + buffer + ELSE buffer + FI . + +ENDPROC year ; + +TEXT PROC time of day : + time of day (clock (1)) +ENDPROC time of day ; + +TEXT PROC time of day (REAL CONST value) : + subtext (time (value MOD daylength), 1, 5) +ENDPROC time of day ; + +TEXT PROC time (REAL CONST value) : + time (value,10) +ENDPROC time ; + +TEXT PROC time (REAL CONST value, INT CONST length) : + result := "" ; + IF length > 7 + THEN result CAT hour ; + result CAT ":" + FI ; + result CAT minute ; + result CAT ":" ; + result CAT rest ; + change all (result, " ", "0") ; + result . + +hour : + text (int (value/hours), length-8) . + +minute : + text (int (value/minutes MOD 60.0), 2) . + +rest : + text (value MOD minutes, 4, 1) . + +END PROC time ; + +REAL PROC date (TEXT CONST datum) : + split and check datum; + real (day no)*daylength + + previous days [month no] + calendary day + + floor (real (year no)*middleyearlength / daylength)*daylength . + +split and check datum: + INT CONST day no :: first no; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI; + + INT CONST month no :: second no; + IF NOT last conversion ok OR month no < 1 OR month no > 12 + THEN errorstop ("inkorrekte Datumsangabe (Monat) : " + datum) FI; + + INT CONST year no :: third no + century; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Jahr) : " + datum) FI; + + IF day no < 1 OR day no > size of month + THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI . + +century: + IF (length (datum) - second pos) <= 2 + THEN 1900 + ELSE 0 FI . + +size of month: + SELECT month no OF + CASE 1, 3, 5, 7, 8, 10, 12: 31 + CASE 4, 6, 9, 11: 30 + OTHERWISE february size ENDSELECT . + +february size: + IF leapyear + THEN 29 + ELSE 28 FI . + +calendary day: + IF month no > 2 AND leapyear + THEN daylength + ELSE 0.0 FI . + +leapyear: + year no MOD 4 = 0 AND year no MOD 400 <> 0 . + +first no: + INT CONST first pos :: pos (datum, "."); + int (subtext (datum, 1, first pos-1)) . + +second no: + INT CONST second pos :: pos (datum, ".", first pos+1); + int (subtext (datum, first pos + 1, second pos-1)) . + +third no: + int (subtext (datum, second pos + 1)) . + +END PROC date; + +REAL PROC time (TEXT CONST time) : + split and check time; + hour + min + sec . + +split and check time: + REAL CONST hour :: hour no * hours; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Stunde) : " + time) FI; + + REAL CONST min :: min no * minutes; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Minute) : " + time) FI; + + REAL CONST sec :: sec no; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Sekunde) : " + time) FI; + + set conversion (hour ok AND min ok AND sec ok) . + +hour no: + INT CONST hour pos :: pos (time, ":"); + real (subtext (time, 1, hour pos-1)) . + +min no: + INT VAR min pos :: pos (time, ":", hour pos+1); + IF min pos = 0 + THEN real (subtext (time, hour pos + 1, LENGTH time)) + ELSE real (subtext (time, hour pos + 1, min pos-1)) + FI . + +sec no: + IF min pos = 0 + THEN 0.0 + ELSE real (subtext (time, min pos + 1)) + FI . + +hour ok: 0.0 <= hour AND hour < daylength . +min ok: 0.0 <= min AND min < hours . +sec ok: 0.0 <= sec AND sec < minutes . +END PROC time; + +END PACKET datehandling + diff --git a/system/base/1.7.5/src/editor b/system/base/1.7.5/src/editor new file mode 100644 index 0000000..62af2db --- /dev/null +++ b/system/base/1.7.5/src/editor @@ -0,0 +1,2959 @@ +PACKET editor paket DEFINES (* EDITOR 121 *) + (**********) (* 19.07.85 -bk- *) + (* 10.09.85 -ws- *) + (* 25.04.86 -sh- *) + edit, editget, (* 06.06.86 -wk- *) + quit, quit last, (* 04.06.86 -jl- *) + push, type, + word wrap, margin, + write permission, + set busy indicator, + two bytes, + is kanji esc, + within kanji, + rubin mode, + is editget, + getchar, nichts neu, + getcharety, satznr neu, + is incharety, ueberschrift neu, + get window, zeile neu, + get editcursor, abschnitt neu, + get editline, bildabschnitt neu, + put editline, bild neu, + aktueller editor, alles neu, + groesster editor, satznr zeigen, + open editor, ueberschrift zeigen, + editfile, bild zeigen: + + +LET hop = ""1"", right = ""2"", + up char = ""3"", clear eop = ""4"", + clear eol = ""5"", cursor pos = ""6"", + piep = ""7"", left = ""8"", + down char = ""10"", rubin = ""11"", + rubout = ""12"", cr = ""13"", + mark key = ""16"", abscr = ""17"", + inscr = ""18"", dezimal = ""19"", + backcr = ""20"", esc = ""27"", + dach = ""94"", blank = " "; + + +LET no output = 0, out zeichen = 1, + out feldrest = 2, out feld = 3, + clear feldrest = 4; + +LET FELDSTATUS = STRUCT (INT stelle, alte stelle, rand, limit, + anfang, marke, laenge, verschoben, + BOOL einfuegen, fliesstext, write access, + TEXT tabulator); +FELDSTATUS VAR feldstatus; + +TEXT VAR begin mark := ""15"", + end mark := ""14""; + +TEXT VAR separator := "", kommando := "", audit := "", zeichen := "", + satzrest := "", merksatz := "", alter editsatz := ""; + +INT VAR kommando zeiger := 1, umbruchstelle, umbruch verschoben, + zeile, spalte, output mode := no output, postblanks := 0, + min schreibpos, max schreibpos, cpos, absatz ausgleich; + +BOOL VAR lernmodus := FALSE, separator eingestellt := FALSE, + invertierte darstellung := FALSE, absatzmarke steht, + cursor diff := FALSE, editget modus := FALSE, + two byte mode := FALSE, std fliesstext := TRUE;. + +schirmbreite : x size - 1 . +schirmhoehe : y size . +maxbreite : schirmbreite - 2 . +maxlaenge : schirmhoehe - 1 . +marklength : mark size .; + +initialisiere editor; + +.initialisiere editor : + anfang := 1; zeile := 0; verschoben := 0; tabulator := ""; + einfuegen := FALSE; fliesstext := TRUE; zeileneinfuegen := FALSE; + marke := 0; bildmarke := 0; feldmarke := 0.; + +(******************************** editget ********************************) + +PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge, + TEXT CONST sep, res, TEXT VAR exit char) : + IF editlaenge < 1 THEN errorstop ("Fenster zu klein") FI; + separator := ""13""; separator CAT sep; + separator eingestellt := TRUE; + TEXT VAR reservierte editget tasten := ""11""12"" ; + reservierte editget tasten CAT res ; + disable stop; + absatz ausgleich := 0; exit char := ""; get cursor; + FELDSTATUS CONST alter feldstatus := feldstatus; + feldstatus := FELDSTATUS : (1, 1, spalte - 1, editlimit, + 1, 0, editlaenge, 0, + FALSE, FALSE, TRUE, ""); + konstanten neu berechnen; + output mode := out feld; + feld editieren; + zeile verlassen; + feldstatus := alter feldstatus; + konstanten neu berechnen; + separator := ""; + separator eingestellt := FALSE . + +feld editieren : + REP + feldeditor (editsatz, reservierte editget tasten); + IF is error + THEN kommando zeiger := 1; kommando := ""; LEAVE feld editieren + FI ; + TEXT VAR t, zeichen; getchar (zeichen); + IF zeichen ist separator + THEN exit char := zeichen; LEAVE feld editieren + ELIF zeichen = hop + THEN feldout (editsatz, stelle); getchar (zeichen) + ELIF zeichen = mark key + THEN output mode := out feld + ELIF zeichen = abscr + THEN exit char := cr; LEAVE feld editieren + ELIF zeichen = esc + THEN getchar (zeichen); auf exit pruefen; + IF zeichen = rubout (*sh*) + THEN IF marke > 0 + THEN merksatz := subtext (editsatz, marke, stelle - 1); + change (editsatz, marke, stelle - 1, ""); + stelle := marke; marke := 0; konstanten neu berechnen + FI + ELIF zeichen = rubin + THEN t := subtext (editsatz, 1, stelle - 1); + t CAT merksatz; + satzrest := subtext (editsatz, stelle); + t CAT satzrest; + stelle INCR LENGTH merksatz; + merksatz := ""; editsatz := t + ELIF zeichen ist kein esc kommando (*wk*) + AND + kommando auf taste (zeichen) <> "" + THEN editget kommando ausfuehren + FI ; + output mode := out feld + FI + PER . + +zeichen ist kein esc kommando : (*wk*) + pos (hop + left + right, zeichen) = 0 . + +zeile verlassen : + IF marke > 0 OR verschoben <> 0 + THEN stelle DECR verschoben; verschoben := 0; feldout (editsatz, 0) + ELSE cursor (rand + 1 + min (LENGTH editsatz, editlaenge), zeile) + FI . + +zeichen ist separator : pos (separator, zeichen) > 0 . + +auf exit pruefen : + IF pos (res, zeichen) > 0 + THEN exit char := esc + zeichen; LEAVE feld editieren + FI . + +editget kommando ausfuehren : + editget zustaende sichern ; + do (kommando auf taste (zeichen)) ; + alte editget zustaende wieder herstellen ; + IF stelle < marke THEN stelle := marke FI; + konstanten neu berechnen . + +editget zustaende sichern : (*wk*) + BOOL VAR alter editget modus := editget modus; + FELDSTATUS VAR feldstatus vor do kommando := feldstatus ; + INT VAR zeile vor do kommando := zeile ; + TEXT VAR separator vor do kommando := separator ; + BOOL VAR separator eingestellt vor do kommando := separator eingestellt ; + editget modus := TRUE ; + alter editsatz := editsatz . + +alte editget zustaende wieder herstellen : + editget modus := alter editget modus ; + editsatz := alter editsatz; + feldstatus := feldstatus vor do kommando ; + zeile := zeile vor do kommando ; + separator := separator vor do kommando ; + separator eingestellt := separator eingestellt vor do kommando . + +END PROC editget; + +PROC editget (TEXT VAR editsatz, INT CONST editlimit, TEXT VAR exit char) : + editget (editsatz, editlimit, x size - x cursor, "", "", exit char) +END PROC editget; (* 05.07.84 -bk- *) + +PROC editget (TEXT VAR editsatz, TEXT CONST sep, res, TEXT VAR exit char) : + editget (editsatz, max text length, x size - x cursor, sep, res, exit char) +END PROC editget; (* 05.07.84 -bk- *) + +PROC editget (TEXT VAR editsatz) : + TEXT VAR exit char; (* 05.07.84 -bk- *) + editget (editsatz, max text length, x size - x cursor, "", "", exit char) +END PROC editget; + +PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge) : + TEXT VAR exit char; + editget (editsatz, editlimit, editlaenge, "", "", exit char) +ENDPROC editget; + +(******************************* feldeditor ******************************) + +TEXT VAR reservierte feldeditor tasten ; (*jl*) + +PROC feldeditor (TEXT VAR satz, TEXT CONST res) : + enable stop; + reservierte feldeditor tasten := ""1""2""8"" ; + reservierte feldeditor tasten CAT res; + absatzmarke steht := (satz SUB LENGTH satz) = blank; + alte stelle merken; + cursor diff bestimmen und ggf ausgleichen; + feld editieren; + absatzmarke updaten . + +alte stelle merken : alte stelle := stelle . + +cursor diff bestimmen und ggf ausgleichen : + IF cursor diff + THEN stelle INCR 1; cursor diff := FALSE + FI ; + IF stelle auf zweitem halbzeichen + THEN stelle DECR 1; cursor diff := TRUE + FI . + +feld editieren : + REP + feld optisch aufbereiten; + kommando annehmen und ausfuehren + PER . + +absatzmarke updaten : + IF absatzmarke soll stehen + THEN IF NOT absatzmarke steht THEN absatzmarke schreiben (TRUE) FI + ELSE IF absatzmarke steht THEN absatzmarke schreiben (FALSE) FI + FI . + +absatzmarke soll stehen : (satz SUB LENGTH satz) = blank . + +feld optisch aufbereiten : + stelle korrigieren; + verschieben wenn erforderlich; + randausgleich fuer doppelzeichen; + output mode behandeln; + ausgabe verhindern . + +randausgleich fuer doppelzeichen : + IF stelle = max schreibpos CAND stelle auf erstem halbzeichen + THEN verschiebe (1) + FI . + +stelle korrigieren : + IF stelle auf zweitem halbzeichen THEN stelle DECR 1 FI . + +stelle auf erstem halbzeichen : within kanji (satz, stelle + 1) . + +stelle auf zweitem halbzeichen : within kanji (satz, stelle) . + +output mode behandeln : + SELECT output mode OF + CASE no output : im markiermode markierung anpassen + CASE out zeichen : zeichen ausgeben; LEAVE output mode behandeln + CASE out feldrest : feldrest neu schreiben + CASE out feld : feldout (satz, stelle) + CASE clear feldrest : feldrest loeschen + END SELECT; + schreibmarke positionieren (stelle) . + +ausgabe verhindern : output mode := no output . + +im markiermode markierung anpassen : + IF markiert THEN markierung anpassen FI . + +markierung anpassen : + IF stelle > alte stelle + THEN markierung verlaengern + ELIF stelle < alte stelle + THEN markierung verkuerzen + FI . + +markierung verlaengern : + invers out (satz, alte stelle, stelle, "", end mark) . + +markierung verkuerzen : + invers out (satz, stelle, alte stelle, end mark, "") . + +zeichen ausgeben : + IF NOT markiert + THEN out (zeichen) + ELIF mark refresh line mode + THEN feldout (satz, stelle); schreibmarke positionieren (stelle) + ELSE out (begin mark); markleft; out (zeichen); out (end mark); markleft + FI . + +markleft : + marklength TIMESOUT left . + +feldrest neu schreiben : + IF NOT markiert + THEN feldrest unmarkiert neu schreiben + ELSE feldrest markiert neu schreiben + FI ; + WHILE postblanks > 0 CAND x cursor <= rand + laenge REP + out (blank); postblanks DECR 1 + PER ; postblanks := 0 . + +feldrest unmarkiert neu schreiben : + schreibmarke positionieren (alte stelle); + out subtext mit randbehandlung (satz, alte stelle, stelle am ende) . + +feldrest markiert neu schreiben : + markierung verlaengern; out subtext mit randbehandlung + (satz, stelle, stelle am ende - 2 * marklength) . + +kommando annehmen und ausfuehren : + kommando annehmen; kommando ausfuehren . + +kommando annehmen : + getchar (zeichen); kommando zurueckweisen falls noetig . + +kommando zurueckweisen falls noetig : + IF NOT write access CAND zeichen ist druckbar + THEN benutzer warnen; kommando ignorieren + FI . + +benutzer warnen : out (piep) . + +kommando ignorieren : + zeichen := ""; LEAVE kommando annehmen und ausfuehren . + +kommando ausfuehren : + neue satzlaenge bestimmen; + alte stelle merken; + IF zeichen ist separator + THEN feldeditor verlassen + ELIF zeichen ist druckbar + THEN fortschreiben + ELSE funktionstasten behandeln + FI . + +neue satzlaenge bestimmen : INT VAR satzlaenge := LENGTH satz . + +feldeditor verlassen : + IF NOT absatzmarke steht THEN blanks abschneiden FI; (*sh*) + push (zeichen); LEAVE feld editieren . + +blanks abschneiden : + INT VAR letzte non blank pos := satzlaenge; + WHILE letzte non blank pos > 0 CAND (satz SUB letzte non blank pos) = blank REP + letzte non blank pos DECR 1 + PER; satz := subtext (satz, 1, letzte non blank pos) . + +zeichen ist druckbar : zeichen >= blank . + +zeichen ist separator : + separator eingestellt CAND pos (separator, zeichen) > 0 . + +fortschreiben : + zeichen in satz eintragen; + IF is kanji esc (zeichen) THEN kanji zeichen schreiben FI; + bei erreichen von limit ueberlauf behandeln . + +zeichen in satz eintragen : + IF hinter dem satz + THEN satz mit leerzeichen auffuellen und zeichen anfuegen + ELIF einfuegen + THEN zeichen vor aktueller position einfuegen + ELSE altes zeichen ersetzen + FI . + +hinter dem satz : stelle > satzlaenge . + +satz mit leerzeichen auffuellen und zeichen anfuegen : + satz AUFFUELLENMIT blank; + zeichen anfuegen; + output mode := out zeichen . + +zeichen anfuegen : satz CAT zeichen; neue satzlaenge bestimmen . +zeichen ignorieren : benutzer warnen; LEAVE kommando ausfuehren . + +zeichen vor aktueller position einfuegen : + insert char (satz, zeichen, stelle); + neue satzlaenge bestimmen; + output mode := out feldrest . + +altes zeichen ersetzen : + replace (satz, stelle, zeichen); + IF stelle auf erstem halbzeichen + THEN output mode := out feldrest; replace (satz, stelle + 1, blank) + ELSE output mode := out zeichen + FI . + +kanji zeichen schreiben : + alte stelle merken; + stelle INCR 1; getchar (zeichen); + IF zeichen < ""64"" THEN zeichen := ""64"" FI; + IF hinter dem satz + THEN zeichen anfuegen + ELIF einfuegen + THEN zeichen vor aktueller position einfuegen + ELSE replace (satz, stelle, zeichen) + FI ; + output mode := out feldrest . + +bei erreichen von limit ueberlauf behandeln : (*sh*) + IF satzlaenge kritisch + THEN in naechste zeile falls moeglich + ELSE stelle INCR 1 + FI . + +satzlaenge kritisch : + IF stelle >= satzlaenge + THEN satzlaenge = limit + ELSE satzlaenge = limit + 1 + FI . + +in naechste zeile falls moeglich : + IF fliesstext AND umbruch moeglich OR NOT fliesstext AND stelle >= satzlaenge + THEN in naechste zeile + ELSE stelle INCR 1 + FI . + +umbruch moeglich : + INT CONST st := stelle; stelle := limit; + INT CONST ltzt wortanf := letzter wortanfang (satz); + stelle := st; einrueckposition (satz) < ltzt wortanf . + +in naechste zeile : + IF fliesstext + THEN ueberlauf und oder umbruch + ELSE ueberlauf ohne umbruch + FI . + +ueberlauf und oder umbruch : + INT VAR umbruchpos := 1; + umbruchposition bestimmen; + loeschposition bestimmen; + IF stelle = satzlaenge + THEN ueberlauf mit oder ohne umbruch + ELSE umbruch mit oder ohne ueberlauf + FI . + +umbruchposition bestimmen : + umbruchstelle := stelle; + stelle := satzlaenge; + umbruchpos := max (umbruchpos, letzter wortanfang (satz)); + stelle := umbruchstelle . + +loeschposition bestimmen : + INT VAR loeschpos := umbruchpos; + WHILE davor noch blank REP loeschpos DECR 1 PER . + +davor noch blank : + loeschpos > ganz links CAND (satz SUB (loeschpos - 1)) = blank . + +ganz links : max (1, marke) . + +ueberlauf mit oder ohne umbruch : + IF zeichen = blank OR loeschpos = ganz links + THEN stelle := 1; ueberlauf ohne umbruch + ELSE ueberlauf mit umbruch + FI . + +ueberlauf ohne umbruch : push (cr) . + +ueberlauf mit umbruch : + ausgabe verhindern; + umbruchkommando aufbereiten; + auf loeschposition positionieren . + +umbruchkommando aufbereiten : + zeichen := hop + rubout + inscr; + satzrest := subtext (satz, umbruchpos); + zeichen CAT satzrest; + IF stelle ist im umgebrochenen teil + THEN insert char (zeichen, backcr, max (stelle - umbruchpos + 1, 0) + 4); + zeichen CAT backcr + FI ; + push (zeichen) . + +stelle ist im umgebrochenen teil : stelle >= loeschpos . + +auf loeschposition positionieren : stelle := loeschpos . + +umbruch mit oder ohne ueberlauf : + umbruchposition anpassen; + IF stelle ist im umgebrochenen teil + THEN umbruch mit ueberlauf + ELSE umbruch ohne ueberlauf + FI . + +umbruchposition anpassen : + IF zeichen = blank + THEN umbruchpos := stelle + 1; + umbruchposition bestimmen; + neue loeschposition bestimmen + FI . + +neue loeschposition bestimmen : + loeschpos := umbruchpos; + WHILE davor noch blank AND stelle noch nicht erreicht REP loeschpos DECR 1 PER . + +stelle noch nicht erreicht : loeschpos > stelle + 1 . + +umbruch mit ueberlauf : ueberlauf mit umbruch . + +umbruch ohne ueberlauf : + zeichen := inscr; + satzrest := subtext (satz, umbruchpos); + zeichen CAT satzrest; + zeichen CAT up char + backcr; + umbruchstelle INCR 1; umbruch verschoben := verschoben; + satz := subtext (satz, 1, loeschpos - 1); + schreibmarke positionieren (loeschpos); feldrest loeschen; + output mode := out feldrest; + push (zeichen) . + +funktionstasten behandeln : + SELECT pos (kommandos, zeichen) OF + CASE c hop : hop kommandos behandeln + CASE c esc : esc kommandos behandeln + CASE c right : nach rechts oder ueberlauf + CASE c left : wenn moeglich ein schritt nach links + CASE c tab : zur naechsten tabulator position + CASE c dezimal : dezimalen schreiben + CASE c rubin : einfuegen umschalten + CASE c rubout : ein zeichen loeschen + CASE c abscr, c inscr, c down : feldeditor verlassen + CASE c up : eine zeile nach oben (*sh*) + CASE c cr : ggf absatz erzeugen + CASE c mark : markieren umschalten + CASE c backcr : zurueck zur umbruchstelle + OTHERWISE : sondertaste behandeln + END SELECT . + +kommandos : + LET c hop = 1, c right = 2, + c up = 3, c left = 4, + c tab = 5, c down = 6, + c rubin = 7, c rubout = 8, + c cr = 9, c mark = 10, + c abscr = 11, c inscr = 12, + c dezimal = 13, c esc = 14, + c backcr = 15; + + ""1""2""3""8""9""10""11""12""13""16""17""18""19""27""20"" . + +dezimalen schreiben : IF write access THEN dezimaleditor (satz) FI . + +zurueck zur umbruchstelle: + IF umbruch stelle > 0 THEN stelle := umbruch stelle FI; + IF verschoben <> umbruch verschoben + THEN verschoben := umbruch verschoben; output mode := out feld + FI . + +hop kommandos behandeln : + TEXT VAR zweites zeichen; getchar (zweites zeichen); + zeichen CAT zweites zeichen; + SELECT pos (hop kommandos, zweites zeichen) OF + CASE h hop : nach links oben + CASE h right : nach rechts blaettern + CASE h left : nach links blaettern + CASE h tab : tab position definieren oder loeschen + CASE h rubin : zeile splitten + CASE h rubout : loeschen oder rekombinieren + CASE h cr, h up, h down : feldeditor verlassen + OTHERWISE : zeichen ignorieren + END SELECT . + +hop kommandos : + LET h hop = 1, h right = 2, + h up = 3, h left = 4, + h tab = 5, h down = 6, + h rubin = 7, h rubout = 8, + h cr = 9; + + ""1""2""3""8""9""10""11""12""13"" . + +nach links oben : + stelle := max (marke, anfang) + verschoben; feldeditor verlassen . + +nach rechts blaettern : + INT CONST rechter rand := stelle am ende - markierausgleich; + IF stelle ist am rechten rand + THEN stelle INCR laenge - 2 * markierausgleich + ausgleich fuer doppelzeichen + ELSE stelle := rechter rand + FI ; + IF satzlaenge <= limit THEN stelle := min (stelle, limit) FI; + alte einrueckposition mitziehen . + +stelle ist am rechten rand : + stelle auf erstem halbzeichen CAND stelle = rechter rand - 1 + COR stelle = rechter rand . + +ausgleich fuer doppelzeichen : stelle - rechter rand . + +nach links blaettern : + INT CONST linker rand := stelle am anfang; + IF stelle = linker rand + THEN stelle DECR laenge - 2 * markierausgleich + ELSE stelle := linker rand + FI ; + stelle := max (ganz links, stelle); + alte einrueckposition mitziehen . + +tab position definieren oder loeschen : + IF stelle > LENGTH tabulator + THEN tabulator AUFFUELLENMIT right; tabulator CAT dach + ELSE replace (tabulator, stelle, neues tab zeichen) + FI ; + feldeditor verlassen . + +neues tab zeichen : + IF (tabulator SUB stelle) = right THEN dach ELSE right FI . + +zeile splitten : + IF write access THEN feldeditor verlassen ELSE zeichen ignorieren FI . + +loeschen oder rekombinieren : + IF NOT write access + THEN zeichen ignorieren + ELIF hinter dem satz + THEN zeilen rekombinieren + ELIF auf erstem zeichen + THEN ganze zeile loeschen + ELSE zeilenrest loeschen + FI . + +zeilen rekombinieren : feldeditor verlassen . +auf erstem zeichen : stelle = 1 . +ganze zeile loeschen : satz := ""; feldeditor verlassen . + +zeilenrest loeschen : + change (satz, stelle, satzlaenge, ""); + output mode := clear feldrest . + +esc kommandos behandeln : + getchar (zweites zeichen); + zeichen CAT zweites zeichen; + auf exit pruefen; + SELECT pos (esc kommandos, zweites zeichen) OF + CASE e hop : lernmodus umschalten + CASE e right : zum naechsten wort + CASE e left : zum vorigen wort + OTHERWISE : belegte taste ausfuehren + END SELECT . + +auf exit pruefen : + IF pos (res, zweites zeichen) > 0 THEN feldeditor verlassen FI . + +esc kommandos : + LET e hop = 1, + e right = 2, + e left = 3; + + ""1""2""8"" . + +lernmodus umschalten : + IF lernmodus THEN lernmodus ausschalten ELSE lernmodus einschalten FI; + feldeditor verlassen . + +lernmodus ausschalten : + lernmodus := FALSE; + belegbare taste erfragen; + audit := subtext (audit, 1, LENGTH audit - 2); + IF taste = hop + THEN (* lernsequenz nicht auf taste legen *) (* 16.08.85 -ws- *) + ELSE lernsequenz auf taste legen (taste, audit) + FI ; + audit := "" . + +belegbare taste erfragen : + TEXT VAR taste; getchar (taste); + WHILE taste ist reserviert REP + benutzer warnen; getchar (taste) + PER . + +taste ist reserviert : (* 16.08.85 -ws- *) + taste <> hop CAND pos (reservierte feldeditor tasten, taste) > 0 . + +lernmodus einschalten : audit := ""; lernmodus := TRUE . + +zum vorigen wort : + IF stelle > 1 + THEN stelle DECR 1; stelle := letzter wortanfang (satz); + alte einrueckposition mitziehen; + IF (satz SUB stelle) <> blank THEN LEAVE zum vorigen wort FI + FI ; + feldeditor verlassen . + +zum naechsten wort : + IF kein naechstes wort THEN feldeditor verlassen FI . + +kein naechstes wort : + BOOL VAR im alten wort := TRUE; + INT VAR i; + FOR i FROM stelle UPTO satzlaenge REP + IF im alten wort + THEN im alten wort := (satz SUB i) <> blank + ELIF (satz SUB i) <> blank + THEN stelle := i; LEAVE kein naechstes wort WITH FALSE + FI + PER; + TRUE . + +belegte taste ausfuehren : + IF ist kommando taste + THEN feldeditor verlassen + ELSE gelerntes ausfuehren + FI . + +ist kommando taste : taste enthaelt kommando (zweites zeichen) . + +gelerntes ausfuehren : + push (lernsequenz auf taste (zweites zeichen)) . (*sh*) + +nach rechts oder ueberlauf : + IF fliesstext COR stelle < limit OR satzlaenge > limit + THEN nach rechts + ELSE auf anfang der naechsten zeile + FI . + +nach rechts : + IF stelle auf erstem halbzeichen THEN stelle INCR 2 ELSE stelle INCR 1 FI; + alte einrueckposition mitziehen . + +auf anfang der naechsten zeile : push (abscr) . + +nach links : stelle DECR 1; alte einrueckposition mitziehen . + +alte einrueckposition mitziehen : + IF satz ist leerzeile + THEN alte einrueckposition := stelle + ELSE alte einrueckposition := min (stelle, einrueckposition (satz)) + FI . + +satz ist leerzeile : + satz = "" OR satz = blank . + +wenn moeglich ein schritt nach links : + IF stelle = ganz links + THEN zeichen ignorieren + ELSE nach links + FI . + +zur naechsten tabulator position : + bestimme naechste explizite tabulator position; + IF tabulator gefunden + THEN explizit tabulieren + ELIF stelle <= satzlaenge + THEN implizit tabulieren + ELSE auf anfang der naechsten zeile + FI . + +bestimme naechste explizite tabulator position : + INT VAR tab position := pos (tabulator, dach, stelle + 1); + IF tab position > limit AND satzlaenge <= limit + THEN tab position := 0 + FI . + +tabulator gefunden : tab position <> 0 . + +explizit tabulieren : stelle := tab position; push (dezimal) . + +implizit tabulieren : + tab position := einrueckposition (satz); + IF stelle < tab position + THEN stelle := tab position + ELSE stelle := satzlaenge + 1 + FI . + +einfuegen umschalten : + IF NOT write access THEN zeichen ignorieren FI; (*sh*) + einfuegen := NOT einfuegen; + IF einfuegen THEN einfuegen optisch anzeigen FI; + feldeditor verlassen . + +einfuegen optisch anzeigen : + IF markiert + THEN out (begin mark); markleft; out (dach left); warten; + out (end mark); markleft + ELSE out (dach left); warten; + IF stelle auf erstem halbzeichen + THEN out text (satz, stelle, stelle + 1) + ELSE out text (satz, stelle, stelle) + FI + FI . + +markiert : marke > 0 . +dach left : ""94""8"" . + +warten : + TEXT VAR t := incharety (2); + kommando CAT t; IF lernmodus THEN audit CAT t FI . + +ein zeichen loeschen : + IF NOT write access THEN zeichen ignorieren FI; (*sh*) + IF zeichen davor soll geloescht werden + THEN nach links oder ignorieren + FI ; + IF NOT hinter dem satz THEN aktuelles zeichen loeschen FI . + +zeichen davor soll geloescht werden : + hinter dem satz COR markiert . + +nach links oder ignorieren : + IF stelle > ganz links + THEN nach links (*sh*) + ELSE zeichen ignorieren + FI . + +aktuelles zeichen loeschen : + stelle korrigieren; alte stelle merken; + IF stelle auf erstem halbzeichen + THEN delete char (satz, stelle); + postblanks INCR 1 + FI ; + delete char (satz, stelle); + postblanks INCR 1; + neue satzlaenge bestimmen; + output mode := out feldrest . + +eine zeile nach oben : (*sh*) + IF NOT absatzmarke steht CAND NOT ist teil eines umbruchkommandos + THEN blanks abschneiden + FI ; + push (zeichen); LEAVE feld editieren . + +ist teil eines umbruchkommandos : (kommando SUB kommandozeiger) = backcr . + +ggf absatz erzeugen : (*sh*) + IF write access + THEN IF NOT absatzmarke steht THEN blanks abschneiden FI; + IF stelle > LENGTH satz AND fliesstext AND NOT absatzmarke steht + THEN satz CAT blank + FI + FI ; push (zeichen); LEAVE feld editieren . + +markieren umschalten : + IF markiert + THEN marke := 0; maxschreibpos INCR marklength; cpos DECR marklength + ELSE marke := stelle; maxschreibpos DECR marklength; cpos INCR marklength; + verschieben wenn erforderlich + FI ; + feldeditor verlassen . + +sondertaste behandeln : push (esc + zeichen) . +END PROC feldeditor; + +PROC dezimaleditor (TEXT VAR satz) : + INT VAR dezimalanfang := stelle; + zeichen einlesen; + IF dezimalstartzeichen CAND ueberschreibbar THEN dezimalen schreiben FI; + push (zeichen) . + +zeichen einlesen : TEXT VAR zeichen; getchar (zeichen) . +dezimalzeichen : pos (dezimalen, zeichen) > 0 AND nicht separator . +dezimalstartzeichen : pos (startdezimalen, zeichen) > 0 AND nicht separator . +dezimalen : "0123456789" . +startdezimalen : "+-0123456789" . +nicht separator : pos (separator, zeichen) = 0 . + +ueberschreibbar : + dezimalanfang > LENGTH satz OR + pos (ueberschreibbare zeichen, satz SUB dezimalanfang) > 0 . + +ueberschreibbare zeichen : " ,.+-0123456789" . + +dezimalen schreiben : + REP + dezimale in satz eintragen; + dezimalen zeigen; + zeichen einlesen; + dezimalanfang DECR 1 + UNTIL dezimaleditor beendet PER; + stelle INCR 1 . + +dezimale in satz eintragen : + IF dezimalanfang > LENGTH satz + THEN satz AUFFUELLENMIT blank; satz CAT zeichen + ELSE delete char (satz, dezimalanfang); insert char (satz, zeichen, stelle) + FI . + +dezimalen zeigen : + INT VAR min dezimalschreibpos := max (min schreibpos, dezimalanfang); + IF markiert THEN markiert zeigen ELSE unmarkiert zeigen FI; + schreibmarke positionieren (stelle) . + +markiert : marke > 0 . + +markiert zeigen : + invers out (satz, min dezimalschreibpos, stelle, "", end mark); + out (zeichen) . + +unmarkiert zeigen : + schreibmarke positionieren (min dezimalschreibpos); + out subtext (satz, min dezimalschreibpos, stelle) . + +dezimaleditor beendet : + NOT dezimalzeichen OR + dezimalanfang < max (min schreibpos, marke) OR + NOT ueberschreibbar . +END PROC dezimaleditor; + +BOOL PROC is editget : + editget modus +END PROC is editget ; + +PROC get editline (TEXT VAR editline, INT VAR editpos, editmarke) : + IF editget modus + THEN editline := alter editsatz; + editpos := stelle + FI ; + editmarke := marke +END PROC get editline; + +PROC put editline (TEXT CONST editline, INT CONST editpos, editmarke) : + IF editget modus + THEN alter editsatz := editline; + stelle := max (editpos, 1); + marke := max (editmarke, 0) + FI +END PROC put editline; + +BOOL PROC within kanji (TEXT CONST satz, INT CONST stelle) : + count directly prefixing kanji esc bytes; + number of kanji esc bytes is odd . + +count directly prefixing kanji esc bytes : + INT VAR pos := stelle - 1, kanji esc bytes := 0; + WHILE pos > 0 CAND is kanji esc (satz SUB pos) REP + kanji esc bytes INCR 1; pos DECR 1 + PER . + +number of kanji esc bytes is odd : + (kanji esc bytes AND 1) <> 0 . +END PROC within kanji; + +BOOL PROC is kanji esc (TEXT CONST char) : (*sh*) + two byte mode CAND + (char >= ""129"" AND char <= ""159"" OR char >= ""224"" AND char <= ""239"") +END PROC is kanji esc; + +BOOL PROC two bytes : two byte mode END PROC two bytes; + +PROC two bytes (BOOL CONST new mode) : + two byte mode := new mode +END PROC two bytes; + +PROC outtext (TEXT CONST source, INT CONST from, to) : + out subtext mit randbehandlung (source, from, to); + INT VAR trailing; + IF from <= LENGTH source + THEN trailing := to - LENGTH source + ELSE trailing := to - from + 1 + FI ; trailing TIMESOUT blank +END PROC outtext; + +PROC out subtext mit randbehandlung (TEXT CONST satz, INT CONST von, bis) : + IF von > bis + THEN + ELIF bis >= LENGTH satz COR NOT within kanji (satz, bis + 1) + THEN out subtext mit anfangsbehandlung (satz, von, bis) + ELSE out subtext mit anfangsbehandlung (satz, von, bis - 1); out (blank) + FI +END PROC out subtext mit randbehandlung; + +PROC out subtext mit anfangsbehandlung (TEXT CONST satz, INT CONST von, bis) : + IF von > bis + THEN + ELIF von = 1 COR NOT within kanji (satz, von) + THEN out subtext (satz, von, bis) + ELSE out (blank); out subtext (satz, von + 1, bis) + FI +END PROC out subtext mit anfangsbehandlung; + +PROC get cursor : get cursor (spalte, zeile) END PROC get cursor; + +INT PROC x cursor : get cursor; spalte END PROC x cursor; + +BOOL PROC write permission : write access END PROC write permission; + +PROC push (TEXT CONST ausfuehrkommando) : + IF ausfuehrkommando = "" (*sh*) + THEN + ELIF kommando = "" + THEN kommando := ausfuehrkommando + ELIF (kommando SUB kommando zeiger - 1) = ausfuehrkommando + THEN kommando zeiger DECR 1 + ELIF replace moeglich + THEN kommando zeiger DECR laenge des ausfuehrkommandos; + replace (kommando, kommando zeiger, ausfuehrkommando) + ELSE insert char (kommando, ausfuehrkommando, kommando zeiger) + FI . + +replace moeglich : + INT CONST laenge des ausfuehrkommandos := LENGTH ausfuehrkommando; + kommando zeiger > laenge des ausfuehrkommandos . +END PROC push; + +PROC type (TEXT CONST ausfuehrkommando) : + kommando CAT ausfuehrkommando +END PROC type; + +INT PROC stelle am anfang : anfang + verschoben END PROC stelle am anfang; + +INT PROC stelle am ende : stelle am anfang+laenge-1 END PROC stelle am ende; + +INT PROC markierausgleich : SIGN marke * marklength END PROC markierausgleich; + +PROC verschieben wenn erforderlich : + IF stelle > max schreibpos + THEN verschiebe (stelle - max schreibpos) + ELIF stelle < min schreibpos + THEN verschiebe (stelle - min schreibpos) + FI +END PROC verschieben wenn erforderlich; + +PROC verschiebe (INT CONST i) : + verschoben INCR i; + min schreibpos INCR i; + max schreibpos INCR i; + cpos DECR i; + output mode := out feld; + schreibmarke positionieren (stelle) (* 11.05.85 -ws- *) +END PROC verschiebe; + +PROC konstanten neu berechnen : + min schreibpos := anfang + verschoben; + IF min schreibpos < 0 (* 17.05.85 -ws- *) + THEN min schreibpos DECR verschoben; verschoben := 0 + FI ; + max schreibpos := min schreibpos + laenge - 1 - markierausgleich; + cpos := rand + laenge - max schreibpos +END PROC konstanten neu berechnen; + +PROC schreibmarke positionieren (INT CONST sstelle) : + cursor (cpos + sstelle, zeile) +END PROC schreibmarke positionieren; + +PROC simple feldout (TEXT CONST satz, INT CONST dummy) : + (* PRECONDITION : NOT markiert AND verschoben = 0 *) + (* AND feldrest schon geloescht *) + schreibmarke an feldanfang positionieren; + out subtext mit randbehandlung (satz, anfang, anfang + laenge - 1); + IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI . + +schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) . +END PROC simple feldout; + +PROC feldout (TEXT CONST satz, INT CONST sstelle) : + schreibmarke an feldanfang positionieren; + feld ausgeben; + feldrest loeschen; + IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI . + +schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) . + +feld ausgeben : + INT VAR von := anfang + verschoben, bis := von + laenge - 1; + IF nicht markiert + THEN unmarkiert ausgeben + ELIF markiertes nicht sichtbar + THEN unmarkiert ausgeben + ELSE markiert ausgeben + FI . + +nicht markiert : marke <= 0 . + +markiertes nicht sichtbar : + bis DECR marklength * (1 + SIGN sstelle); marke > bis + 1 . + +unmarkiert ausgeben : + out subtext mit randbehandlung (satz, von, bis) . + +markiert ausgeben : + INT VAR smarke := max (von, marke); + out text (satz, von, smarke - 1); out (begin mark); + verschiedene feldout modes behandeln . + +verschiedene feldout modes behandeln : + IF sstelle = 0 + THEN out subtext mit randbehandlung (satz, smarke, bis); out (end mark) + ELSE out text (satz, smarke, zeilenrand); out (end mark); (*sh*) + out subtext mit randbehandlung (satz, sstelle, bis) + FI . + +zeilenrand : min (bis, sstelle - 1) . +END PROC feldout; + +PROC absatzmarke schreiben (BOOL CONST schreiben) : + IF fliesstext AND nicht markiert + THEN cursor (rand + 1 + laenge, zeile); + out (absatzmarke) ; + absatzmarke steht := TRUE + FI . + +nicht markiert : marke <= 0 . + +absatzmarke : + IF NOT schreiben + THEN " " + ELIF marklength > 0 + THEN ""15""14"" + ELSE ""15" "14" " + FI . +END PROC absatzmarke schreiben; + +PROC invers out (TEXT CONST satz, INT CONST von, bis, TEXT CONST pre, post) : + IF mark refresh line mode + THEN feldout (satz, stelle) + ELSE schreibmarke positionieren (von); + out (begin mark); markleft; out (pre); + out text (satz, von, bis - 1); out (post) + FI . + +markleft : + marklength TIMESOUT left . + +END PROC invers out; + +PROC feldrest loeschen : + IF rand + laenge < maxbreite COR invertierte darstellung + THEN INT VAR x; get cursor (x, zeile); + (rand + laenge - x + 1 + absatz ausgleich) TIMESOUT blank; (*sh*) + cursor (x, zeile) + ELSE out (clear eol); absatzmarke steht := FALSE + FI +END PROC feldrest loeschen; + +OP AUFFUELLENMIT (TEXT VAR satz, TEXT CONST fuellzeichen) : + INT VAR i; + FOR i FROM stelle - LENGTH satz DOWNTO 2 REP + satz CAT fuellzeichen + PER +END OP AUFFUELLENMIT; + +INT PROC einrueckposition (TEXT CONST satz) : (*sh*) + IF fliesstext AND satz = blank + THEN anfang + ELSE max (pos (satz, ""33"", ""254"", 1), 1) + FI +END PROC einrueckposition; + +INT PROC letzter wortanfang (TEXT CONST satz) : (*sh*) + INT CONST ganz links := max (1, marke); + BOOL VAR noch nicht im neuen wort := TRUE; + INT VAR i; + FOR i FROM stelle DOWNTO ganz links REP + IF noch nicht im neuen wort + THEN noch nicht im neuen wort := char = blank + ELIF is kanji esc (char) + THEN LEAVE letzter wortanfang WITH i + ELIF nicht mehr im neuen wort + THEN LEAVE letzter wortanfang WITH i + 1 + FI + PER ; + ganz links . + +char : satz SUB i . + +nicht mehr im neuen wort : char = blank COR within kanji (satz, i) . +END PROC letzter wortanfang; + +PROC getchar (TEXT VAR zeichen) : + IF kommando = "" + THEN inchar (zeichen); IF lernmodus THEN audit CAT zeichen FI + ELSE zeichen := kommando SUB kommando zeiger; + kommando zeiger INCR 1; + IF kommando zeiger > LENGTH kommando + THEN kommando zeiger := 1; kommando := "" + FI ; + IF LENGTH kommando - kommando zeiger < 3 + THEN kommando CAT inchety + FI + FI . +END PROC getchar; + +TEXT PROC inchety : + IF lernmodus + THEN TEXT VAR t := incharety; audit CAT t; t + ELSE incharety + FI +END PROC inchety; + +BOOL PROC is incharety (TEXT CONST muster) : + IF kommando = "" + THEN TEXT CONST t := inchety; + IF t = muster THEN TRUE ELSE kommando := t; FALSE FI + ELIF (kommando SUB kommando zeiger) = muster + THEN kommando zeiger INCR 1; + IF kommando zeiger > LENGTH kommando + THEN kommando zeiger := 1; kommando := "" + FI ; + TRUE + ELSE FALSE + FI +END PROC is incharety; + +TEXT PROC getcharety : + IF kommando = "" + THEN inchety + ELSE TEXT CONST t := kommando SUB kommando zeiger; + kommando zeiger INCR 1; + IF kommando zeiger > LENGTH kommando + THEN kommando zeiger := 1; kommando := "" + FI ; t + FI +END PROC getcharety; + +PROC get editcursor (INT VAR x, y) : (*sh*) + IF actual editor > 0 THEN aktualisiere bildparameter FI; + x := rand - (anfang + verschoben - 1 - markierausgleich) + stelle; + y := zeile . + + aktualisiere bildparameter : + INT VAR old x, old y; get cursor (old x, old y); + dateizustand holen; bildausgabe steuern; satznr zeigen; + fenster zeigen; zeile := bildrand + zeilennr; cursor (old x, old y) . +END PROC get editcursor; + +(************************* Zugriff auf Feldstatus *************************). + +stelle : feldstatus.stelle . +alte stelle : feldstatus.alte stelle . +rand : feldstatus.rand . +limit : feldstatus.limit . +anfang : feldstatus.anfang . +marke : feldstatus.marke . +laenge : feldstatus.laenge . +verschoben : feldstatus.verschoben . +einfuegen : feldstatus.einfuegen . +fliesstext : feldstatus.fliesstext . +write access : feldstatus.write access . +tabulator : feldstatus.tabulator . + +(***************************************************************************) + +LET undefinierter bereich = 0, nix = 1, + bildzeile = 2, akt satznr = 2, + abschnitt = 3, ueberschrift = 3, + bild = 4, fehlermeldung = 4; + +LET BILDSTATUS = STRUCT (INT feldlaenge, kurze feldlaenge, + bildrand, bildlaenge, kurze bildlaenge, + ueberschriftbereich, bildbereich, + erster neusatz, letzter neusatz, + old zeilennr, old lineno, old mark lineno, + BOOL zeileneinfuegen, old line update, + TEXT satznr pre, ueberschrift pre, + ueberschrift text, ueberschrift post, old satz, + FRANGE old range, + FILE file), + EDITSTATUS = STRUCT (FELDSTATUS feldstatus, BILDSTATUS bildstatus), + max editor = 10, + EDITSTACK = ROW max editor EDITSTATUS; + +BILDSTATUS VAR bildstatus ; +EDITSTACK VAR editstack; + +ROW max editor INT VAR einrueckstack; + +BOOL VAR markiert; +TEXT VAR filename, tab, bildsatz, bildzeichen, fehlertext, + akt bildsatz ; +INT VAR zeilennr, satznr, bildanfang, bildmarke, feldmarke, + actual editor := 0, max used editor := 0, + letzer editor auf dieser datei, + alte einrueckposition := 1; + +INT PROC aktueller editor : actual editor END PROC aktueller editor; + +INT PROC groesster editor : max used editor END PROC groesster editor; + +(****************************** bildeditor *******************************) + +PROC bildeditor (TEXT CONST res, PROC (TEXT CONST) kommando interpreter) : + evtl fehler behandeln; + enable stop; + TEXT VAR reservierte tasten := ""11""12""27"bf" ; + reservierte tasten CAT res ; + INT CONST my highest editor := max used editor; + laenge := feldlaenge; + konstanten neu berechnen; + REP + markierung justieren; + altes feld nachbereiten; + feldlaenge einstellen; + ueberschrift zeigen; + fenster zeigen ; + zeile bereitstellen; + zeile editieren; + kommando ausfuehren + PER . + +evtl fehler behandeln : + IF is error + THEN fehlertext := errormessage; + IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI; + clear error + ELSE fehlertext := "" + FI . + +markierung justieren : + IF bildmarke > 0 + THEN IF satznr <= bildmarke + THEN bildmarke := satznr; + stelle := max (stelle, feldmarke); + marke := feldmarke + ELSE marke := 1 + FI + FI . + +zeile bereitstellen : IF hinter letztem satz THEN insert record (file) FI . +hinter letztem satz : lineno (file) > lines (file) . + +altes feld nachbereiten : + IF old line update AND lineno (file) <> old lineno + THEN IF verschoben <> 0 + THEN verschoben := 0; konstanten neu berechnen; + FI ; + INT CONST alte zeilennr := old lineno - bildanfang + 1; + IF alte zeilennr > 0 AND alte zeilennr <= aktuelle bildlaenge + THEN INT CONST m := marke; + IF lineno (file) < old lineno + THEN marke := 0 + ELIF old lineno = bildmarke + THEN marke := min (feldmarke, LENGTH old satz + 1) + ELSE marke := min (marke, LENGTH old satz + 1) + FI ; + zeile := bildrand + alte zeilennr; + feldout (old satz, 0); marke := m + FI + FI ; + old line update := FALSE; old satz := "" . + +feldlaenge einstellen : + INT CONST alte laenge := laenge; + IF zeilennr > kurze bildlaenge + THEN laenge := kurze feldlaenge + ELSE laenge := feldlaenge + FI ; + IF laenge <> alte laenge + THEN konstanten neu berechnen + FI . + +zeile editieren : + zeile := bildrand + zeilennr; + exec (PROC (TEXT VAR, TEXT CONST) feldeditor, file, reservierte tasten); + old lineno := satznr; + IF markiert oder verschoben + THEN old line update := TRUE; read record (file, old satz) + FI . + +markiert oder verschoben : markiert COR verschoben <> 0 . + +kommando ausfuehren : + getchar (bildzeichen); + SELECT pos (kommandos, bildzeichen) OF + CASE x hop : hop kommando verarbeiten + CASE x esc : esc kommando verarbeiten + CASE x up : zum vorigen satz + CASE x down : zum folgenden satz + CASE x rubin : zeicheneinfuegen umschalten + CASE x mark : markierung umschalten + CASE x cr : eingerueckt mit cr (* 08.06.85 -ws- *) + CASE x inscr : eingerueckt zum folgenden satz + CASE x abscr : zum anfang des folgenden satzes + END SELECT . + +kommandos : + LET x hop = 1, x up = 2, + x down = 3, x rubin = 4, + x cr = 5, x mark = 6, + x abscr = 7, x inscr = 8, + x esc = 9; + + ""1""3""10""11""13""16""17""18""27"" . + +zeicheneinfuegen umschalten : + rubin segment in ueberschrift eintragen; + neu (ueberschrift, nix) . + +rubin segment in ueberschrift eintragen : + replace (ueberschrift text, 9, rubin segment) . + +rubin segment : + IF einfuegen THEN "RUBIN" ELSE "....." FI . + +hop kommando verarbeiten : + getchar (bildzeichen); + read record (file, bildsatz); + SELECT pos (hop kommandos, bildzeichen) OF + CASE y hop : nach oben + CASE y cr : neue seite + CASE y up : zurueckblaettern + CASE y down : weiterblaettern + CASE y tab : put tabs (file, tabulator); neu (ueberschrift, nix) + CASE y rubout : zeile loeschen + CASE y rubin : zeileneinfuegen umschalten + END SELECT . + +hop kommandos : + LET y hop = 1, y up = 2, + y tab = 3, y down = 4, + y rubin = 5, y rubout = 6, + y cr = 7; + + ""1""3""9""10""11""12""13"" . + +zeileneinfuegen umschalten : + zeileneinfuegen := NOT zeileneinfuegen; + IF zeileneinfuegen + THEN zeile aufspalten; logisches eof setzen + ELSE leere zeile am ende loeschen; logisches eof loeschen + FI ; restbild zeigen . + +zeile aufspalten : + IF stelle <= LENGTH bildsatz OR stelle = 1 + THEN loesche ggf trennende blanks und spalte zeile + FI . + +loesche ggf trennende blanks und spalte zeile: (* 26.06.84 -bk- *) + INT VAR first non blank pos := stelle; + WHILE first non blank pos <= length (bildsatz) CAND + (bildsatz SUB first non blank pos) = blank REP + first non blank pos INCR 1 + PER ; + split line and indentation; (*sh*) + first non blank pos := stelle - 1; + WHILE first non blank pos >= 1 CAND + (bildsatz SUB first non blank pos) = blank REP + first non blank pos DECR 1 + PER; + bildsatz := subtext (bildsatz, 1, first non blank pos); + write record (file, bildsatz) . + +split line and indentation : + split line (file, first non blank pos, TRUE) . + +logisches eof setzen : + down (file); col (file, 1); + set range (file, 1, 1, old range); up (file) . + +leere zeile am ende loeschen : + to line (file, lines (file)); + IF len (file) = 0 THEN delete record (file) FI; + to line (file, satznr) . + +logisches eof loeschen : + col (file, stelle); set range (file, old range) . + +restbild zeigen : + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + rest segment in ueberschrift eintragen; + neu (ueberschrift, abschnitt) . + +rest segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 25, rest segment) . + +rest segment : + IF zeileneinfuegen THEN "REST" ELSE "...." FI . + +esc kommando verarbeiten : + getchar (bildzeichen); + eventuell zeichen zurueckweisen; (* 04.05.85 -ws- *) + IF taste ist reserviert + THEN belegte taste ausfuehren + ELSE fest vordefinierte esc funktion + FI ; ende nach quit . + +eventuell zeichen zurueckweisen : (* 04.05.85 -ws- *) + IF NOT write access CAND NOT erlaubte taste + THEN benutzer warnen; LEAVE kommando ausfuehren + FI . + +erlaubte taste : pos (zulaessige zeichen, bildzeichen) > 0 . +zulaessige zeichen : res + ""1""2""8""27"bfq" . +benutzer warnen : out (piep) . + +ende nach quit : + IF max used editor < my highest editor THEN LEAVE bildeditor FI . + +taste ist reserviert : pos (res, bildzeichen) > 0 . + +fest vordefinierte esc funktion : + read record (file, bildsatz); + SELECT pos (esc kommandos, bildzeichen) OF + CASE z hop : lernmodus umschalten + CASE z esc : kommandodialog versuchen + CASE z left : zum vorigen wort + CASE z right : zum naechsten wort + CASE z b : bild an aktuelle zeile angleichen + CASE z f : belegte taste ausfuehren + CASE z rubout : markiertes vorsichtig loeschen + CASE z rubin : vorsichtig geloeschtes einfuegen + OTHERWISE : belegte taste ausfuehren + END SELECT . + +esc kommandos : + LET z hop = 1, z right = 2, + z left = 3, z rubin = 4, + z rubout = 5, z esc = 6, + z b = 7, z f = 8; + + ""1""2""8""11""12""27"bf" . + +zum vorigen wort : + IF vorgaenger erlaubt + THEN vorgaenger; read record (file, bildsatz); + stelle := LENGTH bildsatz + 1; push (esc + left) + FI . + +vorgaenger erlaubt : + satznr > max (1, bildmarke) . + +zum naechsten wort : + IF nicht auf letztem satz THEN weitersuchen wenn nicht gefunden FI . + +nicht auf letztem satz : line no (file) < lines (file) . + +weitersuchen wenn nicht gefunden : + nachfolgenden satz holen; + IF (nachfolgender satz SUB anfang) = blank + THEN push (abscr + esc + right) + ELSE push (abscr) + FI . + +nachfolgenden satz holen : + down (file); read record (file, nachfolgender satz); up (file) . + +bild an aktuelle zeile angleichen : + anfang INCR verschoben; verschoben := 0; + margin segment in ueberschrift eintragen; + neu (ueberschrift, bild) . + +margin segment in ueberschrift eintragen : + replace (ueberschrift text, 2, margin segment) . + +margin segment : + IF anfang <= 1 + THEN "......" + ELSE TEXT VAR margin text := "M" + text (anfang); + (6 - LENGTH margin text) * "." + margin text + FI . + +belegte taste ausfuehren : + kommando analysieren (bildzeichen, PROC(TEXT CONST) kommando interpreter) . + +kommandodialog versuchen: + IF fenster ist zu schmal fuer dialog + THEN kommandodialog ablehnen + ELSE kommandodialog fuehren + FI . + +fenster ist zu schmal fuer dialog : laenge < 20 . + +kommandodialog ablehnen : + fehlertext := "zu schmal fuer ESC ESC"; neu (fehlermeldung, nix) . + +kommandodialog fuehren: + INT VAR x0, x1, x2, x3, y; + get cursor (x0, y); + cursor (rand + 1, bildrand + zeilennr); + get cursor (x1, y); + out (begin mark); out (monitor meldung); + get cursor (x2, y); + (laenge - LENGTH monitor meldung - marklength) TIMESOUT blank; + get cursor (x3, y); + out (end mark); out (blank); + kommandozeile editieren; + ueberschrift zeigen; + absatz ausgleich := 2; (*sh*) + IF kommandotext = "" THEN LEAVE kommandodialog fuehren FI; + kommando auf taste legen ("f", kommandotext); + kommando analysieren ("f", PROC(TEXT CONST) kommando interpreter); + IF fehlertext <> "" + THEN push (esc + esc + esc + "k") + ELIF markiert + THEN zeile neu + FI . + +kommandozeile editieren : + TEXT VAR kommandotext := ""; + cursor (x1, y); out (begin mark); + disable stop; + darstellung invertieren; + editget schleife; + darstellung invertieren; + enable stop; + cursor (x3, y); out (end mark); + exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle); + cursor (x0, y) . + +darstellung invertieren : + TEXT VAR dummy := begin mark; begin mark := end mark; end mark := dummy; + invertierte darstellung := NOT invertierte darstellung . + +editget schleife : + TEXT VAR exit char; + REP + cursor (x2, y); + editget (kommandotext, max textlength, rand + laenge - x cursor, + "", "k?!", exit char); + neu (ueberschrift, nix); + IF exit char = ""27"k" + THEN kommando text := kommando auf taste ("f") + ELIF exit char = ""27"?" + THEN TEXT VAR taste; getchar (taste); + kommando text := kommando auf taste (taste) + ELIF exit char = ""27"!" + THEN getchar (taste); + IF ist reservierte taste + THEN set busy indicator; (*sh*) + out ("FEHLER: """ + taste + """ ist reserviert"7"") + ELSE kommando auf taste legen (taste, kommandotext); + kommandotext := ""; LEAVE editget schleife + FI + ELSE LEAVE editget schleife + FI + PER . + +ist reservierte taste : pos (res, taste) > 0 . +monitor meldung : "gib kommando : " . + +neue seite : bildanfang := satznr; zeilennr := 1; neu (akt satznr, bild) . + +weiterblaettern : + INT CONST akt bildlaenge := aktuelle bildlaenge; + IF nicht auf letztem satz + THEN erster neusatz := satznr; + IF zeilennr >= akt bildlaenge + THEN bildanfang INCR akt bildlaenge; neu (akt satznr, bild) + FI ; + satznr := min (lines (file), bildanfang + akt bildlaenge - 1); + letzter neusatz := satznr; + toline (file, satznr); + stelle DECR verschoben; + neu (akt satznr, nix); + zeilennr := satznr - bildanfang + 1; + IF markiert THEN neu (nix, abschnitt) FI; + einrueckposition bestimmen + FI . + +zurueckblaettern : + IF vorgaenger erlaubt + THEN IF zeilennr <= 1 + THEN bildanfang := max (1, bildanfang - aktuelle bildlaenge); + neu (akt satznr, bild) + FI ; + nach oben; einrueckposition bestimmen + FI . + +zeile loeschen : + IF stelle = 1 + THEN delete record (file); + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + neu (nix, abschnitt) + ELSE zeilen rekombinieren + FI . + +zeilen rekombinieren : + IF nicht auf letztem satz + THEN aktuellen satz mit blanks auffuellen; + delete record (file); + nachfolgenden satz lesen; + bildsatz CAT nachfolgender satz ohne fuehrende blanks; + write record (file, bildsatz); + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + neu (nix, abschnitt) + FI . + +aktuellen satz mit blanks auffuellen : + bildsatz AUFFUELLENMIT blank . + +nachfolgenden satz lesen : + TEXT VAR nachfolgender satz; + read record (file, nachfolgender satz) . + +nachfolgender satz ohne fuehrende blanks : + satzrest := subtext (nachfolgender satz, + einrueckposition (nachfolgender satz)); satzrest . + +zeile aufsplitten : + nachfolgender satz := ""; + INT VAR i; + FOR i FROM 2 UPTO min (stelle, einrueckposition (bildsatz)) REP + nachfolgender satz CAT blank + PER; + satzrest := subtext (bildsatz, naechste non blank position); + nachfolgender satz CAT satzrest; + bildsatz := subtext (bildsatz, 1, stelle - 1); + write record (file, bildsatz); + down (file); insert record (file); + write record (file, nachfolgender satz); up (file) . + +naechste non blank position : + INT VAR non blank pos := stelle; + WHILE (bildsatz SUB non blank pos) = blank REP + non blank pos INCR 1 + PER; non blank pos . + +zum vorigen satz : + IF vorgaenger erlaubt THEN vorgaenger; einrueckposition bestimmen FI . + +zum folgenden satz : (* 12.09.85 -ws- *) + IF nachfolger erlaubt THEN nachfolger; einrueckposition bestimmen + ELSE col (file, len (file) + 1); neu (nix, nix) + FI . + +einrueckposition bestimmen : (* 27.08.85 -ws- *) + read record (file, akt bildsatz); + INT VAR neue einrueckposition := einrueckposition (akt bildsatz); + IF akt bildsatz ist leerzeile + THEN alte einrueckposition := max (stelle, neue einrueckposition) + ELSE alte einrueckposition := min (stelle, neue einrueckposition) + FI . + +akt bildsatz ist leerzeile : + akt bildsatz = "" OR akt bildsatz = blank . + +zum anfang des folgenden satzes : + IF nachfolger erlaubt THEN nachfolger; stelle := anfang FI . + +nachfolger erlaubt : + write access COR nicht auf letztem satz . + +eingerueckt mit cr : + IF NOT nachfolger erlaubt THEN LEAVE eingerueckt mit cr FI; (*sh*) + read record (file, bildsatz); + INT VAR epos := einrueckposition (bildsatz); + nachfolger; col (file, 1); + IF eof (file) + THEN IF LENGTH bildsatz <= epos + THEN stelle := alte einrueckposition + ELSE stelle := epos + FI + ELSE read record (file, bildsatz); + stelle := einrueckposition (bildsatz); + IF bildsatz ist leerzeile (* 29.08.85 -ws- *) + THEN stelle := alte einrueckposition; + aktuellen satz mit blanks auffuellen + FI + FI ; + alte einrueckposition := stelle . + +bildsatz ist leerzeile : + bildsatz = "" OR bildsatz = blank . + +eingerueckt zum folgenden satz : (*sh*) + IF NOT nachfolger erlaubt OR NOT write access + THEN LEAVE eingerueckt zum folgenden satz + FI; + alte einrueckposition merken; + naechsten satz holen; + neue einrueckposition bestimmen; + alte einrueckposition := stelle . + +alte einrueckposition merken : + read record (file, bildsatz); + epos := einrueckposition (bildsatz); + auf aufzaehlung pruefen; + IF epos > LENGTH bildsatz THEN epos := anfang FI. + +auf aufzaehlung pruefen : + BOOL CONST aufzaehlung gefunden := + ist aufzaehlung CAND vorher absatzzeile CAND wort folgt; + IF aufzaehlung gefunden THEN epos := anfang des naechsten wortes FI . + +ist aufzaehlung : + INT CONST wortende := pos (bildsatz, blank, epos, epos + 20) - 1; + SELECT pos ("-*).:" , bildsatz SUB wortende) OF + CASE 1,2 : wortende = epos + CASE 3,4 : wortende <= epos + 7 + CASE 5 : TRUE + OTHERWISE: FALSE + ENDSELECT . + +vorher absatzzeile : + IF satznr = 1 + THEN TRUE + ELSE up (file); + INT CONST vorige satzlaenge := len (file); + BOOL CONST vorher war absatzzeile := + subtext (file, vorige satzlaenge, vorige satzlaenge) = blank; + down (file); vorher war absatzzeile + FI . + +wort folgt : + INT CONST anfang des naechsten wortes := + pos (bildsatz, ""33"", ""254"", wortende + 1); + anfang des naechsten wortes > wortende . + +naechsten satz holen : + nachfolger; col (file, 1); + IF eof (file) + THEN bildsatz := "" + ELSE IF neue zeile einfuegen erforderlich + THEN insert record (file); bildsatz := ""; + letzter neusatz := bildanfang + bildlaenge - 1 + ELSE read record (file, bildsatz); + letzter neusatz := satznr; + ggf trennungen zurueckwandeln und umbruch indikator einfuegen + FI ; + erster neusatz := satznr; + neu (nix, abschnitt) + FI . + +neue zeile einfuegen erforderlich : + BOOL CONST war absatz := war absatzzeile; + war absatz COR neuer satz ist zu lang . + +war absatzzeile : + INT VAR wl := pos (kommando, up backcr, kommando zeiger); + wl = 0 COR (kommando SUB (wl - 1)) = blank . + +neuer satz ist zu lang : laenge des neuen satzes >= limit . + +laenge des neuen satzes : + IF len (file) > 0 + THEN len (file) + wl + ELSE wl + epos + FI . + +up backcr : ""3""20"" . + +ggf trennungen zurueckwandeln und umbruch indikator einfuegen : + LET trenn k = ""220"", + trenn strich = ""221""; + TEXT VAR umbruch indikator; + IF letztes zeichen ist trenn strich + THEN entferne trenn strich; + IF letztes zeichen = trenn k + THEN wandle trenn k um + FI ; + umbruch indikator := up backcr + ELIF letztes umgebrochenes zeichen ist kanji + THEN umbruch indikator := up backcr + ELSE umbruch indikator := blank + up backcr + FI ; + change (kommando, wl, wl+1, umbruch indikator) . + +letztes umgebrochenes zeichen ist kanji : within kanji (kommando, wl-1) . + +letztes zeichen ist trenn strich : + TEXT CONST last char := letztes zeichen; + last char = trenn strich COR + last char = "-" CAND wl > 2 CAND (kommando SUB (wl-2)) <> blank . + +letztes zeichen : kommando SUB (wl-1) . +entferne trenn strich : delete char (kommando, wl-1); wl DECR 1 . +wandle trenn k um : replace (kommando, wl-1, "c") . +loesche indikator : delete char (kommando, wl) . + +neue einrueckposition bestimmen : + IF aufzaehlung gefunden CAND bildsatz ist leerzeile + THEN stelle := epos + ELIF NOT bildsatz ist leerzeile + THEN stelle := einrueckposition (bildsatz) + ELIF war absatz COR auf letztem satz + THEN stelle := epos + ELSE down (file); read record (file, nachfolgender satz); + up (file); stelle := einrueckposition (nachfolgender satz) + FI ; + IF ist einfuegender aber nicht induzierter umbruch + THEN loesche indikator; + umbruchstelle := stelle + wl - kommando zeiger - anzahl der stz; + umbruchverschoben := 0 + FI . + +auf letztem satz : NOT nicht auf letztem satz . + +ist einfuegender aber nicht induzierter umbruch : + wl := pos (kommando, backcr, kommando zeiger); + wl > 0 CAND (kommando SUB (wl - 1)) <> up char . + +anzahl der stz : + TEXT CONST umgebrochener anfang := subtext (kommando, kommando zeiger, wl-1); + INT VAR anz := 0, anf := pos (umgebrochener anfang, ""1"", ""31"", 1); + WHILE anf > 0 REP + anz INCR 1; anf := pos (umgebrochener anfang, ""1"", ""31"", anf + 1) + PER; anz . + +markiertes vorsichtig loeschen : + IF write access CAND markiert + THEN clear removed (file); + IF nur im satz markiert + THEN behandle einen satz + ELSE behandle mehrere saetze + FI + FI . + +nur im satz markiert : line no (file) = bildmarke . + +behandle einen satz : + insert record (file); + satzrest := subtext (bildsatz, marke, stelle - 1); + write record (file, satzrest); + remove (file, 1); + change (bildsatz, marke, stelle - 1, ""); + stelle := marke; + marke := 0; bildmarke := 0; feldmarke := 0; + markiert := FALSE; mark (file, 0, 0); + konstanten neu berechnen; + IF bildsatz = "" + THEN delete record (file); + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + neu (nix, abschnitt) + ELSE write record (file, bildsatz); + neu (nix, bildzeile) + FI . + +behandle mehrere saetze : + erster neusatz := bildmarke; + letzter neusatz := bildanfang + bildlaenge - 1; + zeile an aktueller stelle auftrennen; + ersten markierten satz an markieranfang aufspalten; + markierten bereich entfernen; + bild anpassen . + +zeile an aktueller stelle auftrennen : + INT VAR markierte saetze := line no (file) - bildmarke + 1; + IF nicht am ende der zeile + THEN IF nicht am anfang der zeile + THEN zeile aufsplitten + ELSE up (file); markierte saetze DECR 1 + FI + FI . + +nicht am anfang der zeile : stelle > 1 . +nicht am ende der zeile : stelle <= LENGTH bildsatz . + +ersten markierten satz an markieranfang aufspalten : + to line (file, line no (file) - (markierte saetze - 1)); + read record (file, bildsatz); + stelle := feldmarke; + IF nicht am anfang der zeile + THEN IF nicht am ende der zeile + THEN zeile aufsplitten + ELSE markierte saetze DECR 1 + FI ; + to line (file, line no (file) + markierte saetze) + ELSE to line (file, line no (file) + markierte saetze - 1) + FI ; + read record (file, bildsatz) . + +markierten bereich entfernen : + zeilen nr := line no (file) - markierte saetze - bildanfang + 2; + remove (file, markierte saetze); + marke := 0; bildmarke := 0; feldmarke := 0; + markiert := FALSE; mark (file, 0, 0); + konstanten neu berechnen; + stelle := 1 . + +bild anpassen : + satz nr := line no (file); + IF zeilen nr <= 1 + THEN bildanfang := line no (file); zeilen nr := 1; + neu (akt satznr, bild) + ELSE neu (akt satznr, abschnitt) + FI . + +vorsichtig geloeschtes einfuegen : + IF NOT write access OR removed lines (file) = 0 + THEN LEAVE vorsichtig geloeschtes einfuegen + FI ; + IF nur ein satz + THEN in aktuellen satz einfuegen + ELSE aktuellen satz aufbrechen und einfuegen + FI . + +nur ein satz : removed lines (file) = 1 . + +in aktuellen satz einfuegen : + reinsert (file); + read record (file, nachfolgender satz); + delete record (file); + TEXT VAR t := bildsatz; + bildsatz := subtext (t, 1, stelle - 1); + aktuellen satz mit blanks auffuellen; (*sh*) + bildsatz CAT nachfolgender satz; + satzrest := subtext (t, stelle); + bildsatz CAT satzrest; + write record (file, bildsatz); + stelle INCR LENGTH nachfolgender satz; + neu (nix, bildzeile) . + +aktuellen satz aufbrechen und einfuegen : + INT CONST alter bildanfang := bildanfang; + old lineno := satznr; + IF stelle = 1 + THEN reinsert (file); + read record (file, bildsatz) + ELIF stelle > LENGTH bildsatz + THEN down (file); + reinsert (file); + read record (file, bildsatz) + ELSE INT VAR von := stelle; + WHILE (bildsatz SUB von) = blank REP von INCR 1 PER; + satzrest := subtext (bildsatz, von, LENGTH bildsatz); + INT VAR bis := stelle - 1; + WHILE (bildsatz SUB bis) = blank REP bis DECR 1 PER; + bildsatz := subtext (bildsatz, 1, bis); + write record (file, bildsatz); + down (file); + reinsert (file); + read record (file, bildsatz); + nachfolgender satz := einrueckposition (bildsatz) * blank; + nachfolgender satz CAT satzrest; + down (file); insert record (file); + write record (file, nachfolgender satz); up (file) + FI ; + stelle := max (1, LENGTH bildsatz); (* 22.06.84 -bk- *) + satz nr := line no (file); + zeilennr INCR satznr - old lineno; + zeilennr := min (zeilennr, aktuelle bildlaenge); + bildanfang := satznr - zeilennr + 1; + IF bildanfang veraendert + THEN abschnitt neu (bildanfang, 9999) + ELSE abschnitt neu (old lineno, 9999) + FI ; + neu (akt satznr, nix). + +bildanfang veraendert : bildanfang <> alter bildanfang . + +lernmodus umschalten : + learn segment in ueberschrift eintragen; neu (ueberschrift, nix) . + +learn segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 19, learn segment) . + +learn segment : + IF lernmodus THEN "LEARN" ELSE "....." FI . + +markierung umschalten : + IF markiert THEN markierung ausschalten ELSE markierung einschalten FI . + +markierung einschalten : + bildmarke := satznr; feldmarke := marke; markiert := TRUE; + mark (file, bildmarke, feldmarke); + neu (nix, bildzeile) . + +markierung ausschalten : + erster neusatz := max (bildmarke, bildanfang); + letzter neusatz := satznr; + bildmarke := 0; feldmarke := 0; markiert := FALSE; + mark (file, 0, 0); + IF erster neusatz = letzter neusatz + THEN neu (nix, bildzeile) + ELSE neu (nix, abschnitt) + FI . +END PROC bildeditor; + +PROC neu (INT CONST ue bereich, b bereich) : + ueberschriftbereich := max (ueberschriftbereich, ue bereich); + bildbereich := max (bildbereich, b bereich) +END PROC neu; + + +PROC nach oben : + letzter neusatz := satznr; + satznr := max (bildanfang, bildmarke); + toline (file, satznr); + stelle DECR verschoben; + zeilennr := satznr - bildanfang + 1; + erster neusatz := satznr; + IF markiert + THEN neu (akt satznr, abschnitt) + ELSE neu (akt satznr, nix) + FI +END PROC nach oben; + +INT PROC aktuelle bildlaenge : + IF stelle - stelle am anfang < kurze feldlaenge + AND feldlaenge > 0 + THEN bildlaenge (*wk*) + ELSE kurze bildlaenge + FI +END PROC aktuelle bildlaenge; + +PROC vorgaenger : + up (file); satznr DECR 1; + marke := 0; stelle DECR verschoben; + IF zeilennr = 1 + THEN bildanfang DECR 1; neu (ueberschrift, bild) + ELSE zeilennr DECR 1; neu (akt satznr, nix); (*sh*) + IF markiert THEN neu (nix, bildzeile) FI + FI +END PROC vorgaenger; + +PROC nachfolger : + down (file); satznr INCR 1; + stelle DECR verschoben; + IF zeilennr = aktuelle bildlaenge + THEN bildanfang INCR 1; + IF rollup erlaubt + THEN rollup + ELSE neu (ueberschrift, bild) + FI + ELSE neu (akt satznr, nix); zeilennr INCR 1 (*sh*) + FI ; + IF markiert THEN neu (nix, bildzeile) FI . + +rollup erlaubt : + kurze bildlaenge = maxlaenge AND kurze feldlaenge = maxbreite . + +rollup : + out (down char); + IF bildzeichen = inscr + THEN neu (ueberschrift, nix) + ELIF is cr or down CAND (write access COR nicht auf letztem satz) (*sh*) + THEN neu (nix, bildzeile) + ELSE neu (ueberschrift, bildzeile) + FI . + +is cr or down : + IF kommando = "" THEN kommando := inchety FI; + kommando char = down char COR kommando char = cr . + +kommando char : kommando SUB kommando zeiger . + +nicht auf letztem satz : line no (file) < lines (file) . +END PROC nachfolger; + +BOOL PROC next incharety is (TEXT CONST muster) : + INT CONST klen := LENGTH kommando - kommando zeiger + 1, + mlen := LENGTH muster; + INT VAR i; FOR i FROM 1 UPTO mlen - klen REP kommando CAT inchety PER; + subtext (kommando, kommando zeiger, kommando zeiger + mlen - 1) = muster +END PROC next incharety is; + +PROC quit last: (* 22.06.84 -bk- *) + IF actual editor > 0 AND actual editor < max used editor + THEN verlasse alle groesseren editoren + FI . + +verlasse alle groesseren editoren : + open editor (actual editor + 1); quit . +END PROC quit last; + +PROC quit : + IF actual editor > 0 THEN verlasse aktuellen editor FI . + +verlasse aktuellen editor : + disable stop; + INT CONST aktueller editor := actual editor; + in innersten editor gehen; + REP + IF zeileneinfuegen THEN hop rubin simulieren FI; + ggf bildschirmdarstellung korrigieren; + innersten editor schliessen + UNTIL aktueller editor > max used editor PER; + actual editor := max used editor . + +in innersten editor gehen : open editor (max used editor) . + +hop rubin simulieren : + zeileneinfuegen := FALSE; + leere zeilen am dateiende loeschen; (*sh*) + ggf bildschirmdarstellung korrigieren; + logisches eof loeschen . + +innersten editor schliessen : + max used editor DECR 1; + IF max used editor > 0 + THEN open editor (max used editor); + bildeinschraenkung aufheben + FI . + +logisches eof loeschen : + col (file, stelle); set range (file, old range) . + +leere zeilen am dateiende loeschen : (* 15.08.85 -ws- *) + satz nr := line no (file) ; + to line (file, lines (file)) ; + WHILE lines (file) > 1 AND bildsatz ist leerzeile REP + delete record (file); + to line (file, lines (file)) + PER; + toline (file, satznr) . + +bildsatz ist leerzeile : + TEXT VAR bildsatz; + read record (file, bildsatz); + ist leerzeile . + +ist leerzeile : + bildsatz = "" OR bildsatz = blank . + +ggf bildschirmdarstellung korrigieren : + satz nr DECR 1; (* für Bildschirmkorrektur *) + IF satznr > lines (file) + THEN zeilen nr DECR satz nr - lines (file); + satz nr := lines (file); + dateizustand retten + FI . + +bildeinschraenkung aufheben : + laenge := feldlaenge; + kurze feldlaenge := feldlaenge; + kurze bildlaenge := bildlaenge; + neu (nix, bild) . +END PROC quit; + +PROC nichts neu : neu (nix, nix) END PROC nichts neu; + +PROC satznr neu : neu (akt satznr, nix) END PROC satznr neu; + +PROC ueberschrift neu : neu (ueberschrift, nix) END PROC ueberschrift neu; + +PROC zeile neu : + INT CONST zeile := line no (file); + abschnitt neu (zeile, zeile) +END PROC zeile neu; + +PROC abschnitt neu (INT CONST von satznr, bis satznr) : + IF von satznr <= bis satznr + THEN erster neusatz := min (erster neusatz, von satznr); + letzter neusatz := max (letzter neusatz, bis satznr); + neu (nix, abschnitt) + ELSE abschnitt neu (bis satznr, von satznr) + FI +END PROC abschnitt neu; + +PROC bildabschnitt neu (INT CONST von zeile, bis zeile) : (*sh*) + IF von zeile <= bis zeile + THEN erster neusatz := max (1, von zeile + bildanfang - 1); + letzter neusatz := min (bildlaenge, bis zeile + bildanfang - 1); + IF von zeile < 1 + THEN neu (ueberschrift, abschnitt) + ELSE neu (nix , abschnitt) + FI + ELSE bildabschnitt neu (bis zeile, von zeile) + FI +END PROC bildabschnitt neu; + +PROC bild neu : neu (nix, bild) END PROC bild neu; (*sh*) + +PROC bild neu (FILE VAR f) : + INT CONST editor no := abs (editinfo (f)) DIV 256; + IF editor no > 0 AND editor no <= max used editor + THEN IF editor no = actual editor + THEN bild neu + ELSE editstack (editor no).bildstatus.bildbereich := bild + FI + FI +END PROC bild neu; + +PROC alles neu : + neu (ueberschrift, bild); + INT VAR i; + FOR i FROM 1 UPTO max used editor REP + editstack (i).bildstatus.bildbereich := bild; + editstack (i).bildstatus.ueberschriftbereich := ueberschrift + PER +END PROC alles neu; + +PROC satznr zeigen : + out (satznr pre); out (text (text (lineno (file)), 4)) +END PROC satznr zeigen; + +PROC ueberschrift zeigen : + SELECT ueberschriftbereich OF + CASE akt satznr : satznr zeigen; + ueberschriftbereich := nix + CASE ueberschrift : ueberschrift schreiben; + ueberschriftbereich := nix + CASE fehlermeldung : fehlermeldung schreiben; + ueberschriftbereich := ueberschrift + END SELECT +END PROC ueberschrift zeigen; + +PROC fenster zeigen : + SELECT bildbereich OF + CASE bildzeile : + zeile := bildrand + zeilennr; + IF line no (file) > lines (file) + THEN feldout ("", stelle) + ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle) + FI + CASE abschnitt : + bild ausgeben + CASE bild : + erster neusatz := 1; + letzter neusatz := 9999; + bild ausgeben + OTHERWISE : + LEAVE fenster zeigen + END SELECT; + erster neusatz := 9999; + letzter neusatz := 0; + bildbereich := nix +END PROC fenster zeigen ; + +PROC bild ausgeben : + BOOL CONST schreiben ist ganz einfach := NOT markiert AND verschoben = 0; + INT CONST save marke := marke, + save verschoben := verschoben, + save laenge := laenge, + act lineno := lineno (file), + von := max (1, erster neusatz - bildanfang + 1); + INT VAR bis := min (letzter neusatz - bildanfang + 1, bildlaenge); + IF kurze feldlaenge <= 0 THEN bis := min (bis, kurze bildlaenge) FI; + IF von > bis THEN LEAVE bild ausgeben FI; + verschoben := 0; + IF markiert + THEN IF mark lineno (file) < bildanfang + von - 1 + THEN marke := anfang + ELSE marke := 0 + FI + FI ; + abschnitt loeschen und neuschreiben; + to line (file, act lineno); + laenge := save laenge; + verschoben := save verschoben; + marke := save marke . + +markiert : mark lineno (file) > 0 . + +abschnitt loeschen und neuschreiben : + abschnitt loeschen; + INT VAR line number := bildanfang + von - 1; + to line (file, line number); + abschnitt schreiben . + +abschnitt loeschen : + cursor (rand + 1, bildrand + von); + IF bildrest darf komplett geloescht werden + THEN out (clear eop) + ELSE zeilenweise loeschen + FI . + +bildrest darf komplett geloescht werden : + bis = maxlaenge AND kurze bildlaenge = maxlaenge + AND kurze feldlaenge = maxbreite . + +zeilenweise loeschen : + INT VAR i; + FOR i FROM von UPTO bis REP + check for interrupt; + feldlaenge einstellen; + feldrest loeschen; + IF i < bis THEN out (down char) FI + PER . + +feldlaenge einstellen : + IF ganze zeile sichtbar + THEN laenge := feldlaenge + ELSE laenge := kurze feldlaenge + FI . + +ganze zeile sichtbar : i <= kurze bildlaenge . + +abschnitt schreiben : + INT CONST last line := lines (file); + FOR i FROM von UPTO bis + WHILE line number <= last line REP + check for interrupt; + feldlaenge einstellen; + zeile schreiben; + down (file); + line number INCR 1 + PER . + +check for interrupt : + kommando CAT inchety; + IF kommando <> "" + THEN IF zeilen nr = 1 CAND up command CAND vorgaenger erlaubt + THEN LEAVE abschnitt loeschen und neuschreiben + ELIF zeilen nr = bildlaenge CAND down command CAND nicht letzter satz + THEN LEAVE abschnitt loeschen und neuschreiben + FI + FI . + +vorgaenger erlaubt : + satznr > max (1, bildmarke) . + +up command : next incharety is (""3"") COR next incharety is (""1""3"") . + +down command : + next incharety is (""10"") CAND bildlaenge < maxlaenge + COR next incharety is (""1""10"") . + +nicht letzter satz : act lineno < lines (file) . + +zeile schreiben : + zeile := bildrand + i; + IF schreiben ist ganz einfach + THEN exec (PROC (TEXT CONST, INT CONST) simple feldout, file, 0) + ELSE zeile kompliziert schreiben + FI ; + IF line number = old lineno THEN old line update := FALSE FI . + +zeile kompliziert schreiben : + IF line number = mark lineno (file) THEN marke := mark col (file) FI; + IF line number = act lineno + THEN verschoben := save verschoben; + exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle); + verschoben := 0; marke := 0 + ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, 0); + IF line number = mark lineno (file) THEN marke := anfang FI + FI . +END PROC bild ausgeben; + +PROC bild zeigen : (* wk *) + + dateizustand holen ; + ueberschrift zeigen ; + bildausgabe steuern ; + bild neu ; + fenster zeigen ; + oldline no := satznr ; + old line update := FALSE ; + old satz := "" ; + old zeilennr := satznr - bildanfang + 1 ; + dateizustand retten . + +ENDPROC bild zeigen ; + +PROC ueberschrift initialisieren : (*sh*) + satznr pre := + cursor pos + code (bildrand - 1) + code (rand + feldlaenge - 6); + ueberschrift pre := + cursor pos + code (bildrand - 1) + code (rand) + mark anf; + ueberschrift text := ""; INT VAR i; + FOR i FROM 16 UPTO feldlaenge REP ueberschrift text CAT "." PER; + ueberschrift post := blank + mark end + "Zeile " + mark anf; + ueberschrift post CAT blank + mark end + " "; + filename := headline (file); + filename := subtext (filename, 1, feldlaenge - 24); + insert char (filename, blank, 1); filename CAT blank; + replace (ueberschrift text, filenamepos, filename); + rubin segment in ueberschrift eintragen; + margin segment in ueberschrift eintragen; + rest segment in ueberschrift eintragen; + learn segment in ueberschrift eintragen . + +filenamepos : (LENGTH ueberschrift text - LENGTH filename + 3) DIV 2 . +mark anf : begin mark + mark ausgleich. +mark end : end mark + mark ausgleich. +mark ausgleich : (1 - sign (max (mark size, 0))) * blank . + +rubin segment in ueberschrift eintragen : + replace (ueberschrift text, 9, rubin segment) . + +rubin segment : + IF einfuegen THEN "RUBIN" ELSE "....." FI . + +margin segment in ueberschrift eintragen : + replace (ueberschrift text, 2, margin segment) . + +margin segment : + IF anfang <= 1 + THEN "......" + ELSE TEXT VAR margin text := "M" + text (anfang); + (6 - LENGTH margin text) * "." + margin text + FI . + +rest segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 25, rest segment) . + +rest segment : + IF zeileneinfuegen THEN "REST" ELSE "...." FI . + +learn segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 19, learn segment) . + +learn segment : + IF lernmodus THEN "LEARN" ELSE "....." FI . + +END PROC ueberschrift initialisieren; + +PROC ueberschrift schreiben : + replace (ueberschrift post, satznr pos, text (text (lineno (file)), 4)); + out (ueberschrift pre); out (ueberschrift text); out (ueberschrift post); + get tabs (file, tab); + IF pos (tab, dach) > 0 + THEN out (ueberschrift pre); + out subtext (tab, anfang + 1, anfang + feldlaenge - 1); + cursor (rand + 1 + feldlaenge, bildrand); out (end mark) + FI . + + satznr pos : IF mark size > 0 THEN 9 ELSE 10 FI . (*sh*) +END PROC ueberschrift schreiben; + +PROC fehlermeldung schreiben : + ueberschrift schreiben; + out (ueberschrift pre); + out ("FEHLER: "); + out subtext (fehlertext, 1, feldlaenge - 21); + out (blank); + out (piep); + cursor (rand + 1 + feldlaenge, bildrand); out (end mark) +END PROC fehlermeldung schreiben; + +PROC set busy indicator : + cursor (rand + 2, bildrand) +END PROC set busy indicator; + +PROC kommando analysieren (TEXT CONST taste, + PROC (TEXT CONST) kommando interpreter) : + disable stop; + bildausgabe normieren; + zustand in datei sichern; + editfile modus setzen; + kommando interpreter (taste); + editfile modus zuruecksetzen; + IF actual editor <= 0 THEN LEAVE kommando analysieren FI; + absatz ausgleich := 2; (*sh*) + konstanten neu berechnen; + neues bild bei undefinierter benutzeraktion; + evtl fehler behandeln; + zustand aus datei holen; + bildausgabe steuern . + +editfile modus setzen : + BOOL VAR alter editget modus := editget modus ; + editget modus := FALSE . + +editfile modus zuruecksetzen : + editget modus := alter editget modus . + +evtl fehler behandeln : + IF is error + THEN fehlertext := errormessage; + IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI; + clear error + ELSE fehlertext := "" + FI . + +zustand in datei sichern : + old zeilennr := zeilennr; + old mark lineno := bildmarke; + dateizustand retten . + +zustand aus datei holen : + dateizustand holen; + IF letzer editor auf dieser datei <> actual editor + THEN zurueck auf alte position; neu (ueberschrift, bild) + FI . + +zurueck auf alte position : + to line (file, old lineno); + col (file, alte stelle); + IF fliesstext + THEN editinfo (file, old zeilennr) + ELSE editinfo (file, - old zeilennr) + FI ; dateizustand holen . + +bildausgabe normieren : + bildbereich := undefinierter bereich; + erster neusatz := 9999; + letzter neusatz := 0 . + +neues bild bei undefinierter benutzeraktion : + IF bildbereich = undefinierter bereich THEN alles neu FI . +END PROC kommando analysieren; + +PROC bildausgabe steuern : + IF markiert + THEN IF old mark lineno = 0 + THEN abschnitt neu (bildmarke, satznr); + konstanten neu berechnen + ELIF stelle veraendert (*sh*) + THEN zeile neu + FI + ELIF old mark lineno > 0 + THEN abschnitt neu (old mark lineno, (max (satznr, old lineno))); + konstanten neu berechnen + FI ; + IF satznr <> old lineno + THEN neu (akt satznr, nix); + neuen bildaufbau bestimmen + ELSE zeilennr := old zeilennr + FI ; + zeilennr := min (min (zeilennr, satznr), aktuelle bildlaenge); + bildanfang := satznr - zeilennr + 1 . + +stelle veraendert : stelle <> alte stelle . + +neuen bildaufbau bestimmen : + zeilennr := old zeilennr + satznr - old lineno; + IF 1 <= zeilennr AND zeilennr <= aktuelle bildlaenge + THEN im fenster springen + ELSE bild neu aufbauen + FI . + +im fenster springen : + IF markiert THEN abschnitt neu (old lineno, satznr) FI . + +bild neu aufbauen : + neu (nix, bild); zeilennr := max (1, aktuelle bildlaenge DIV 2) . +END PROC bildausgabe steuern; + +PROC word wrap (BOOL CONST b) : + IF actual editor = 0 + THEN std fliesstext := b + ELSE fliesstext in datei setzen + FI . + +fliesstext in datei setzen : + fliesstext := b; + IF fliesstext veraendert THEN editinfo (file, - editinfo (file)) FI; + neu (ueberschrift, bild) . + +fliesstext veraendert : + fliesstext AND editinfo (file) < 0 OR + NOT fliesstext AND editinfo (file) > 0 . +END PROC word wrap; + +BOOL PROC word wrap : (*sh*) + IF actual editor = 0 + THEN std fliesstext + ELSE fliesstext + FI +END PROC word wrap; + +INT PROC margin : anfang END PROC margin; + +PROC margin (INT CONST i) : (*sh*) + IF anfang <> i CAND i > 0 AND i < 16001 + THEN anfang := i; neu (ueberschrift, bild); + margin segment in ueberschrift eintragen + ELSE IF i >= 16001 OR i < 0 + THEN errorstop ("ungueltige Anfangsposition (1 - 16000)") + FI + FI . + +margin segment in ueberschrift eintragen : + replace (ueberschrift text, 2, margin segment) . + +margin segment : + IF anfang <= 1 + THEN "......" + ELSE TEXT VAR margin text := "M" + text (anfang); + (6 - LENGTH margin text) * "." + margin text + FI . + +END PROC margin; + +BOOL PROC rubin mode : rubin mode (actual editor) END PROC rubin mode; + +BOOL PROC rubin mode (INT CONST editor nr) : (*sh*) + IF editor nr < 1 OR editor nr > max used editor + THEN errorstop ("Editor nicht eroeffnet") + FI ; + IF editor nr = actual editor + THEN einfuegen + ELSE editstack (editor nr).feldstatus.einfuegen + FI +END PROC rubin mode; + +PROC edit (INT CONST i, TEXT CONST res, + PROC (TEXT CONST) kommando interpreter) : + edit (i, i, i, res, PROC (TEXT CONST) kommando interpreter) +END PROC edit; + +PROC edit (INT CONST von, bis, start, TEXT CONST res, + PROC (TEXT CONST) kommando interpreter) : + disable stop; + IF von < bis + THEN edit (von+1, bis, start, res, PROC (TEXT CONST) kommando interpreter); + IF max used editor < von THEN LEAVE edit FI; + open editor (von) + ELSE open editor (start) + FI ; + absatz ausgleich := 2; + bildeditor (res, PROC (TEXT CONST) kommando interpreter); + cursor (1, schirmhoehe); + IF is error + THEN kommando zeiger := 1; kommando := ""; quit + FI ; + IF lernmodus CAND actual editor = 0 THEN warnung ausgeben FI . (*sh*) + + warnung ausgeben : + out (clear eop); out ("WARNUNG: Lernmodus nicht ausgeschaltet"13""10"") . +END PROC edit; + +PROC dateizustand holen : + modify (file); + get tabs (file, tabulator); + zeilennr und fliesstext und letzter editor aus editinfo decodieren; + limit := max line length (file); + stelle := col (file); + markiert := mark (file); + IF markiert + THEN markierung holen + ELSE keine markierung + FI ; + satz nr := lineno (file); + IF zeilennr > aktuelle bildlaenge (*sh*) + THEN zeilennr := min (satznr, aktuelle bildlaenge); bild neu + ELIF zeilennr > satznr + THEN zeilennr := min (satznr, aktuelle bildlaenge) + FI ; zeilennr := max (zeilennr, 1); + bildanfang := satz nr - zeilennr + 1 . + +zeilennr und fliesstext und letzter editor aus editinfo decodieren : + zeilennr := edit info (file); + IF zeilennr = 0 + THEN zeilennr := 1; + fliesstext := std fliesstext + ELIF zeilennr > 0 + THEN fliesstext := TRUE + ELSE zeilennr := - zeilennr; + fliesstext := FALSE + FI ; + letzer editor auf dieser datei := zeilennr DIV 256; + zeilennr := zeilennr MOD 256 . + +markierung holen : + bildmarke := mark lineno (file); + feldmarke := mark col (file); + IF line no (file) <= bildmarke + THEN to line (file, bildmarke); + marke := feldmarke; + stelle := max (stelle, feldmarke) + ELSE marke := 1 + FI . + +keine markierung : + bildmarke := 0; + feldmarke := 0; + marke := 0 . +END PROC dateizustand holen; + +PROC dateizustand retten : + put tabs (file, tabulator); + IF fliesstext + THEN editinfo (file, zeilennr + actual editor * 256) + ELSE editinfo (file, - (zeilennr + actual editor * 256)) + FI ; + max line length (file, limit); + col (file, stelle); + IF markiert + THEN mark (file, bildmarke, feldmarke) + ELSE mark (file, 0, 0) + FI +END PROC dateizustand retten; + +PROC open editor (FILE CONST new file, BOOL CONST access) : + disable stop; quit last; + neue bildparameter bestimmen; + open editor (actual editor + 1, new file, access, x, y, x len, y len). + +neue bildparameter bestimmen : + INT VAR x, y, x len, y len; + IF actual editor > 0 + THEN teilbild des aktuellen editors + ELSE volles bild + FI . + +teilbild des aktuellen editors : + get editcursor (x, y); bildgroesse bestimmen; + IF fenster zu schmal (*sh*) + THEN enable stop; errorstop ("Fenster zu klein") + ELIF fenster zu kurz + THEN verkuerztes altes bild nehmen + FI . + +bildgroesse bestimmen : + x len := rand + feldlaenge - x + 3; + y len := bildrand + bildlaenge - y + 1 . + +fenster zu schmal : x > schirmbreite - 17 . +fenster zu kurz : y > schirmhoehe - 1 . + +verkuerztes altes bild nehmen : + x := rand + 1; y := bildrand + 1; + IF fenster zu kurz THEN enable stop; errorstop ("Fenster zu klein") FI; + x len := feldlaenge + 2; + y len := bildlaenge; + kurze feldlaenge := 0; + kurze bildlaenge := 1 . + +volles bild : + x := 1; y := 1; x len := schirmbreite; y len := schirmhoehe . +END PROC open editor; + +PROC open editor (INT CONST editor nr, + FILE CONST new file, BOOL CONST access, + INT CONST x start, y, x len start, y len) : + INT VAR x := x start, + x len := x len start; + IF editor nr > max editor + THEN errorstop ("zu viele Editor-Fenster") + ELIF editor nr > max used editor + 1 OR editor nr < 1 + THEN errorstop ("Editor nicht eroeffnet") + ELIF fenster ungueltig + THEN errorstop ("Fenster ungueltig") + ELSE neuen editor stacken + FI . + +fenster ungueltig : + x < 1 COR x > schirmbreite COR y < 1 COR y > schirmhoehe COR + x len - 2 <= 15 COR y len - 1 < 1 COR + x + x len - 1 > schirmbreite COR y + y len - 1 > schirmhoehe . + +neuen editor stacken : + disable stop; + IF actual editor > 0 AND ist einschraenkung des alten bildes + THEN dateizustand holen; + aktuelles editorbild einschraenken; + arbeitspunkt in das restbild positionieren; + abgrenzung beruecksichtigen + FI ; + aktuellen zustand retten; + neuen zustand setzen; + neues editorbild zeigen; + actual editor := editor nr; + IF actual editor > max used editor + THEN max used editor := actual editor + FI . + +ist einschraenkung des alten bildes : + x > rand CAND x + x len = rand + feldlaenge + 3 CAND + y > bildrand CAND y + y len = bildrand + bildlaenge + 1 . + +aktuelles editorbild einschraenken : + kurze feldlaenge := x - rand - 3; + kurze bildlaenge := y - bildrand - 1 . + +arbeitspunkt in das restbild positionieren : + IF stelle > 3 + THEN stelle DECR 3; alte stelle := stelle + ELSE WHILE zeilennr > 1 AND zeilennr > kurze bildlaenge REP + vorgaenger + PER; old lineno := satznr + FI . + +abgrenzung beruecksichtigen : + IF x - rand > 1 + THEN balken malen; + x INCR 2; + x len DECR 2 + FI . + +balken malen : + INT VAR i; + FOR i FROM 0 UPTO y len-1 REP + cursor (x, y+i); out (kloetzchen) (*sh*) + PER . + +kloetzchen : IF mark size > 0 THEN ""15""14"" ELSE ""15" "14" " FI . + +aktuellen zustand retten : + IF actual editor > 0 + THEN dateizustand retten; + editstack (actual editor).feldstatus := feldstatus; + editstack (actual editor).bildstatus := bildstatus; + einrueckstack (actual editor) := alte einrueckposition + FI . + +neuen zustand setzen : + FRANGE VAR frange; + feldstatus := FELDSTATUS : + (1, 1, x-1, 0, 1, 0, x len-2, 0, FALSE, TRUE, access, ""); + bildstatus := BILDSTATUS : + (x len-2, x len-2, y, y len-1, y len-1, ueberschrift, bild, + 0, 0, 1, 0, 0, FALSE, FALSE, "", "", "", "", "", frange, new file); + alte einrueckposition := 1; + dateizustand holen; + ueberschrift initialisieren . + +neues editorbild zeigen : + ueberschrift zeigen; fenster zeigen +END PROC open editor; + +PROC open editor (INT CONST i) : + IF i < 1 OR i > max used editor + THEN errorstop ("Editor nicht eroeffnet") + ELIF actual editor <> i + THEN switch editor + FI . + +switch editor : + aktuellen zustand retten; + actual editor := i; + neuen zustand setzen; + IF kein platz mehr fuer restfenster + THEN eingeschachtelte editoren vergessen; + bildeinschraenkung aufheben + ELSE neu (nix, nix) + FI . + +aktuellen zustand retten : + IF actual editor > 0 + THEN editstack (actual editor).feldstatus := feldstatus; + editstack (actual editor).bildstatus := bildstatus; + einrueckstack (actual editor) := alte einrueckposition; + dateizustand retten + FI . + +neuen zustand setzen : + feldstatus := editstack (i).feldstatus; + bildstatus := editstack (i).bildstatus; + alte einrueckposition := einrueckstack (i); + dateizustand holen . + +kein platz mehr fuer restfenster : + kurze feldlaenge < 1 AND kurze bildlaenge < 1 . + +eingeschachtelte editoren vergessen : + IF actual editor < max used editor + THEN open editor (actual editor + 1) ; + quit + FI ; + open editor (i) . + +bildeinschraenkung aufheben : + laenge := feldlaenge; + kurze feldlaenge := feldlaenge; + kurze bildlaenge := bildlaenge; + neu (ueberschrift, bild) . +END PROC open editor; + +FILE PROC editfile : + IF actual editor = 0 OR editget modus + THEN errorstop ("Editor nicht eroeffnet") + FI ; file +END PROC editfile; + +PROC get window (INT VAR x, y, x size, y size) : + x := rand + 1; + y := bildrand; + x size := feldlaenge + 2; + y size := bildlaenge + 1 +ENDPROC get window; + +(************************* Zugriff auf Bildstatus *************************). + +feldlaenge : bildstatus.feldlaenge . +kurze feldlaenge : bildstatus.kurze feldlaenge . +bildrand : bildstatus.bildrand . +bildlaenge : bildstatus.bildlaenge . +kurze bildlaenge : bildstatus.kurze bildlaenge . +ueberschriftbereich : bildstatus.ueberschriftbereich . +bildbereich : bildstatus.bildbereich . +erster neusatz : bildstatus.erster neusatz . +letzter neusatz : bildstatus.letzter neusatz . +old zeilennr : bildstatus.old zeilennr . +old lineno : bildstatus.old lineno . +old mark lineno : bildstatus.old mark lineno . +zeileneinfuegen : bildstatus.zeileneinfuegen . +old line update : bildstatus.old line update . +satznr pre : bildstatus.satznr pre . +ueberschrift pre : bildstatus.ueberschrift pre . +ueberschrift text : bildstatus.ueberschrift text . +ueberschrift post : bildstatus.ueberschrift post . +old satz : bildstatus.old satz . +old range : bildstatus.old range . +file : bildstatus.file . + +END PACKET editor paket; + diff --git a/system/base/1.7.5/src/elan do interface b/system/base/1.7.5/src/elan do interface new file mode 100644 index 0000000..72026a7 --- /dev/null +++ b/system/base/1.7.5/src/elan do interface @@ -0,0 +1,57 @@ + +PACKET elan do interface DEFINES (*Autor: J.Liedtke *) + (*Stand: 08.11.85 *) + do , + no do again : + + +LET no ins = FALSE , + no lst = FALSE , + no check = FALSE , + no sermon = FALSE , + compile line mode = 2 , + do again mode = 4 , + max command length = 2000 ; + + +INT VAR do again mod nr := 0 ; +TEXT VAR previous command := "" ; + +DATASPACE VAR ds ; + + +PROC do (TEXT CONST command) : + + enable stop ; + IF LENGTH command > max command length + THEN errorstop ("Kommando zu lang") + ELIF do again mod nr <> 0 AND command = previous command + THEN do again + ELSE previous command := command ; + compile and execute + FI . + +do again : + elan (do again mode, ds, "", do again mod nr, + no ins, no lst, no check, no sermon) . + +compile and execute : + elan (compile line mode, ds, command, do again mod nr, + no ins, no lst, no check, no sermon) . + +ENDPROC do ; + +PROC no do again : + + do again mod nr := 0 + +ENDPROC no do again ; + +PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line, + INT VAR start module number, + BOOL CONST ins, lst, rt check, ser) : + EXTERNAL 256 +ENDPROC elan ; + +ENDPACKET elan do interface ; + diff --git a/system/base/1.7.5/src/error handling b/system/base/1.7.5/src/error handling new file mode 100644 index 0000000..34db65d --- /dev/null +++ b/system/base/1.7.5/src/error handling @@ -0,0 +1,142 @@ + +PACKET error handling DEFINES + + enable stop , + disable stop , + is error , + clear error , + errormessage , + error code , + error line , + put error , + errorstop , + stop : + + +LET cr lf = ""13""10"" , + line nr field = 1 , + error line field = 2 , + error code field = 3 , + syntax error code= 100 , + + error pre = ""7""13""10""5"FEHLER : " ; + + +TEXT VAR errortext := "" ; + + +PROC enable stop : + EXTERNAL 75 +ENDPROC enable stop ; + +PROC disable stop : + EXTERNAL 76 +ENDPROC disable stop ; + +PROC set error stop (INT CONST code) : + EXTERNAL 77 +ENDPROC set error stop ; + +BOOL PROC is error : + EXTERNAL 78 +ENDPROC is error ; + +PROC clear error : + EXTERNAL 79 +ENDPROC clear error ; + +PROC select error message : + + SELECT error code OF + CASE 1 : error text := "'halt' vom Terminal" + CASE 2 : error text := "Stack-Ueberlauf" + CASE 3 : error text := "Heap-Ueberlauf" + CASE 4 : error text := "INT-Ueberlauf" + CASE 5 : error text := "DIV durch 0" + CASE 6 : error text := "REAL-Ueberlauf" + CASE 7 : error text := "TEXT-Ueberlauf" + CASE 8 : error text := "zu viele DATASPACEs" + CASE 9 : error text := "Ueberlauf bei Subskription" + CASE 10: error text := "Unterlauf bei Subskription" + CASE 11: error text := "falscher DATASPACE-Zugriff" + CASE 12: error text := "INT nicht initialisiert" + CASE 13: error text := "REAL nicht initialisiert" + CASE 14: error text := "TEXT nicht initialisiert" + CASE 15: error text := "nicht implementiert" + CASE 16: error text := "Block unlesbar" + CASE 17: error text := "Codefehler" + END SELECT + +ENDPROC select error message ; + +TEXT PROC error message : + + select error message ; + error text + +ENDPROC error message ; + +INT PROC error code : + + pcb (error code field) + +ENDPROC error code ; + +INT PROC error line : + + IF is error + THEN pcb (error line field) + ELSE 0 + FI + +ENDPROC error line ; + +PROC syntax error (TEXT CONST message) : + + INTERNAL 259 ; + errorstop (syntax error code, message) . + +ENDPROC syntax error ; + +PROC errorstop (TEXT CONST message) : + + errorstop (0, message) ; + +ENDPROC errorstop ; + +PROC errorstop (INT CONST code, TEXT CONST message) : + + IF NOT is error + THEN error text := message ; + set error stop (code) + FI + +ENDPROC errorstop ; + +PROC put error : + + IF is error + THEN select error message ; + IF error text <> "" + THEN put error message + FI + FI . + +put error message : + out (error pre) ; + out (error text) ; + IF error line > 0 + THEN out (" bei Zeile "); out (text (error line)) ; + FI ; + out (cr lf) . + +ENDPROC put error ; + +PROC stop : + + errorstop ("stop") + +ENDPROC stop ; + +ENDPACKET error handling ; + diff --git a/system/base/1.7.5/src/eumel coder part 1 b/system/base/1.7.5/src/eumel coder part 1 new file mode 100644 index 0000000..83974f7 --- /dev/null +++ b/system/base/1.7.5/src/eumel coder part 1 @@ -0,0 +1,866 @@ +PACKET eumel coder part 1 (* Autor: U. Bartling *) + DEFINES run, run again, + insert, + prot, prot off, + check, check on, check off, + warnings, warnings on, warnings off, + + help, bulletin, packets + : + +(**************************************************************************) +(* *) +(* E U M E L - C O D E R *) +(* *) +(* *) +(* Zur Beschreibung des Coders siehe *) +(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *) +(* *) +(* Stand der Dokumentation : 13.02.1986 *) +(* Stand der Implementation : 16.04.1986 *) +(* *) +(* *) +(**************************************************************************) + + + (***** Globale Variable *****) + +TEXT VAR object name; + +FILE VAR bulletin file; + +INT VAR hash table pointer, nt link, permanent pointer, param link, + index, mode, word; + +BOOL VAR found, end of params; + +#page# +(**************************************************************************) +(* *) +(* 1. Interface zum ELAN-Compiler 10.04.1986 *) +(* 1.7.5.4 *) +(* *) +(* Beschreibung der Tabellen (-groessen), *) +(* internen Vercodung von Typen *) +(* und Kennungen . *) +(* Initialisieren und Beenden des Compilers, *) +(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *) +(* *) +(**************************************************************************) + + +LET begin of hash table = 0 , + end of hash table = 1023 , + + begin of permanent table = 22784 , + before first pt entry = 22784 , + first permanent entry = 22785 , + end of permanent table = 32767 , + + wordlength = 1 , (* compile u n d run time *) + two word length = 2 , + three word length = 3 , + + permanent param const = 10000 , + permanent param var = 20000 , + permanent proc op = 30000 , + permanent type = 30000 , + permanent row = 10 , + permanent struct = 11 , + permanent param proc = 12 , +(* permanent param proc end marker = 0 , *) + permanent type field = 0 , + + ptt limit = 10000 , + begin of pt minus ptt limit = 12784 , + + void = 0 , + int = 1 , + real = 2 , + string = 3 , + bool = 5 , + bool result = 6 , + dataspace = 7 , + row = 10 , + struct = 11 , + + const = 1 , + var = 2 , +(* proc = 3 , *) +(* denoter = 5 , *) + bold = 2 , + + ins = TRUE , + no ins = FALSE , + no lst = FALSE , + sermon = TRUE , + no sermon = FALSE , + + run again mode = 0 , + compile file mode = 1 , + + warning message = 2 , + error message = 4 , + + point line = "..............." ; + +INT CONST permanent packet := -2 , + permanent end := -3 ; + + +INT VAR run again mod nr := 0 ; + + + (***** Start/Ende *****) + +PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line, + INT VAR start module number, BOOL CONST ins, lst, rtc, ser) : + EXTERNAL 256 +ENDPROC elan ; + + (***** Hash/Namenstabelle *****) +. +next hash entry : + hash table pointer INCR wordlength . + +end of hash table reached : + hash table pointer > end of hash table . + +yet another nt entry : + nt link := cdb int (nt link) ; + nt link <> 0 . ; + +PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) : + EXTERNAL 10031 +ENDPROC declare object ; + +PROC to object (TEXT CONST searched object) : + hash ; + search nt entry . + +hash : + hash code := 0 ; + FOR index FROM 1 UPTO LENGTH searched object REP + addmult cyclic + ENDREP . + +addmult cyclic : + hash code INCR hash code ; + IF hash code > end of hash table THEN wrap around FI ; + hash code := (hash code + code (searched object SUB index)) MOD 1024 . + +wrap around : + hash code DECR end of hash table . + +hash code : nt link . + +search nt entry : + found := FALSE ; + WHILE yet another nt entry REP + read current entry ; + IF object name = searched object + THEN found := TRUE ; + LEAVE to object + FI + PER . + +read current entry : + permanent pointer := cdb int (nt link + wordlength) ; + object name := cdb text (nt link + two word length) +ENDPROC to object ; + + + (***** Permanent Tabelle *****) +. +next procedure : + permanent pointer := cdb int (permanent pointer) . ; + +PROC next pt param : + mode := cdb int (param link) MOD ptt limit ; + param link INCR wordlength ; + IF mode = permanent row THEN skip over permanent row + ELIF mode = permanent struct THEN skip over permanent struct + FI ; + set end marker if end of list . + +skip over permanent row : + param link INCR wordlength ; + next pt param . + +skip over permanent struct : + REP + next pt param ; + mode := cdb int (param link) + UNTIL mode = permanent type field PER ; + param link INCR wordlength +ENDPROC next pt param ; + +PROC set end marker if end of list : + mode := cdb int (param link) ; + end of params := mode >= permanent proc op OR mode <= 0 +ENDPROC set end marker if end of list ; + +PROC get type and mode (INT VAR type) : + mode := cdb int (param link) ; + IF mode = permanent param proc THEN type of param proc + ELSE type of object + FI . + +type of param proc : + param link INCR wordlength ; + get type and mode (type) ; + mode := permanent param proc . + +type of object : + IF mode < 0 THEN type := 2769 + (32767 + mode) ; + mode := 0 + ELSE type := mode MOD ptt limit ; + mode DECR type ; + translate type if necessary ; + translate mode if necessary + FI . + +translate type if necessary : + IF permanent row or struct THEN translate type FI . + +translate type : + type := param link - begin of pt minus ptt limit . + +translate mode if necessary : + IF mode = permanent param const THEN mode := const + ELIF mode = permanent param var THEN mode := var + FI . + +permanent row or struct : + type = permanent row OR type = permanent struct +ENDPROC get type and mode ; + + + (***** Allgemeine Zugriffsprozeduren *****) + +INT PROC cdb int (INT CONST index) : + EXTERNAL 116 +ENDPROC cdb int ; + +TEXT PROC cdb text (INT CONST index) : + EXTERNAL 117 +ENDPROC cdb text ; + +#page# +(**************************************************************************) +(* *) +(* 10. Inspector 16.04.1986 *) +(* *) +(**************************************************************************) + + + +INT VAR line number, pattern length, packet link, + begin of packet, last packet entry, indentation; + +TEXT VAR bulletin name, type and mode, pattern, buffer; + +DATASPACE VAR bulletin ds :: nilspace ; + +.packet name : + cdb text (cdb int(packet link + wordlength) + two word length) . + +.within editor : + aktueller editor > 0 . ; + +PROC name of type (INT CONST type) : + SELECT type OF + CASE void : + CASE int : type and mode CAT "INT" + CASE real : type and mode CAT "REAL" + CASE string : type and mode CAT "TEXT" + CASE bool, bool result : type and mode CAT "BOOL" + CASE dataspace : type and mode CAT "DATASPACE" + CASE row : type and mode CAT "ROW " + CASE struct : type and mode CAT "STRUCT" + OTHERWISE : complex type + ENDSELECT . + +complex type : + IF type > ptt limit THEN perhaps permanent struct or row + ELSE get complex type + FI . + +perhaps permanent struct or row : + index := type + begin of pt minus ptt limit ; + mode := cdb int (index) MOD ptt limit ; + IF mode = permanent row THEN get permanent row + ELIF mode = permanent struct THEN get permanent struct + ELSE type and mode CAT "-" + FI . + +get complex type : + index := type + begin of permanent table ; + IF is complex type THEN get name + ELSE type and mode CAT "-" + FI . + +is complex type : + permanent type definition mode = permanent type . + +get name : + type and mode CAT cdb text (link to type name + two word length) . + +link to type name : + cdb int (index + three word length) . + +permanent type definition mode : + cdb int (index + wordlength) . + +get permanent row : + INT VAR t; + type and mode CAT "ROW " ; + type and mode CAT text (cdb int (index + wordlength)) ; + type and mode CAT " " ; + param link := index + two wordlength ; + get type and mode (t) ; + name of type (t) . + +get permanent struct : + type and mode CAT "STRUCT ( ... )" +ENDPROC name of type ; + +PROC help (TEXT CONST proc name) : + prep bulletin ; + prep help ; + scan (object name) ; + next symbol (pattern) ; + packet link := end of permanent table ; + IF function = 0 THEN standard help + ELSE asterisk help + FI . + +prep help : + object name := compress (proc name) ; + INT VAR function :: 0 ; + INT CONST l :: LENGTH object name ; + IF l > 1 AND object name <> "**" + THEN IF (object name SUB l) = "*" + THEN function INCR 2 ; + delete char (object name, l) + FI ; + IF (object name SUB 1) = "*" + THEN function INCR 1 ; + delete char (object name, 1) + FI ; + IF another asterisk THEN wrong function FI + FI. + +another asterisk : + pos (object name, "*") <> 0 . + +wrong function : + errorstop ("unzulaessige Sternfunktion") . + +standard help : + to object (pattern) ; + IF found THEN display + ELSE error stop ("unbekannt: " + proc name) + FI . + +display : + WHILE permanent pointer <> 0 REP + put name of packet if necessary ; + put specifications (pattern) ; + next procedure + ENDREP ; + show bulletin file . + +put name of packet if necessary : + IF new packet THEN packet link := permanent pointer ; + find begin of packet ; + writeline (2) ; + write packet name + FI . + +find begin of packet : + REP + packet link DECR wordlength + UNTIL begin of packet found PER . + +begin of packet found : + cdb int (packet link) = permanent packet . + +new packet : + permanent pointer < packet link . + +asterisk help : + hash table pointer := begin of hash table ; + pattern length := LENGTH pattern - 1 ; + REP + list all objects in current hash table chain ; + next hash entry + UNTIL end of hash table reached ENDREP ; + show bulletin file . + +list all objects in current hash table chain : + nt link := hash table pointer ; + WHILE yet another nt entry REP + permanent pointer := cdb int (nt link + wordlength) ; + object name := cdb text (nt link + two word length) ; + IF matching THEN into bulletin FI + PER . + +matching : + INT CONST p :: pos (object name, pattern) ; + SELECT function OF + CASE 1 : p <> 0 AND p = LENGTH object name - pattern length + CASE 2 : p = 1 + CASE 3 : p <> 0 + OTHERWISE FALSE + ENDSELECT . + +into bulletin : + object names into bulletin (BOOL PROC not end of chain) +ENDPROC help ; + +BOOL PROC not end of chain : + permanent pointer <> 0 +ENDPROC not end of chain ; + +PROC write packet name : + indentation := 0 ; + write line ; + write bulletin line ("PACKET ") ; + indentation := 7 ; + object name := packet name ; + write bulletin line (object name) ; + write bulletin line (":") ; + writeline (2) +ENDPROC write packet name ; + +PROC put specifications (TEXT CONST proc name) : + put obj name (proc name) ; + to first param ; + IF NOT end of params THEN put param list FI ; + put result ; + writeline . + +to first param : + param link := permanent pointer + word length ; + set end marker if end of list . + +put result : + INT VAR type; + get type and mode (type) ; + IF type <> void THEN type and mode := " --> " ; + name of type (type) ; + write bulletin line (type and mode) + FI +ENDPROC put specifications ; + +PROC put param list : + write bulletin line (" (") ; + REP + INT VAR type, param mode; + get type and mode (type) ; + param mode := mode ; + put type and mode ; + maybe param proc ; + next pt param ; + IF end of params THEN write bulletin line (")") ; + LEAVE put param list + FI ; + write bulletin line (", ") ; + PER . + +put type and mode : + type and mode := "" ; + name of type (type) ; + type and mode CAT name of mode ; + write bulletin line (type and mode) . + +name of mode : + IF param mode = const THEN " CONST" + ELIF param mode = var THEN " VAR" + ELSE " PROC" + FI . + +maybe param proc : + IF mode = permanent param proc THEN put virtual params FI . + +put virtual params : + skip over result type if complex type ; + IF NOT end of virtual params THEN put param list FI. + +skip over result type if complex type : + next pt param . + +end of virtual params : + end of params +ENDPROC put param list ; + +PROC next packet : + REP + packet link INCR wordlength ; + word := cdb int (packet link) ; + IF word = permanent packet THEN true return + ELIF end of permanents THEN false return + FI ; + ENDREP . + +true return : + found := TRUE ; + LEAVE next packet . + +false return : + found := FALSE ; + LEAVE next packet . + +end of permanents : + word = permanent end OR packet link > end of permanent table +ENDPROC next packet ; + +PROC prep bulletin : + forget (bulletin ds) ; + bulletin ds := nilspace ; + bulletin file := sequential file (output, bulletin ds) ; + line number := 0 ; + buffer := "" +ENDPROC prep bulletin ; + +PROC show bulletin file : + IF within editor THEN ueberschrift neu FI ; + DATASPACE VAR local ds :: bulletin ds ; + FILE VAR local file :: sequential file (modify, local ds) ; + show (local file) ; + forget (local ds) +ENDPROC show bulletin file ; + +PROC write bulletin line (TEXT CONST line) : + IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ; + buffer CAT line +ENDPROC write bulletin line ; + +PROC writeline : + write (bulletin file, buffer) ; + line (bulletin file) ; + line number INCR 1 ; + cout (line number) ; + buffer := indentation * " " +ENDPROC writeline ; + +PROC writeline (INT CONST times) : + IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ; + writeline + ELSE index := times + FI ; + line (bulletin file, index) ; + line number INCR index; + indentation := 0 ; + cout (line number) +ENDPROC writeline ; + +PROC bulletin (TEXT CONST packet name) : + prep bulletin ; + scan (packet name) ; + next symbol (pattern) ; + to packet ; + IF found THEN list packet ; + show bulletin file + ELSE error stop (packet name + " ist kein Paketname") + FI . + +to packet : + last packet entry := 0 ; + get nametab link of packet name ; + packet link := before first pt entry ; + REP + packet link INCR wordlength ; + word := cdb int (packet link) ; + IF word < 0 THEN IF word = permanent packet THEN packet found + ELIF word = permanent end THEN return + FI + FI + ENDREP . + +get nametab link of packet name : + to object (pattern) ; + IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ; + LEAVE to packet + FI . + +packet found : + IF cdb int (packet link + wordlength) = nt link + THEN last packet entry := packet link FI . + +return : + IF last packet entry <> 0 THEN found := TRUE ; + packet link := last packet entry + ELSE found := FALSE + FI ; + LEAVE to packet +ENDPROC bulletin ; + +PROC list packet : + begin of packet := packet link + word length ; + write packet name ; + find end of packet ; + run through nametab and list all packet objects . + +find end of packet : + last packet entry := begin of packet ; + REP + last packet entry INCR wordlength ; + word := cdb int (last packet entry) ; + UNTIL end of packet entries PER . + +end of packet entries : + word = permanent packet OR word = permanent end . + +run through nametab and list all packet objects : + hashtable pointer := begin of hashtable ; + REP + nt link := hashtable pointer ; + list objects of current packet in this chain ; + next hash entry + UNTIL end of hashtable reached ENDREP . + +list objects of current packet in this chain : + WHILE yet another nt entry REP + permanent pointer := cdb int (nt link + wordlength) ; + put objects of this name + PER . + +put objects of this name : + IF there is at least one object of this name in the current packet + THEN into bulletin FI . + +there is at least one object of this name in the current packet : + REP + IF permanent pointer >= begin of packet AND + permanent pointer < last packet entry + THEN LEAVE there is at least one object of this name + in the current packet WITH TRUE FI ; + next procedure + UNTIL permanent pointer = 0 PER ; + FALSE . + +into bulletin : + object name := cdb text (nt link + two word length) ; + object names into bulletin (BOOL PROC within packet) +ENDPROC list packet ; + +BOOL PROC within packet : + permanent pointer >= begin of packet AND + permanent pointer < last packet entry +ENDPROC within packet ; + +PROC object names into bulletin (BOOL PROC link ok) : + scan (object name) ; + next symbol (object name, mode) ; + IF type definition THEN put type definition + ELSE put object definitions + FI . + +type definition : + mode = bold AND no params . + +no params : + cdb int (permanent pointer + word length) >= permanent type . + +put type definition : + put obj name (object name) ; + write bulletin line ("TYPE ") ; + writeline (1) . + +put object definitions : + WHILE link ok REP + put specifications (object name) ; + next procedure + ENDREP +ENDPROC object names into bulletin ; + +PROC bulletin : + prep bulletin ; + packet link := first permanent entry ; + REP + list packet ; + write line (4) ; + next packet + UNTIL NOT found PER ; + show bulletin file +ENDPROC bulletin ; + +PROC put obj name (TEXT CONST name) : + buffer := " " ; + bulletin name := point line ; + change (bulletin name, 1, end of line or name, name) ; + buffer CAT bulletin name ; + indentation := LENGTH buffer + 1 . + +end of line or name : + min (LENGTH name, LENGTH bulletin name) +ENDPROC put obj name ; + +PROC packets : + prep bulletin ; + packet link := first permanent entry ; + REP + object name := packet name ; + put obj name (object name) ; + write line ; + next packet + UNTIL NOT found PER ; + show bulletin file +ENDPROC packets ; + +#page# +(**************************************************************************) +(* *) +(* 11. ELAN Run-Interface 09.01.1986 *) +(* *) +(* Uebersetzen von ELAN-Programmen *) +(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *) +(* *) +(**************************************************************************) + + + +BOOL VAR list option := FALSE , + check option := TRUE , + warning option := FALSE , + listing enabled := FALSE ; + +FILE VAR listing file ; + +TEXT VAR listing file name := "" ; + + +PROC run (TEXT CONST file name) : + enable stop ; + IF NOT exists (file name) + THEN errorstop ("""" + file name + """ gibt es nicht") + FI ; + last param (file name) ; + run elan (file name, no ins) +END PROC run; + +PROC run : + run (last param) +ENDPROC run ; + +PROC run again : + IF run again mod nr <> 0 + THEN elan (run again mode, bulletin file, "", run again mod nr, + no ins, no lst, check option, no sermon) + ELSE errorstop ("'run again' nicht moeglich") + FI +ENDPROC run again ; + +PROC insert (TEXT CONST file name) : + enable stop ; + IF NOT exists (file name) + THEN errorstop ("""" + file name + """ gibt es nicht") + FI ; + last param (file name) ; + run elan (file name, ins) +ENDPROC insert ; + +PROC insert : + insert (last param) +ENDPROC insert ; + +PROC run elan (TEXT CONST file name, BOOL CONST insert option) : + FILE VAR source := sequential file (modify, file name) ; + IF listing enabled + THEN open listing file + FI ; + + disable stop ; + no do again ; + elan (compile file mode, source, "" , run again mod nr, + insert option, list option, check option, sermon) ; + + IF anything noted AND command dialogue + THEN ignore halt during compiling ; + note edit (source) ; + last param (file name) ; + errorstop ("") + FI . + +ignore halt during compiling : + IF is error + THEN put error ; + clear error ; + pause (5) + FI . + +open listing file : + listing file := sequential file (output, listing file name) ; + max line length (listing file, 130) + +ENDPROC run elan ; + +PROC out text (TEXT CONST text, INT CONST out type) : + INTERNAL 257 ; + IF online + THEN out (text) + FI ; + IF out type = error message OR (warning option AND out type = warning message) + THEN note (text) ; + FI ; + IF listing enabled + THEN write (listing file, text) + FI +ENDPROC out text ; + +PROC out line (INT CONST out type) : + INTERNAL 258 ; + IF online + THEN out (""13""10"") + FI ; + IF out type = error message + OR (warning option AND out type = warning message) + THEN note line + ELIF listing enabled + THEN line (listing file) + FI +ENDPROC out line ; + +PROC prot (TEXT CONST file name) : + list option := TRUE ; + listing file name := file name ; + listing enabled := TRUE +ENDPROC prot ; + +PROC prot off : + list option := FALSE ; + listing enabled := FALSE +ENDPROC prot off ; + +BOOL PROC prot : + list option +ENDPROC prot ; + +PROC check on : + check option := TRUE +ENDPROC check on ; + +PROC check off : + check option := FALSE +ENDPROC check off ; + +BOOL PROC check : + check option +ENDPROC check ; + +PROC warnings on : + warning option := TRUE +ENDPROC warnings on ; + +PROC warnings off : + warning option := FALSE +ENDPROC warnings off ; + +BOOL PROC warnings : + warning option +ENDPROC warnings ; + +ENDPACKET eumel coder part 1 ; + diff --git a/system/base/1.7.5/src/file b/system/base/1.7.5/src/file new file mode 100644 index 0000000..530dcb3 --- /dev/null +++ b/system/base/1.7.5/src/file @@ -0,0 +1,2122 @@ +(* ------------------- VERSION 35 02.06.86 ------------------- *) +PACKET file handling DEFINES (* Autoren: J.Liedtke, D.Martinek *) + (***********) + + FILE, + :=, + sequential file, + reorganize, + input, + output, + modify, + close, + putline, + getline, + put, + get, + write , + line, + reset, + down, + up, + downety, + uppety, + pattern found, + to first record, + to line, + to eof, + insert record, + delete record, + read record, + write record, + is first record, + eof, + line no, + FRANGE, + set range, + reset range , + remove, + clear removed, + reinsert, + max line length, + edit info, + line type , + copy attributes , + headline, + put tabs, + get tabs, + col, + word, + at, + removed lines, + exec, + pos , + len , + subtext , + change , + lines , + segments , + mark , + mark line no , + mark col , + set marked range , + split line , + concatenate line , + prefix , + sort , + lexsort : + + +(**********************************************************************) +(* *) +(* Terminologie: *) +(* *) +(* *) +(* ATOMROW Menge aller Atome eines FILEs. *) +(* Die einzelnen Atome haben zwar eine Position *) +(* im Row, aber in dieser Betrachtung keine *) +(* logische Reihenfolge. *) +(* *) +(* ATOM Basiselement, kann eine Zeile der Datei und die *) +(* zugehoerige Verwaltungsinformation aufnehmen *) +(* *) +(* CHAIN Zyklisch geschlossene Kette von Segmenten. *) +(* *) +(* SEGMENT Teilbereich des Atomrows, enthaelt 1 oder mehr *) +(* zusammenhaengende Atoms. *) +(* Jedes Segment hat ein Vorgaenger- und ein *) +(* Nachfolgersegment. *) +(* Jedes Segment enthaelt einen logisch zumsammen- *) +(* haengenden Teile einer Sequence. *) +(* *) +(* SEQUENCE Logische Folge von Lines. *) +(* Jede Sequence ist Teil einer Chain oder besteht *) +(* vollstaendig daraus: *) +(* *) +(* SEG1--SEG2--SEG3--SEG4--SEG5 *) +(* :----sequence----: *) +(* *) +(* Die 'Reihenfolge' ebenso wie die 'Anzahl' der *) +(* Lines ist eine wesentliche Eigenschaft einer *) +(* Sequence. *) +(* *) +(* LINE Ein Atom als Element ein Sequence betrachtet. *) +(* *) +(* *) +(**********************************************************************) +(* *) +(* Eigenschaften: *) +(* *) +(* Folgende Mengen bilden eine Zerlegung (im math. Sinn) einer *) +(* gesamten Datei: *) +(* used segment chain *) +(* scratch segment chain *) +(* free segment chain *) +(* unused tail *) +(* *) +(* Fuer jedes X aus (used, scratch, free) gelten: *) +(* *) +(* 'X sequence' ist echte Teilmenge von 'X segment chain'. *) +(* *) +(* (Daraus folgt, es gibt keine leere 'chain'.) *) +(* *) +(* 'X segment chain' ist zyklisch gekettet. *) +(* *) +(* Alle Atome von 'X segment chain' haben definierten Inhalt. *) +(* *) +(**********************************************************************) + + +LET file size = 4075 , + nil = 0 , + + free root = 1 , + scratch root = 2 , + used root = 3 , + first unused = 4 ; + + +LET SEQUENCE = STRUCT (INT index, segment begin, segment end, + INT line no, lines), + SEGMENT = STRUCT (INT succ, pred, end), + ATOM = STRUCT (SEGMENT seg, INT type, TEXT line), + ATOMROW = ROW filesize ATOM, + + LIST = STRUCT (SEQUENCE used, INT prefix lines, postfix lines, + SEQUENCE scratch, free, INT unused tail, + INT mode, col, limit, edit info, mark line, mark col, + ATOMROW atoms); + +TYPE FILE = BOUND LIST ; + +TYPE FRANGE = STRUCT (INT pre, post, BOOL pre was split, post was split); + + +OP := (FRANGE VAR left, FRANGE CONST right): + CONCR (left) := CONCR (right) +ENDOP := ; + + +OP := (FILE VAR left, FILE CONST right): + EXTERNAL 260 +END OP :=; + + +PROC becomes (INT VAR a, b) : + INTERNAL 260 ; + a := b +END PROC becomes; + + +PROC initialize (FILE VAR f) : + + f.used := SEQUENCE : (used root, used root, used root, 1, 0); + f.prefix lines := 0; + f.postfix lines := 0; + f.free := SEQUENCE : (free root, free root, free root, 1, 0); + f.scratch := SEQUENCE : (scratch root, scratch root, scratch root, 1, 0); + f.unused tail := first unused; + + f.limit := 77; + f.edit info := 0; + f.col := 1 ; + f.mark line := 0 ; + f.mark col := 0 ; + + INT VAR i; + FOR i FROM 1 UPTO 3 REP + root (i).seg := SEGMENT : (i, i, i); + root (i).line := "" + PER; + put tabs (f, "") . + +root : f.atoms . + +END PROC initialize; + + +(**********************************************************************) +(* *) +(* Segment Handler (SEGMENTs & CHAINs) *) +(* *) +(**********************************************************************) + +INT PROC segs (SEQUENCE CONST s, ATOMROW CONST atom) : + + INT VAR number of segments := 0 , + actual segment := s.segment begin ; + REP + number of segments INCR 1 ; + actual segment := atom (actual segment).seg.succ + UNTIL actual segment = s.segment begin PER ; + number of segments . + +ENDPROC segs ; + + +PROC next segment (SEQUENCE VAR s, ATOMROW CONST atom) : + + disable stop; + s.line no INCR (s.segment end - s.index + 1); + INT CONST new segment index := actual segment.succ; + s.segment begin := new segment index; + s.segment end := new segment.end; + s.index := new segment index . + +actual segment : atom (s.segment begin).seg . +new segment : atom (new segment index).seg . + +END PROC next segment; + + +PROC previous segment (SEQUENCE VAR s, ATOMROW CONST atom) : + + disable stop; + s.line no DECR (s.index - s.segment begin + 1); + INT CONST new segment index := actual segment.pred; + s.segment begin := new segment index; + s.segment end := new segment.end; + s.index := s.segment end . + +actual segment : atom (s.segment begin).seg . +new segment : atom (new segment index).seg . + +END PROC previous segment; + + +PROC split segment (SEQUENCE VAR s, ATOMROW VAR atom) : + + disable stop; + IF not at segment top + THEN split segment at actual position + FI . + +split segment at actual position : + INT CONST pred index := s.segment begin, + actual index := s.index, + succ index := pred.succ; + + actual.pred := pred index; + actual.succ := succ index; + actual.end := s.segment end; + + pred.succ := actual index; + pred.end := actual index - 1; + + succ.pred := actual index; + + s.segment begin := actual index . + +not at segment top : s.index > s.segment begin . + +pred : atom (pred index).seg . + +actual : atom (actual index).seg . + +succ : atom (succ index).seg . + +END PROC split segment; + + +PROC join segments (ATOMROW VAR atom, + INT CONST first index, INT VAR second index) : + + disable stop; + IF first seg.end + 1 = second index + THEN attach second to first segment + ELSE link first to second segment + FI . + +attach second to first segment : + first seg.end := second seg.end; + INT VAR successor of second := second seg.succ; + IF successor of second = second index + THEN first seg.succ := first index + ELSE join segments (atom, first index, successor of second) + FI; + second index := first index . + +link first to second segment : + first seg.succ := second index; + second seg.pred := first index . + +first seg : atom (first index).seg . +second seg : atom (second index).seg . + +END PROC join segments; + + +PROC delete segments (SEQUENCE VAR from, ATOMROW VAR atom, + INT CONST first index, last index, lines) : + + determine surrounding segments and new atom index; + join surrounding segments; + update sequence descriptor . + +determine surrounding segments and new atom index : + INT VAR pred index := first seg.pred, + actual index := last seg.succ; + from.index := actual index . + +join surrounding segments : + join segments (atom, pred index, actual index) . + +update sequence descriptor : + from.segment begin := actual index; + from.segment end := actual seg.end; + from.lines DECR lines . + +actual seg : atom (actual index).seg . +first seg : atom (first index).seg . +last seg : atom (last index).seg . + +END PROC delete segments; + + +PROC insert segments (SEQUENCE VAR into, ATOMROW VAR atom, + INT CONST first index, last index, lines) : + + join into sequence and new segments; + update sequence descriptor . + +join into sequence and new segments : + INT VAR actual index := into.index, + pred index := actual seg.pred; + join segments (atom, last index, actual index); + actual index := first index; + join segments (atom, pred index, actual index) . + +update sequence descriptor : + into.index := first index; + into.segment begin := actual index; + into.segment end := actual seg.end; + into.lines INCR lines . + +actual seg : atom (actual index).seg . + +END PROC insert segments; + + +PROC next atom (SEQUENCE VAR s, ATOMROW CONST atom) : + + IF s.line no <= s.lines + THEN to next atom + ELSE errorstop ("'down' nach Dateiende") + FI . + +to next atom : + disable stop; + IF s.index = s.segment end + THEN next segment (s, atom) + ELSE s.index INCR 1; + s.line no INCR 1 + FI + +END PROC next atom; + + +PROC next atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) : + + INT CONST destination line := min (s.line no + times, s.lines + 1); + jump upto destination segment; + position within destination segment . + +jump upto destination segment : + WHILE s.line no + length of actual segments tail < destination line REP + next segment (s, atom); + PER . + +position within destination segment : + disable stop; + s.index INCR (destination line - s.line no); + s.line no := destination line . + +length of actual segments tail : s.segment end - s.index . + +END PROC next atoms; + + +PROC previous atom (SEQUENCE VAR s, ATOMROW CONST atom) : + + IF s.line no > 1 + THEN to previous atom + ELSE errorstop ("'up' am Dateianfang") + FI . + +to previous atom : + disable stop; + IF s.index = s.segment begin + THEN previous segment (s, atom) + ELSE s.index DECR 1; + s.line no DECR 1 + FI + +END PROC previous atom; + + +PROC previous atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) : + + INT CONST destination line := max (1, s.line no - times); + jump back to destination segment; + position within destination segment . + +jump back to destination segment : + WHILE s.line no - length of actual segments head > destination line REP + previous segment (s, atom); + PER . + +position within destination segment : + disable stop; + s.index DECR (s.line no - destination line); + s.line no := destination line . + +length of actual segments head : s.index - s.segment begin . + +END PROC previous atoms; + + +TEXT VAR pre, pat, pattern0; +INT VAR last search line ; + +PROC search down (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT CONST max lines, INT VAR column) : + + INT CONST start col := column , + start line := s.lineno ; + last search line := min (s.lines, s.lineno + max lines) ; + pre:= somefix (pattern) ; + pattern0 := pattern ** 0 ; + down in atoms (s, atom, pre, column); + IF NOT (last search succeeded CAND like pattern) + THEN try again + FI; + last search succeeded := TRUE ; + column := matchpos (0) . + +try again: + WHILE s.line no < last search line + REP next atom (s, atom) ; + column := 1 ; + down in atoms (s, atom, pre, column); + IF last search succeeded CAND like pattern + THEN LEAVE try again + FI + PER; + column := 1 + LENGTH record; + last search succeeded := FALSE ; + LEAVE search down. + +like pattern : + correct position ; + pat := any (column-1) ; + pat CAT any ; + pat CAT pattern0 ; + pat CAT any ; + record LIKE pat . + +correct position : + IF s.lineno = start line + THEN column := start col + ELSE column := 1 + FI . + +record : atom (s.index).line . + +ENDPROC search down ; + +PROC down in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT VAR column) : + + last search succeeded := FALSE ; + search forwards in actual line ; + IF NOT found AND s.line no < last search line + THEN search in following lines + FI ; + IF found + THEN last search succeeded := TRUE + ELSE set column behind last char + FI . + +set column behind last char : + column := LENGTH atom (s.index).line + 1 . + +search forwards in actual line : + IF pattern <> "" + THEN column := pos (atom (s.index).line, pattern, column) + ELIF column > LENGTH atom (s.index).line + THEN column := 0 + FI . + +search in following lines : + next atom (s, atom) ; + IF pattern = "" + THEN column := 1 ; + LEAVE search in following lines + FI ; + REP + search forwards through segment ; + update file position forwards ; + IF found OR s.line no = last search line + THEN LEAVE search in following lines + ELSE next segment (s, atom) + FI + PER . + +search forwards through segment : + INT VAR search index := s.index , + last index := min (s.segment end, s.index+(last search line-s.line no)); + REP + column := pos (atom (search index).line, pattern) ; + IF found OR search index = last index + THEN LEAVE search forwards through segment + FI ; + search index INCR 1 + PER . + +update file position forwards : + disable stop ; + s.line no INCR (search index - s.index) ; + s.index := search index ; + enable stop . + +found : column > 0 . + +ENDPROC down in atoms ; + +TEXT PROC prefix (TEXT CONST pattern) : + + INT VAR invalid char pos := pos (pattern, ""0"", ""31"", 1) ; + SELECT invalid char pos OF + CASE 0 : pattern + CASE 1 : "" + OTHERWISE : subtext (pattern, 1, invalid char pos - 1) + ENDSELECT . + +ENDPROC prefix ; + +PROC search up (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT CONST max lines, INT VAR column) : + + last search line := max (1, s.lineno - max lines) ; + pre:= prefix (pattern); + pattern0 := pattern ** 0; + remember start point ; + up in atoms (s, atom, pre, column); + IF NOT (last search succeeded CAND last pattern in line found) + THEN try again + FI; + last search succeeded := TRUE ; + column := matchpos (0) . + + try again: + WHILE s.lineno > last search line OR column > 1 + REP previous atom (s, atom); + column := LENGTH record ; + up in atoms (s, atom, pre, column); + IF last search succeeded CAND last pattern in line found + THEN LEAVE try again + FI + PER; + column := 1; + last search succeeded := FALSE ; + LEAVE search up. + + remember start point : + INT VAR c:= column, r:= s.lineno;. + + last pattern in line found : + column := 2 ; + WHILE like pattern CAND right of start REP + column := matchpos (0) +1 + PER ; + column DECR 1 ; + like pattern CAND right of start . + + like pattern : + pat := any (column-1) ; + pat CAT any ; + pat CAT pattern0 ; + pat CAT any ; + record LIKE pat . + + right of start : (r > s.lineno COR c >= matchpos(0)) . + record : atom (s.index).line . + +ENDPROC search up ; + +PROC up in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT VAR column) : + + last search succeeded := FALSE ; + search backwards in actual line ; + IF NOT found AND s.line no > last search line + THEN search in preceeding lines + FI ; + IF found + THEN last search succeeded := TRUE + ELSE column := 1 + FI . + +search backwards in actual line : + IF pattern = "" + THEN LEAVE search backwards in actual line + FI ; + INT VAR last pos , new pos := 0 ; + REP + last pos := new pos ; + new pos := pos (atom (s.index).line, pattern, last pos+1) ; + UNTIL new pos = 0 OR new pos > column PER ; + column := last pos . + +search in preceeding lines : + previous atom (s, atom) ; + IF pattern = "" + THEN column := LENGTH atom (s.index).line + 1 ; + last search succeeded := TRUE ; + LEAVE search in preceeding lines + FI ; + REP + search backwards through segment ; + update file position backwards ; + IF found OR s.line no = last search line + THEN LEAVE search in preceeding lines + ELSE previous segment (s, atom) + FI + PER . + +search backwards through segment : + INT VAR search index := s.index , + last index := max (s.segment begin, s.index-(s.line no-last search line)); + REP + new pos := 0 ; + REP + column := new pos ; + new pos := pos (atom (search index).line, pattern, column+1) ; + UNTIL new pos = 0 PER ; + IF found OR search index = last index + THEN LEAVE search backwards through segment + FI ; + search index DECR 1 + PER . + +update file position backwards : + disable stop ; + s.line no DECR (s.index - search index) ; + s.index := search index ; + enable stop . + +found : column > 0 . + +ENDPROC up in atoms ; + +BOOL VAR last search succeeded ; + +BOOL PROC pattern found : + last search succeeded +ENDPROC pattern found ; + + + +PROC delete atom (SEQUENCE VAR used, free, ATOMROW VAR atom) : + + disable stop; + IF used.line no <= used.lines + THEN delete actual atom + ELSE errorstop ("'delete' am Dateiende") + FI . + +delete actual atom : + position behind actual free segment; + split segment (used, atom); + INT VAR actual index := used.index; + cut off tail of actual used segment; + delete segments (used, atom, actual index, actual index, 1); + insert segments (free, atom, actual index, actual index, 1) . + +position behind actual free segment : + IF free.line no <= free.lines + THEN next segment (free, atom) + FI . + +cut off tail of actual used segment : + IF actual index <> used.segment end + THEN used.index INCR 1; + split segment (used, atom); + used.index DECR 1 + FI . + +END PROC delete atom; + + +PROC insert atom (SEQUENCE VAR used, free,INT VAR unused, ATOMROW VAR atom) : + + disable stop; + split segment (used, atom); + IF free.lines > 0 + THEN insert new atom from free sequence + ELIF unused <= file size + THEN insert new atom from unused tail + ELSE errorstop ("FILE-Ueberlauf") + FI . + +insert new atom from free sequence : + get a free segments head; + make this atom to actual segment; + transfer from free to used chain . + +get a free segments head : + IF actual free segment is root segment + THEN previous segment (free, atom) + FI; + position to actual segments head . + +position to actual segments head : + INT VAR actual index := free.segment begin; + free.line no DECR (free.index - actual index); + free.index := actual index . + +make this atom to actual segment : + IF free.segment end > actual index + THEN free.index INCR 1; + split segment (free, atom); + free.index DECR 1 + FI . + +transfer from free to used chain : + delete segments (free, atom, actual index, actual index, 1); + insert segments (used, atom, actual index, actual index, 1); + atom (actual index).line := "" . + +insert new atom from unused tail : + actual index := unused; + atom (actual index).seg := + SEGMENT:(actual index, actual index, actual index); + atom (actual index).line := ""; + insert segments (used, atom, actual index, actual index, 1); + unused INCR 1 . + +actual free segment is root segment : free.segment begin = free root . + +END PROC insert atom; + + +PROC insert next (SEQUENCE VAR used, free, INT VAR unused, ATOMROW VAR atom, + TEXT CONST record) : + + IF used.line no > used.lines + THEN insert atom (used, free, unused, atom) + ELIF actual position before unused nonempty atomrow part + THEN forward and insert atom by simple extension of used atomrow part + ELSE next atom (used, atom); + insert atom (used, free, unused, atom) + FI; + atom (used.index).line := record . + +forward and insert atom by simple extension of used atomrow part : + used.line no INCR 1; + used.lines INCR 1; + used.index INCR 1; + used.segment end INCR 1; + atom (used.segment begin).seg.end INCR 1; + unused INCR 1 . + +actual position before unused nonempty atomrow part : + used.index = unused - 1 AND unused part not empty . + +unused part not empty : unused <= file size . + +END PROC insert next; + + +PROC transfer subsequence (SEQUENCE VAR source, dest, + ATOMROW VAR atom, INT CONST size) : + + IF size > 0 + THEN INT VAR subsequence size := min (size, source.line no); + mark begin of source part; + mark end of source part; + split destination sequence; + transfer part + FI . + +mark begin of source part : + previous atoms (source, atom, subsequence size - 1); + split segment (source, atom); + INT CONST first := source.segment begin . + +mark end of source part : + next atoms (source, atom, subsequence size - 1); + INT CONST last := source.segment begin; + next atom (source, atom); + split segment (source, atom) . + +split destination sequence : + split segment (dest, atom) . + +transfer part : + disable stop; + delete segments (source, atom, first, last, subsequence size); + source.line no DECR subsequence size; + insert segments (dest, atom, first, last, subsequence size); + next atoms (dest, atom, subsequence size - 1) . + +END PROC transfer subsequence; + + + +(********************************************************************) +(***** *****) +(***** FILE handler *****) +(***** *****) +(********************************************************************) + + + +LET file type = 1003 , + file type 16 = 1002 , + + closed = 0, + inp = 1, + outp = 2, + mod = 3, + end = 4, + + max limit = 16000, + super limit = 16001; + + +TYPE TRANSPUTDIRECTION = INT; + + +TRANSPUTDIRECTION PROC input : + TRANSPUTDIRECTION : (inp) +END PROC input; + + +TRANSPUTDIRECTION PROC output : + TRANSPUTDIRECTION : (outp) +END PROC output; + + +TRANSPUTDIRECTION PROC modify : + TRANSPUTDIRECTION : (mod) +END PROC modify; + + +FILE VAR result file; + + +FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, + DATASPACE CONST ds) : + IF type (ds) = file type + THEN result := ds + ELIF type (ds) < 0 + THEN result := ds; type (ds, file type); initialize (result file) + ELSE enable stop; errorstop ("Datenraum hat falschen Typ") + FI; + reset (result file, mode); + result file . + +result : CONCR (result file) . + +END PROC sequential file; + + +FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, TEXT CONST name) : + + IF exists (name) + THEN get dataspace if file + ELIF CONCR (mode) <> inp + THEN get new file space + ELSE errorstop (""""+name+""" gibt es nicht") ; enable stop + FI; + update status if necessary; + reset (result file, mode); + result file . + +get dataspace if file : + IF type (old (name)) = file type 16 + THEN reorganize (name) + FI ; + result := old (name, file type) ; + IF is 170 file + THEN result.col := 1 ; + result.mark line := 0 ; + result.mark col := 0 + FI . + +is 170 file : result.mark col < 0 . + +get new file space : + result := new (name); + IF NOT is error + THEN type (old (name), file type); initialize (result file) + FI . + +update status if necessary : + IF CONCR (mode) <> inp + THEN status (name, ""); headline (result file, name) + FI . + +result : CONCR (result file) . + +END PROC sequential file; + + +PROC reset (FILE VAR f) : + + IF f.mode = end + THEN reset (f, input) + ELSE reset (f, TRANSPUTDIRECTION:(f.mode)) + FI . + +ENDPROC reset ; + +PROC reset (FILE VAR f, TRANSPUTDIRECTION CONST mode) : + + IF f.mode <> mod OR new mode <> mod + THEN f.mode := new mode ; + initialize file index + FI . + +initialize file index : + IF new mode = outp + THEN to line without check (f, f.used.lines); + col := super limit + ELSE to line without check (f, 1); + col := 1 ; + IF new mode = inp AND file is empty + THEN f.mode := end + FI + FI . + +file is empty : f.used.lines = 0 . + +new mode : CONCR (mode) . + +col : CONCR (CONCR (f)).col . + +END PROC reset; + + +PROC input (FILE VAR f) : + + reset (f, input) . + +END PROC input; + + +PROC output (FILE VAR f) : + + reset (f, output) + +END PROC output; + + +PROC modify (FILE VAR f) : + + reset (f, modify) + +END PROC modify; + + +PROC close (FILE VAR f) : + + f.mode := closed . + +END PROC close; + + +PROC check mode (FILE CONST f, INT CONST mode) : + + IF f.mode = mode + THEN LEAVE check mode + ELIF f.mode = closed + THEN errorstop ("Datei zu!") + ELIF f.mode = mod + THEN errorstop ("unzulaessiger Zugriff auf modify-FILE") + ELIF mode = mod + THEN errorstop ("Zugriff nur auf modify-FILE zulaessig") + ELIF f.mode = end + THEN errorstop ("Leseversuch nach Dateiende") + ELIF mode = inp + THEN errorstop ("Leseversuch auf output-FILE") + ELIF mode = outp + THEN errorstop ("Schreibversuch auf input-FILE") + FI . + +END PROC check mode; + + +PROC to line without check (FILE VAR f, INT CONST destination line) : + + INT CONST distance := destination line - f.used.line no; + IF distance > 0 + THEN next atoms (f.used, f.atoms, distance) + ELIF distance < 0 + THEN previous atoms (f.used, f.atoms, - distance) + FI . + +END PROC to line without check; + + +PROC to line (FILE VAR f, INT CONST destination line) : + + check mode (f, mod); + to line without check (f, destination line) + +END PROC to line; + + +PROC to first record (FILE VAR f) : + + to line (f, 1) + +END PROC to first record; + + +PROC to eof (FILE VAR f) : + + to line (f, f.used.lines + 1) . + +END PROC to eof; + + +PROC putline (FILE VAR f, TEXT CONST word) : + + write (f, word); + col := super limit . + +col : CONCR (CONCR (f)).col . + +END PROC putline; + + +PROC delete record (FILE VAR f) : + + check mode (f, mod); + delete atom (f.used, f.free, f.atoms) . + +END PROC delete record; + + +PROC insert record (FILE VAR f) : + + check mode (f, mod); + insert atom (f.used, f.free, f.unused tail, f.atoms) . + +END PROC insert record; + + +PROC down (FILE VAR f) : + + check mode (f, mod); + next atom (f.used, f.atoms) . + +END PROC down ; + +PROC up (FILE VAR f) : + + check mode (f, mod); + previous atom (f.used, f.atoms) . + +END PROC up ; + +PROC down (FILE VAR f, INT CONST n) : + + to line (f, lineno (f) + n) + +ENDPROC down ; + +PROC up (FILE VAR f, INT CONST n) : + + to line (f, lineno (f) - n) + +ENDPROC up ; + + +PROC write record (FILE VAR f, TEXT CONST record) : + + check mode (f, mod); + IF not at eof + THEN f.atoms (f.used.index).line := record + ELSE errorstop ("'write' nach Dateiende") + FI . + +not at eof : f.used.line no <= f.used.lines . + +END PROC write record; + + +PROC read record (FILE CONST f, TEXT VAR record) : + + check mode (f, mod); + record := f.atoms (f.used.index).line . + +END PROC read record; + + +PROC line (FILE VAR f) : + + IF mode = end + THEN errorstop ("Leseversuch nach Dateiende") + ELIF mode = inp + THEN next atom (f.used, f.atoms); col := 1; check eof + ELIF mode = outp + THEN IF col <= max limit + THEN col := super limit + ELSE append empty line + FI + FI . + +append empty line : + insert next (f.used, f.free, f.unused tail, f.atoms, "") . + +col : CONCR (CONCR (f)).col . + +mode : CONCR (CONCR (f)).mode . + +check eof : + IF eof (f) THEN mode := end FI . + +END PROC line; + + +PROC line (FILE VAR f, INT CONST lines) : + + INT VAR i; FOR i FROM 1 UPTO lines REP line (f) PER + +END PROC line; + + +PROC getline (FILE VAR f, TEXT VAR text) : + + check mode (f, inp); + text := subtext (record, f.col); + IF f.used.line no >= f.used.lines + THEN f.mode := end ; + set end of file + ELSE to next line ; + f.col := 1 + FI . + +to next line : + next atom (f.used, f.atoms) . + +set end of file : + f.col := LENGTH record + 1 . + +record : f.atoms (f.used.index).line . + +END PROC getline; + + +BOOL PROC is first record (FILE CONST f) : + + check mode (f, mod); + f.used.line no = 1 . + +END PROC is first record; + + +BOOL PROC eof (FILE CONST f) : + + IF line no < lines THEN FALSE + ELIF line no = lines THEN col > LENGTH record + ELSE TRUE + FI . + +line no : f.used.line no . +lines : f.used.lines . +col : f.col . +record : f.atoms (f.used.index).line . + +END PROC eof; + + +INT PROC line no (FILE CONST f) : + + f.used.line no . + +END PROC line no; + + +PROC line type (FILE VAR f, INT CONST t) : + + f.atoms (f.used.index).type := t . + +ENDPROC line type ; + +INT PROC line type (FILE CONST f) : + + f.atoms (f.used.index).type . + +ENDPROC line type ; + + +PROC put (FILE VAR f, TEXT CONST word) : + + check mode (f, outp); + IF col + LENGTH word > f.limit + THEN append new line + ELSE record CAT word + FI; + record CAT " "; + col := LENGTH record + 1 . + +append new line : + insert next (f.used, f.free, f.unused tail, f.atoms, word) . + +record : f.atoms (f.used.index).line . +col : f.col . + +END PROC put; + + +PROC put (FILE VAR f, INT CONST value) : + + put (f, text (value)) + +END PROC put; + + +PROC put (FILE VAR f, REAL CONST real) : + + put (f, text (real)) + +END PROC put; + + +PROC write (FILE VAR f, TEXT CONST word) : + + check mode (f, outp); + IF col + LENGTH word - 1 > f.limit + THEN append new line + ELSE record CAT word + FI; + col := LENGTH record + 1 . + +append new line : + insert next (f.used, f.free, f.unused tail, f.atoms, word) . + +record : f.atoms (f.used.index).line . +col : f.col . + +END PROC write; + + +PROC get (FILE VAR f, TEXT VAR word, TEXT CONST separator) : + + check mode (f, inp); + skip separators; + IF word found + THEN get word + ELSE try to find word in next line + FI . + +skip separators : + INT CONST separator length := LENGTH separator; + WHILE is separator REP col INCR separator length PER . + +is separator : + subtext (record, col, col + separator length - 1) = separator . + +word found : col <= LENGTH record . + +get word : + INT VAR end of word := pos (record, separator, col) - 1; + IF separator found + THEN get text upto separator + ELSE get rest of record + FI . + +separator found : end of word >= 0 . + +get text upto separator : + word := subtext (record, col, end of word); + col := end of word + separator length + 1; + IF col > LENGTH record THEN line (f) FI . + +get rest of record : + word := subtext (record, col); line (f) . + +record : f.atoms (f.used.index).line . +col : f.col . + +try to find word in next line : + line (f); IF eof (f) THEN word := "" ELSE get (f, word, separator) FI . + +END PROC get; + + +PROC get (FILE VAR f, TEXT VAR word, INT CONST max length) : + + check mode (f, inp); + IF word is only a part of record + THEN get text of certain length + ELSE get rest of record + FI . + +word is only a part of record : + col <= LENGTH record - max length . + +get text of certain length : + word := text (record, max length, col); + col INCR max length . + +get rest of record : + word := subtext (record, col); line (f) . + +record : f.atoms (f.used.index).line . +col : f.col . + +END PROC get; + + +PROC get (FILE VAR f, TEXT VAR word) : + + get (f, word, " ") + +END PROC get; + + +TEXT VAR number word; + + +PROC get (FILE VAR f, INT VAR number) : + + get (f, number word); + number := int (number word) + +END PROC get; + + +PROC get (FILE VAR f, REAL VAR number) : + + get (f, number word); + number := real (number word) + +END PROC get; + + +TEXT VAR split record ; +INT VAR indentation ; + +PROC split line (FILE VAR f, INT CONST split col) : + + split line (f, split col, TRUE) + +ENDPROC split line ; + +PROC split line (FILE VAR f, INT CONST split col, BOOL CONST note indentation ) : + + IF note indentation + THEN get indentation + ELSE indentation := 0 + FI ; + get split record ; + insert split record and indentation ; + cut off old record . + +get indentation : + indentation := pos (actual record,""33"",""254"",1) - 1 ; + IF indentation < 0 OR indentation >= split col + THEN indentation := split col - 1 + FI . + +get split record : + split record := subtext (actual record, split col, max limit) . + +insert split record and indentation : + down (f) ; + insert record (f) ; + INT VAR i ; + FOR i FROM 1 UPTO indentation REP + actual record CAT " " + PER ; + actual record CAT split record ; + up (f) . + +cut off old record : + actual record := subtext (actual record, 1, split col-1) . + +actual record : f.atoms (f.used.index).line . + +ENDPROC split line ; + +PROC concatenate line (FILE VAR f, BOOL CONST delete blanks) : + + down (f) ; + split record := actual record ; + IF delete blanks + THEN delete leading blanks + FI ; + delete record (f) ; + up (f) ; + actual record CAT split record . + +delete leading blanks : + INT CONST non blank col := pos (split record, ""33"", ""254"", 1) ; + IF non blank col > 0 + THEN split record := subtext (split record, non blank col) + FI . + +actual record : f.atoms (f.used.index).line . + +ENDPROC concatenate line ; + +PROC concatenate line (FILE VAR f) : + concatenate line (f, TRUE) +ENDPROC concatenate line ; + +PROC reorganize : + + reorganize (last param) + +END PROC reorganize; + + +TEXT VAR file record ; + +PROC reorganize (TEXT CONST file name) : + + enable stop ; + FILE VAR input file, output file; + DATASPACE VAR scratch space; + INT CONST type of dataspace := type (old (file name)) ; + INT VAR counter; + + last param (file name); + IF type of dataspace = file type + THEN reorganize new to new + ELIF type of dataspace = file type 16 + THEN reorganize old to new + ELSE errorstop ("Datenraum hat falschen Typ") + FI; + replace file space by scratch space . + +reorganize new to new : + input file := sequential file (input, file name); + disable stop ; + scratch space := nilspace ; + output file := sequential file (output, scratch space); + copy attributes (input file, output file) ; + + FOR counter FROM 1 UPTO 9999 + WHILE NOT eof (input file) REP + cout (counter); + getline (input file, file record); + putline (output file, file record); + check for interrupt + PER . + +reorganize old to new : + LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT record); + LET OLDFILE = BOUND ROW 4075 OLDRECORD; + LET dateianker = 2, freianker = 1; + INT VAR index := dateianker; + + OLDFILE VAR old file := old (file name); + disable stop; + scratch space := nilspace; + output file := sequential file (output, scratch space); + get old attributes ; + + say ("Datei wird in 1.7-Format gewandelt: ") ; + + FOR counter FROM 1 UPTO 9999 + WHILE NOT end of old file REP + cout (counter); + index := next record; + file record := record of old file ; + IF pos (file record, ""128"", ""250"", 1) > 0 + THEN change special chars + FI ; + putline (output file, file record); + check for interrupt + PER . + +get old attributes : + get old headline ; + get old limit and tabs . + +get old headline : + headline (output file, old file (dateianker).record) . + +get old limit and tabs : + file record := old file (freianker).record ; + max line length (output file, int (subtext (file record, 11, 15))) ; + put tabs (output file, subtext (file record, 16)) . + +change special chars : + change all (file record, ""193"", ""214"") (* Ae *) ; + change all (file record, ""207"", ""215"") (* Oe *) ; + change all (file record, ""213"", ""216"") (* Ue *) ; + change all (file record, ""225"", ""217"") (* ae *) ; + change all (file record, ""239"", ""218"") (* oe *) ; + change all (file record, ""245"", ""219"") (* ue *) ; + change all (file record, ""235"", ""220"") (* k *) ; + change all (file record, ""173"", ""221"") (* - *) ; + change all (file record, ""163"", ""222"") (* fis *) ; + change all (file record, ""160"", ""223"") (* blank *) ; + change all (file record, ""194"", ""251"") (* eszet *) . + +end of old file : next record = dateianker . + +next record : old file (index).succ . + +record of old file : old file (index).record . + +check for interrupt : + INT VAR size, used ; + storage (size, used) ; + IF used > size + THEN errorstop ("Speicherengpass") + FI ; + IF is error + THEN forget (scratch space) ; LEAVE reorganize + FI . + +replace file space by scratch space : + headline (output file, file name); + forget (file name, quiet) ; + type (scratch space, file type); + copy (scratch space, file name); + forget (scratch space) . + +END PROC reorganize; + + +PROC set range (FILE VAR f, INT CONST start line, start col, + FRANGE VAR old range) : + + check mode (f, mod); + IF valid restriction parameters + THEN prepare last line ; + prepare first line ; + save old range ; + set new range + ELSE errorstop ("FRANGE ungueltig") + FI . + +valid restriction parameters : + start line > 0 AND start col > 0 AND start before or at actual point . + +start before or at actual point : + start line < line no (f) OR + start line = line no (f) AND start col <= col (f) . + +prepare last line : + INT VAR last line ; + IF col (f) > 1 + THEN split line (f, col(f), FALSE) + FI . + +prepare first line : + IF start col > 1 + THEN split start line ; + FI . + +split start line : + INT VAR old line no := line no (f) ; + to line (f, start line) ; + split line (f, start col, FALSE) ; + to line (f, old line no + 1) . + +save old range : + old range.pre := f.prefix lines ; + old range.post:= f.postfix lines . + +set new range : + get pre lines ; + get post lines ; + disable stop ; + f.prefix lines INCR pre lines ; + f.postfix lines INCR post lines ; + f.used.lines DECR (post lines + pre lines) ; + f.used.line no DECR pre lines . + +get pre lines : + INT VAR pre lines ; + IF start col = 1 + THEN old range.pre was split := FALSE ; + pre lines := start line - 1 + ELSE old range.pre was split := TRUE ; + pre lines := start line + FI . + +get post lines : + INT VAR post lines ; + IF col (f) = 1 + THEN old range.post was split := FALSE ; + post lines := lines (f) - line no (f) + 1 + ELSE old range.post was split := TRUE ; + post lines := lines (f) - line no (f) + FI . + +END PROC set range; + + +PROC set range (FILE VAR f, FRANGE VAR new range) : + + check mode (f, mod); + INT CONST pre add := prefix - new range.pre, + post add := postfix - new range.post; + IF pre add < 0 OR post add < 0 + THEN errorstop ("FRANGE ungueltig") + ELSE set new range; + undo splitting if necessary ; + make range var invalid + FI . + +set new range : + disable stop; + prefix DECR pre add; + postfix DECR post add; + used.line no INCR pre add; + used.lines INCR (pre add + post add) . + +undo splitting if necessary : + IF new range.pre was split + THEN concatenate first line + FI ; + IF new range.post was split + THEN concatenate last line + FI . + +concatenate first line : + INT VAR old line := line no (f) ; + to line (f, pre add) ; + concatenate line (f, FALSE) ; + to line (f, old line - 1) . + +concatenate last line : + old line := line no (f) ; + to line (f, lines (f) - post add) ; + concatenate line (f, FALSE) ; + to line (f, old line) . + +make range var invalid : + new range.pre := maxint . + +used : f.used . +prefix : f.prefix lines . +postfix : f.postfix lines . + +END PROC set range; + +PROC reset range (FILE VAR f) : + + FRANGE VAR complete ; + complete.pre := 0 ; + complete.post:= 0 ; + complete.pre was split := FALSE ; + complete.post was split:= FALSE ; + set range (f, complete) + +ENDPROC reset range ; + +PROC remove (FILE VAR f, INT CONST size) : + + check mode (f, mod); + transfer subsequence (f.used, f.scratch, f.atoms, size) . + +END PROC remove; + + +PROC clear removed (FILE VAR f) : + + check mode (f, mod); + transfer subsequence (f.scratch, f.free, f.atoms, f.scratch.lines) . + +END PROC clear removed; + + +PROC reinsert (FILE VAR f) : + + check mode (f, mod); + transfer subsequence (f.scratch, f.used, f.atoms, f.scratch.lines) . + +END PROC reinsert; + + +PROC copy attributes (FILE CONST source file, FILE VAR dest file) : + + dest.limit := source.limit ; + dest.atoms (free root).line := source.atoms (free root).line ; + dest.atoms (scratch root).line := source.atoms (scratch root).line ; + dest.edit info := source.edit info . + +dest : CONCR (CONCR (dest file)) . +source : CONCR (CONCR (source file)) . + +ENDPROC copy attributes ; + + +INT PROC max line length (FILE CONST f) : + + f.limit . + +END PROC max line length; + + +PROC max line length (FILE VAR f, INT CONST new limit) : + + IF new limit > 0 AND new limit <= max limit + THEN f.limit := new limit + FI . + +END PROC max line length; + + +TEXT PROC headline (FILE CONST f) : + + f.atoms (free root).line . + +END PROC headline; + + +PROC headline (FILE VAR f, TEXT CONST head) : + + f.atoms (free root).line := head . + +END PROC headline; + + +PROC get tabs (FILE CONST f, TEXT VAR tabs) : + + tabs := f.atoms (scratch root).line . + +END PROC get tabs; + + +PROC put tabs (FILE VAR f, TEXT CONST tabs) : + + f.atoms (scratch root).line := tabs . + +END PROC put tabs; + + +INT PROC edit info (FILE CONST f) : + + f.edit info . + +END PROC edit info; + + +PROC edit info (FILE VAR f, INT CONST info) : + + f.edit info := info . + +END PROC edit info; + + +INT PROC lines (FILE CONST f) : + + f.used.lines . + +END PROC lines; + + +INT PROC removed lines (FILE CONST f) : + + f.scratch.lines . + +END PROC removed lines; + + +INT PROC segments (FILE CONST f) : + + segs(f.used,f.atoms) + segs(f.scratch,f.atoms) + segs(f.free,f.atoms) - 2 . + +ENDPROC segments ; + + +INT PROC col (FILE CONST f) : + + f.col + +ENDPROC col ; + +PROC col (FILE VAR f, INT CONST new column) : + + IF new column > 0 + THEN f.col := new column + FI + +ENDPROC col ; + +TEXT PROC word (FILE CONST f) : + + word (f, " ") + +ENDPROC word ; + +TEXT PROC word (FILE CONST f, TEXT CONST delimiter) : + + INT VAR del pos := pos (f, delimiter, col (f)) ; + IF del pos = 0 + THEN del pos := len (f) + 1 + FI ; + subtext (f, col (f), del pos - 1) + +ENDPROC word ; + +TEXT PROC word (FILE CONST f, INT CONST max length) : + + subtext (f, col (f), col (f) + max length - 1) + +ENDPROC word ; + +BOOL PROC at (FILE CONST f, TEXT CONST word) : + + pat := any (column-1) ; + pat CAT word ; + pat CAT any ; + record LIKE pat . + +column : f.col . +record : f.atoms (f.used.index).line . + +ENDPROC at ; + + +PROC exec (PROC (TEXT VAR, TEXT CONST) proc, FILE VAR f, TEXT CONST t) : + + proc (record, t) . + +record : f.atoms (f.used.index).line . + +END PROC exec; + + +PROC exec (PROC (TEXT VAR, INT CONST) proc, FILE VAR f, INT CONST i) : + + proc (record, i) . + +record : f.atoms (f.used.index).line . + +END PROC exec; + +INT PROC pos (FILE CONST f, TEXT CONST pattern, INT CONST i) : + + pos (record, pattern, i) . + +record : f.atoms (f.used.index).line . + +END PROC pos ; + +PROC down (FILE VAR f, TEXT CONST pattern) : + + down (f, pattern, file size) + +ENDPROC down ; + +PROC down (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col + 1 ; + search down (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC down ; + +PROC downety (FILE VAR f, TEXT CONST pattern) : + + downety (f, pattern, file size) + +ENDPROC downety ; + +PROC downety (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col ; + search down (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC downety ; + +PROC up (FILE VAR f, TEXT CONST pattern) : + + up (f, pattern, file size) + +ENDPROC up ; + +PROC up (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col - 1 ; + search up (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC up ; + +PROC uppety (FILE VAR f, TEXT CONST pattern) : + + uppety (f, pattern, file size) + +ENDPROC uppety ; + +PROC uppety (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col ; + search up (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC uppety ; + + +INT PROC len (FILE CONST f) : + + length (record) . + +record : f.atoms (f.used.index).line . + +ENDPROC len ; + +TEXT PROC subtext (FILE CONST f, INT CONST from, to) : + + subtext (record, from, to) . + +record : f.atoms (f.used.index).line . + +ENDPROC subtext ; + +PROC change (FILE VAR f, INT CONST from, to, TEXT CONST new) : + + check mode (f, mod) ; + change (record, from, to, new) . + +record : f.atoms (f.used.index).line . + +ENDPROC change ; + + +BOOL PROC mark (FILE CONST f) : + + f.mark line > 0 + +ENDPROC mark ; + +PROC mark (FILE VAR f, INT CONST line no, col) : + + IF line no > 0 + THEN f.mark line := line no + f.prefix lines ; + f.mark col := col + ELSE f.mark line := 0 ; + f.mark col := 0 + FI + +ENDPROC mark ; + +INT PROC mark line no (FILE CONST f) : + + IF f.mark line = 0 + THEN 0 + ELSE max (1, f.mark line - f.prefix lines) + FI + +ENDPROC mark line no ; + +INT PROC mark col (FILE CONST f) : + + IF f.mark line = 0 + THEN 0 + ELIF f.mark line <= f.prefix lines + THEN 1 + ELSE f.mark col + FI + +ENDPROC mark col ; + +PROC set marked range (FILE VAR f, FRANGE VAR old range) : + + IF mark (f) + THEN set range (f, mark line no (f), mark col (f), old range) + ELSE old range := previous range of file + FI . + +previous range of file : + FRANGE : (f.prefix lines, f.postfix lines, FALSE, FALSE) . + +ENDPROC set marked range ; + + +(*****************************************************************) + + (* Autor: P.Heyderhoff *) + (* Stand: 11.10.83 *) + +BOUND LIST VAR datei; +INT VAR sortierstelle, sortanker; +BOOL VAR ascii sort; +TEXT VAR median, tausch , links, rechts; + +PROC sort (TEXT CONST dateiname) : + sort (dateiname, 1) +END PROC sort; + +PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) : + ascii sort := TRUE ; + sortierstelle := sortieranfang; sortiere (dateiname) +END PROC sort; + +PROC lex sort (TEXT CONST dateiname) : + lex sort (dateiname, 1) +ENDPROC lex sort ; + +PROC lex sort (TEXT CONST dateiname, INT CONST sortieranfang) : + ascii sort := FALSE ; + sortierstelle := sortieranfang; sortiere (dateiname) +ENDPROC lex sort ; + +PROC sortiere (TEXT CONST dateiname) : + + reorganize file if necessary ; + sort file . + +reorganize file if necessary : + FILE VAR f := sequential file (modify, dateiname) ; + IF segments (f) > 1 + THEN reorganize (dateiname) + FI . + +sort file : + f := sequential file (modify, dateiname) ; + INT CONST sortende := lines (f) + 3 ; + sortanker := 1 + 3 ; + datei := old (dateiname) ; + quicksort(sortanker, sortende) . + +END PROC sortiere; + +PROC quicksort ( INT CONST anfang, ende ) : + IF anfang < ende + THEN INT VAR p,q; + spalte (anfang, ende, p, q); + quicksort (anfang, q); + quicksort (p, ende) FI +END PROC quicksort; + +PROC spalte (INT CONST anfang, ende, INT VAR p, q): + fange an der seite an und waehle den median; + ruecke p und q so dicht wie moeglich zusammen; + hole ggf median in die mitte . + + fange an der seite an und waehle den median : + p := anfang; q := ende ; + INT CONST m :: (p + q) DIV 2 ; + median := subtext(datei m, sortierstelle) . + + ruecke p und q so dicht wie moeglich zusammen : + REP schiebe p und q so weit wie moeglich auf bzw ab; + IF p < q THEN vertausche die beiden FI + UNTIL p > q END REP . + + vertausche die beiden : + tausch := datei p; datei p := datei q; datei q := tausch; + p INCR 1; q DECR 1 . + + schiebe p und q so weit wie moeglich auf bzw ab : + WHILE p kann groesser werden REP p INCR 1 END REP; + WHILE q kann kleiner werden REP q DECR 1 END REP . + + p kann groesser werden : + IF p <= ende + THEN links := subtext (datei p, sortierstelle) ; + IF ascii sort + THEN median >= links + ELSE median LEXGREATEREQUAL links + FI + ELSE FALSE + FI . + + q kann kleiner werden : + IF q >= anfang + THEN rechts := subtext(datei q, sortierstelle) ; + IF ascii sort + THEN rechts >= median + ELSE rechts LEXGREATEREQUAL median + FI + ELSE FALSE + FI . + + hole ggf median in die mitte : + IF m < q THEN vertausche m und q + ELIF m > p THEN vertausche m und p FI . + + vertausche m und q : + tausch := datei m; datei m := datei q; datei q := tausch; q DECR 1 . + + vertausche m und p : + tausch := datei m; datei m := datei p; datei p := tausch; p INCR 1 . + + datei m : datei.atoms (m).line . + datei p : datei.atoms (p).line . + datei q : datei.atoms (q).line . + +END PROC spalte; + +END PACKET file handling; + diff --git a/system/base/1.7.5/src/functions b/system/base/1.7.5/src/functions new file mode 100644 index 0000000..9f338ff --- /dev/null +++ b/system/base/1.7.5/src/functions @@ -0,0 +1,760 @@ +PACKET editor functions DEFINES (* FUNCTIONS - 052 *) + (**************) (* 17.07.85 -bk- *) + (* 10.09.85 -ws- *) + edit, (* 25.04.86 -sh- *) + show, (* 27.05.86 -wk- *) + U, + D, + T, + up, + down, + downety, + uppety, + to line, + PUT, + GET, + P, + G, + limit, + len, + eof, + C, + change to, + CA, + change all, + lines, + line no, + col, + mark, + at, + word, + std kommando interpreter, + note, + note line, + note edit, + anything noted, + note file: + + +LET marker = "^", + ersatzmarker = "'", + schritt = 50, + file size = 4072, + write acc = TRUE, + read acc = FALSE; + +LET bold = 2, + integer = 3, + string = 4, + end of file = 7; + +LET std res = "eqvw19dpgn"9""; + +FILE VAR edfile; +BOOL VAR from scratchfile :: FALSE; +TEXT VAR kommandotext, tabulator, zeile; + + +PROC std kommando interpreter (TEXT CONST taste) : + enable stop ; + edfile := editfile; + set busy indicator; + SELECT pos (std res, taste) OF + CASE 1 (*e*) : edit + CASE 2 (*q*) : quit + CASE 3 (*v*) : quit last + CASE 4 (*w*) : open editor (next editor) + CASE 5 (*1*) : toline (1); col (1) + CASE 6 (*9*) : toline (lines); col (len+1) + CASE 7 (*d*) : d case + CASE 8 (*p*) : p case + CASE 9 (*g*) : g case + CASE 10(*n*) : note edit + CASE 11(*tab*): change tabs + OTHERWISE : echtes kommando analysieren + END SELECT . + +d case : + IF mark + THEN PUT ""; mark (FALSE); from scratchfile := TRUE + ELSE textzeile auf taste legen + FI . + +p case : + IF mark (*sh*) + THEN IF write permission + THEN PUT ""; push(""27""12""); from scratchfile := TRUE + ELSE out (""7"") + FI + ELSE textzeile auf taste legen + FI . + +g case : + IF write permission (*sh*) + THEN IF from scratchfile + THEN GET "" + ELSE IF is editget + THEN push (lernsequenz auf taste ("g")); nichts neu + FI + FI + ELSE out (""7"") + FI . + +textzeile auf taste legen : + read record (edfile, zeile); + zeile := subtext (zeile, col); + lernsequenz auf taste legen ("g", zeile); + from scratchfile := FALSE; zeile neu . + +next editor : + (aktueller editor MOD groesster editor) + 1 . + +change tabs : + get tabs (edfile, tabulator) ; + IF pos (tabulator, marker) <> 0 + THEN change all (tabulator, marker, ersatzmarker) + ELSE change all (tabulator, ersatzmarker, marker) + FI ; + put tabs (edfile, tabulator) ; + ueberschrift neu . + +echtes kommando analysieren : + kommandotext := kommando auf taste (taste); + IF kommandotext = "" + THEN nichts neu; LEAVE std kommando interpreter + FI ; + scan (kommandotext); + TEXT VAR s1; INT VAR t1; next symbol (s1, t1); + TEXT VAR s2; INT VAR t2; next symbol (s2, t2); + IF t1 = integer AND t2 = end of file THEN toline (int (s1)) + ELIF t1 = string AND t2 = end of file THEN down (s1) + ELIF perhaps simple up or down THEN + ELIF perhaps simple changeto THEN + ELSE do (kommandotext) + FI . + +perhaps simple up or down : + IF t1 = bold + THEN TEXT VAR s3; INT VAR t3; next symbol (s3, t3); + IF t3 <> end of file THEN FALSE + ELIF s1 = "U" THEN perhaps simple up + ELIF s1 = "D" THEN perhaps simple down + ELSE FALSE + FI + ELSE FALSE + FI . + +perhaps simple up : + IF t2 = string THEN up (s2); TRUE + ELIF t2 = integer THEN up (int (s2)); TRUE + ELSE FALSE + FI . + +perhaps simple down : + IF t2 = string THEN down (s2); TRUE + ELIF t2 = integer THEN down (int (s2)); TRUE + ELSE FALSE + FI . + +perhaps simple changeto : + IF t1 = string AND s2 = "C" AND t3 is string AND t4 is eof + THEN s1 C s3; TRUE + ELSE FALSE + FI . + +t3 is string : + next symbol (s3, t3); + t3 = string . + +t4 is eof : + TEXT VAR s4; INT VAR t4; + next symbol (s4, t4); + t4 = end of file . +END PROC std kommando interpreter; + + +PROC edit (FILE VAR f) : + enable stop; + IF aktueller editor > 0 (*wk*) + THEN ueberschrift neu + FI ; + open editor (f, write acc); + edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter) +END PROC edit; + + +PROC edit (FILE VAR f, INT CONST x, y, x size, y size) : + enable stop; + open editor (groesster editor + 1, f, write acc, x, y, x size, y size); + edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter) +END PROC edit; + + +PROC edit (FILE VAR f, TEXT CONST res, PROC (TEXT CONST) kdo interpreter) : + enable stop; + open editor (f, write acc); + edit (groesster editor, res, PROC(TEXT CONST) kdo interpreter) +END PROC edit; + + +PROC edit : + IF aktueller editor > 0 + THEN dateiname einlesen; + edit (dateiname) + ELSE edit (last param) + FI . + +dateiname einlesen : + INT VAR x, y; get editcursor (x, y); + IF x < x size - 17 (*sh*) + THEN cursor (x, y); + out (""15"Dateiname:"14""); + (x size-14-x) TIMESOUT " "; + (x size-14-x) TIMESOUT ""8""; + TEXT VAR dateiname := std; + editget (dateiname); + trailing blanks entfernen; + quotes entfernen + ELSE errorstop ("Fenster zu klein") + FI . + +trailing blanks entfernen: + INT VAR i := LENGTH dateiname; + WHILE (dateiname SUB i) = " " REP i DECR 1 PER; + dateiname := subtext (dateiname, 1, i) . + +quotes entfernen : + IF (dateiname SUB 1) = """" AND (dateiname SUB LENGTH dateiname) = """" + THEN dateiname := subtext (dateiname, 2, LENGTH dateiname - 1) + FI . +END PROC edit; + + +PROC edit (TEXT CONST filename) : + IF filename <> "" + THEN edit named file + ELSE errorstop ("Name ungueltig") + FI . + +edit named file : + last param (filename); + IF exists (filename) COR yes ("""" + filename + """ neu einrichten") + THEN IF aktueller editor > 0 THEN ueberschrift neu FI; (*sh*) + FILE VAR f := sequential file (modify, filename); + headline (f, filename); edit (f); last param (filename) + ELSE errorstop ("") + FI . +END PROC edit; + + +PROC edit (TEXT CONST filename, INT CONST x, y, x size, y size) : + last param (filename); + IF exists (filename) COR yes ("""" + filename + """ neu einrichten") + THEN FILE VAR f := sequential file (modify, filename); + headline (f, filename); edit (f, x, y, x size, y size); + last param (filename) + ELSE errorstop ("") + FI +END PROC edit; + + +PROC edit (INT CONST i) : + edit (i, std res, PROC (TEXT CONST) std kommando interpreter) +END PROC edit; + + +PROC show (FILE VAR f) : + enable stop; + open editor (f, read acc); + edit(groesster editor, std res, PROC(TEXT CONST) std kommando interpreter); +END PROC show; + + +PROC show (TEXT CONST filename) : (*sh*) + last param (filename); + IF exists (filename) + THEN FILE VAR f := sequential file (modify, filename); + show (f); last param (filename) + ELSE errorstop ("""" + filename + """ gibt es nicht") + FI +END PROC show; + + +PROC show : + show (last param) +END PROC show; + + +DATASPACE VAR local space; +INT VAR zeilenoffset; +TEXT VAR kopierzeile; + + +OP PUT (TEXT CONST filename) : + nichts neu; + IF mark + THEN markierten bereich in datei schreiben + FI . + +markierten bereich in datei schreiben : + disable stop; + zieldatei vorbereiten; + quelldatei oeffnen; + IF noch genuegend platz in der zieldatei (*sh*) + THEN zeilenweise kopieren + ELSE errorstop ("FILE-Ueberlauf") + FI ; + quelldatei schliessen; + zieldatei schliessen; + set busy indicator . + +zieldatei vorbereiten : + FRANGE VAR ganze zieldatei; + IF exists (filename) THEN forget (filename); ueberschrift neu FI; + FILE VAR destination; + IF filename = "" + THEN forget (local space); local space := nilspace; + destination := sequential file (output, local space) + ELSE destination := sequential file (modify, filename) ; + INT CONST groesse der zieldatei := lines (destination); (*sh*) + set marked range (destination, ganze zieldatei) ; + output (destination) + FI . + +quelldatei oeffnen : + zeilenoffset := mark line no (edfile) - 1; + INT CONST old line := line no, old col := col; + FRANGE VAR ganze datei; + set range (edfile, mark lineno (edfile), mark col (edfile), ganze datei); + input (edfile) . + +noch genuegend platz in der zieldatei : + lines + groesse der zieldatei < file size . + +zeilenweise kopieren : + enable stop; + satznr neu; + INT VAR zeile; + FOR zeile FROM 1 UPTO lines (edfile) REP + getline (edfile, kopierzeile); + putline (destination, kopierzeile); + satznr zeigen + PER . + +quelldatei schliessen : + modify (edfile); + set range (edfile, ganze datei); + to line (old line); + col (old col) . + +zieldatei schliessen : + IF filename <> "" + THEN INT CONST last line written := line no (destination) ; + modify (destination) ; + to line (destination, last line written) ; + col (destination, len (destination) + 1) ; + bild neu (destination) ; + set range (destination, ganze zieldatei) + FI . +END OP PUT; + + +OP P (TEXT CONST filename) : + PUT filename +END OP P ; + + +OP GET (TEXT CONST filename) : (*sh*) + IF NOT write permission + THEN errorstop ("Schreibversuch auf 'show'-Datei") + FI ; + quelldatei oeffnen; + IF nicht mehr genuegend platz im editfile + THEN quelldatei schliessen; errorstop ("FILE-Ueberlauf") + FI ; + disable stop; + zieldatei oeffnen; + zeilenweise kopieren ; + zieldatei schliessen; + quelldatei schliessen; + set busy indicator . + +quelldatei oeffnen : + FILE VAR source; + FRANGE VAR ganze quelldatei; + IF filename = "" + THEN source := sequential file (input, local space) + ELSE IF NOT exists (filename) + THEN errorstop ("""" + filename + """ gibt es nicht") + FI ; + source := sequential file (modify, filename); + INT CONST old line := line no (source), + old col := col (source); + set marked range (source, ganze quelldatei); + input (source) + FI . + +nicht mehr genuegend platz im editfile : + lines (source) + lines >= file size . + +zeilenweise kopieren : + enable stop; + satznr neu; + INT VAR zeile; + FOR zeile FROM 1 UPTO lines (source) REP + getline (source, kopierzeile); + putline (edfile, kopierzeile); + satznr zeigen + PER . + +zieldatei oeffnen : + zeilenoffset := line no - 1; + leere datei in editfile einschachteln; + output (edfile) . + +leere datei in editfile einschachteln : + INT CONST range start col := col; + FRANGE VAR ganze datei; + set range (edfile, line no, col, ganze datei); + IF lines = 1 THEN delete record (edfile) FI . + +quelldatei schliessen : + IF filename <> "" + THEN modify (source); + set range (source, ganze quelldatei); + to line (source, old line); + col (source, old col) + FI . + +zieldatei schliessen : + modify (edfile); + to line (lines); + col (range start col); + set range (edfile, ganze datei); + abschnitt neu (zeilenoffset + 1, lines) . +END OP GET; + + +OP G (TEXT CONST filename) : + GET filename +END OP G; + + +INT PROC len : + len (edfile) +END PROC len; + + +PROC col (INT CONST stelle) : + nichts neu; col (edfile, stelle) +END PROC col; + + +INT PROC col : + col (edfile) +END PROC col; + + +PROC limit (INT CONST limit) : + nichts neu; max line length (edfile, limit) +END PROC limit; + + +INT PROC limit : + max line length (edfile) +END PROC limit; + + +INT PROC lines : + lines (edfile) +END PROC lines; + + +INT PROC line no : + line no (edfile) +END PROC line no; + + +PROC to line (INT CONST satz nr) : + satznr neu; + edfile := editfile; + IF satz nr > lines + THEN toline (edfile, lines); col (len + 1) + ELSE to line (edfile, satz nr) + FI +END PROC to line; + + +OP T (INT CONST satz nr) : + to line (satz nr) +END OP T; + + +PROC down (INT CONST anz) : + nichts neu; down (edfile, anz) +END PROC down; + + +OP D (INT CONST anz) : + down (anz) +END OP D; + + +PROC up (INT CONST anz) : + nichts neu; up (edfile, anz) +END PROC up; + + +OP U (INT CONST anz) : + up (anz) +END OP U; + + +PROC down (TEXT CONST muster) : + nichts neu; + REP + down (muster, schritt - line no MOD schritt); + IF pattern found + THEN LEAVE down + ELSE satznr zeigen + FI + UNTIL eof PER +END PROC down; + + +OP D (TEXT CONST muster) : + down (muster) +END OP D; + + +PROC down (TEXT CONST muster, INT CONST anz) : + nichts neu; down (edfile, muster, anz) +END PROC down; + + +PROC up (TEXT CONST muster) : + nichts neu; + REP + up (muster, (line no - 1) MOD schritt + 1); + IF pattern found + THEN LEAVE up + ELSE satznr zeigen + FI + UNTIL line no = 1 PER +END PROC up; + + +OP U (TEXT CONST muster) : + up (muster) +END OP U; + + +PROC up (TEXT CONST muster, INT CONST anz) : + nichts neu; up (edfile, muster, anz) +END PROC up; + + +PROC downety (TEXT CONST muster) : + nichts neu; + IF NOT at (muster) + THEN down (muster) + FI +END PROC downety; + + +PROC downety (TEXT CONST muster, INT CONST anz) : + nichts neu; downety (edfile, muster, anz) +END PROC downety; + + +PROC uppety (TEXT CONST muster) : + nichts neu; + IF NOT at (muster) + THEN up (muster) + FI +END PROC uppety; + + +PROC uppety (TEXT CONST muster, INT CONST anz) : + nichts neu; uppety (edfile, muster, anz) +END PROC uppety; + + +OP C (TEXT CONST old, new) : + change to (old, new) +END OP C; + +OP C (TEXT CONST replacement) : + IF NOT write permission (*sh*) + THEN errorstop ("Schreibversuch auf 'show'-Datei") + FI ; + IF at (edfile, match(0)) + THEN zeile neu; change (edfile, matchpos(0), matchend(0), replacement) + FI +END OP C; + +PROC change to (TEXT CONST old, new) : + IF NOT write permission (*sh*) + THEN errorstop ("Schreibversuch auf 'show'-Datei") + FI ; + nichts neu; + REP + downety (old, schritt - line no MOD schritt); + IF pattern found + THEN change (edfile, matchpos(0), matchend(0), new); + col (col + LENGTH new); zeile neu; + LEAVE changeto + ELSE satznr zeigen + FI + UNTIL eof PER +END PROC change to; + + +OP CA (TEXT CONST old, new) : + change all (old, new) +END OP CA; + + +PROC change all (TEXT CONST old, new) : + WHILE NOT eof REP old C new PER +END PROC change all; + + +BOOL PROC eof : + eof (edfile) +END PROC eof; + + +BOOL PROC mark : + mark (edfile) +END PROC mark; + + +PROC mark (BOOL CONST mark on) : + nichts neu; + IF mark on + THEN mark (edfile, line no, col) + ELSE mark (edfile, 0, 0) + FI +END PROC mark; + + +BOOL PROC at (TEXT CONST pattern) : + at (edfile, pattern) +END PROC at; + +TEXT PROC word : + word (edfile) +END PROC word; + + +TEXT PROC word (TEXT CONST sep) : + word (edfile, sep) +END PROC word; + + +TEXT PROC word (INT CONST len) : + word (edfile, len) +END PROC word; + + +LET no access = 0, + edit access = 1, + output access = 2; + +INT VAR last note file mode; +FILE VAR notebook; +INITFLAG VAR this packet := FALSE; +DATASPACE VAR note ds; + + +PROC note (TEXT CONST text) : + access note file (output access); + write (notebook, text) +END PROC note; + + +PROC note (INT CONST number) : + access note file (output access); + put (notebook, number) +END PROC note; + + +PROC note line : + access note file (output access); + line (notebook) +END PROC note line; + + +BOOL PROC anything noted : + access note file (no access); + last note file mode = output access +END PROC anything noted; + + +FILE PROC note file : + access note file (output access); + notebook +END PROC note file; + + +PROC note edit (FILE VAR context) : (*sh*) + access note file (edit access); + make notebook erasable; + IF aktueller editor = 0 + THEN open editor (1, context, write acc, 1, 1, x size - 1, y size) + FI ; + get window size; + IF window large enough + THEN include note editor; + edit (aktueller editor-1, aktueller editor, aktueller editor-1, + std res, PROC (TEXT CONST) std kommando interpreter) + FI . + +get window size : + INT VAR x, y, windows x size, windows y size; + get window (x, y, windows x size, windows y size) . + +window large enough : + windows y size > 4 . + +include note editor : + open editor (aktueller editor + 1, notebook, write acc, + x, y + (windows y size + 1) DIV 2, + windows x size, windows y size DIV 2) . + +make notebook erasable : + last note file mode := edit access . +END PROC note edit; + + +PROC note edit : + access note file (edit access); + make notebook erasable; + edit (notebook) . + +make notebook erasable : + last note file mode := edit access . +END PROC note edit; + + +PROC access note file (INT CONST new mode) : + disable stop; + initialize note ds if necessary; + IF last note file mode < new mode + THEN forget (note ds); + note ds := nilspace; + notebook := sequential file (output, note ds); + headline (notebook, "notebook"); + last note file mode := new mode + FI . + +initialize note ds if necessary : + IF NOT initialized (this packet) + THEN note ds := nilspace; + last note file mode := no access + FI . +END PROC access note file; + +END PACKET editor functions; + diff --git a/system/base/1.7.5/src/init b/system/base/1.7.5/src/init new file mode 100644 index 0000000..471a717 --- /dev/null +++ b/system/base/1.7.5/src/init @@ -0,0 +1,251 @@ + "run again impossible" + "recursive run" + " " + " Compiler Error : " +" " +" |" +" Fehler entdeckt " +"Keine Fehler gefunden, " +" " +" ******* ENDE DER UEBERSETZUNG *******" +"FEHLER bei >> " +" << " +"weiter bei " +"TEXTende (Anfuehrungszeichen) fehlt irgendwo" +"Kommentarende fehlt irgendwo" +"nach dem Hauptprogramm darf kein Paket folgen" +"ungueltiger Name fuer ein DEFINES-Objekt" +"':' fehlt" +"nach ENDPACKET folgt nicht der Paketname" +"ENDPACKET fehlt" +"CONST oder VAR fehlt" +"ungueltiger Name" +" ',' in Deklarationsliste fehlt" +"ist nicht der PROC Name" +"fehlerhaftes Ende des Hauptprogramms" +"ENDPROC fehlt" +"PROC/OP Schachtelung unzulaessig" +"OP darf kein Parameter sein" +"steht mehrfach im PACKET Interface" +" ist mehrfach deklariert" +"ist schon als Datenobjekt deklariert" +"ist schon als PROC/OP deklariert" +"')' nach Parameterliste erwartet" +"Standard-Schluesselwort kann nicht redefiniert werden" +"ungueltig als BOLD" +"'(' fehlt" +"CONST bzw VAR nicht bei Strukturfeldern" +"'=' fehlt" +"Schluesselwort wird im Paket schon andersartig verwandt" +"Datentyp fehlt" +"ungueltiger OP Name" +"OP muss monadisch oder dyadisch sein" +"ist nicht der OP Name" +"ENDOP fehlt" +"Name nach ENDPROC fehlt" +"Name nach ENDOP fehlt" +"';' fehlt" +"END END ist Unsinn" +"Dieses END... kenne ich nicht" +"ROW Groesse ist kein INT" +"ROW Groesse ist kein Denoter" +"Ein ROW muss mindestens ein Element haben" +"ROW Groesse fehlt" +"Parameter kann man nicht initialisieren" +"Konstanten muessen initialisiert werden" +"'::' verwenden" +"')' fehlt" +"Exponent fehlt" +"Undefinierter Typ" +"Rekursiv definierter Typ" +"Mehrfach definierter Selektor" +"Variable bzw. Abkuerzung in der Paket-Schnittstelle" +"undefinierte ROW Groesse" +"Typ Deklarationen nur im Paketrumpf" +"CONST bzw. VAR ohne Zusammenhang" +"ist nicht deklariert, steht aber in der Paket-Schnittstelle" +"ist nicht deklariert" +"unbekanntes Kommando" +"THIS IS NO CORRECT EXTERNAL NUMBER." +"Schluesselwort unzulaessig" +"Name erwartet" +"Denoter erwartet" +"ENDPROC ohne Zusammenhang" +"ENDOP ohne Zusammenhang" +"Refinement ohne Zusammenhang" +"Delimiter zwischen Paket-Refinement und Deklaration fehlt" +"unzulaessiges Selektor-Symbol (kein Name)" +"BOUND Schachtelungen unzulaessig" +"BOUND-Objekte unzulaessig als Parameter" +"Textende fehlt" +"TEXT-Denoter zu lang" + +"Denoter-Wert wird fuer diese Maschine zu gross" +"Compiler-Fehler, wenden Sie sich an Ihren Systemberater!" +"ist ein zusammenhangloses Schluesselwort" +"'::' nur fuer Initialisierungen, sonst ':='" +"welches Objekt soll verlassen werden?" +"du bist gar nicht innerhalb dieses Refinements" +"nur die eigene PROC / OP kann verlassen werden" +"THEN fehlt" +"FI fehlt" +"BOOL-Ausdruck erwartet" +"ELSE-Teil ist notwendig, da ein Wert geliefert wird" +"INT-Ausdruck erwartet" +"OF fehlt" +"Keine Typanpassung moeglich" +"CASE-Label fehlt" +"mindestens eine CASE-Anweisung geben" +"CASE-Label ist zu gross (skipped)" +"mehrfach definiertes CASE-Label" +"ungueltiges Zeichen nach CASE-Label" +"OTHERWISE-Teil fehlt" +"END SELECT fehlt" +"rekursiver Aufruf eines Refinements" +" wird nicht benutzt" +"';' oder Operator ('+','-',...) fehlt" +"undefinierter monadischer Operator" +"undefinierter dyadischer Operator" +"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen" +"fuer diesen Typ nicht definierter Selektor" +"INT,REAL,BOOL,TEXT koennen nicht selektiert werden" +"bei ROWs nur Subscription" +"nicht selektierbar" +"unzulaessiger Index fuer Subscription" +"'[' ohne Zusammenhang" +"']' ohne Zusammenhang" +"']' nach Subscription fehlt" +"ungueltig zwischen Anweisungen" +"nur die letzte Anweisung eines Abschnitts darf einen Wert liefern" +"Der Paketrumpf kann keinen Wert liefern" +"anstelle des letzten Symbols wurde ein Operand erwartet" +"Der Schleifenrumpf darf keinen Wert liefern" +"die Laufvariable muss eine INT VAR sein" +"wird schon in einer aeusseren Schleife als Laufvariable benutzt" +"FROM erwartet" +"UPTO bzw DOWNTO fehlt" +"REPEAT fehlt" +"END REP fehlt" +"die Konstante darf nicht veraendert werden" +"in einer FOR-Schleife darf die Laufvariable nicht veraendert werden" +"falscher Typ des Resultats" +"ist CONST, es wird aber ein VAR Parameter verlangt" +"unbekannte Prozedur" +"Parameter-Prozedur liefert falsches Resultat" +"Anzahl bzw. Typen der Parameter sind falsch" +"unbekannte Parameter-Prozedur" +"aktuelle Parameter-Prozedur hat CONST-, formale hat VAR-Parameter" +"Kein Konstruktor moeglich, da die Feinstruktur hier unbekannt ist" +"zu wenig Felder angegeben" +"zu viele Felder angegeben" +"unzulaessiger Trenner zwischen Feldern" +"Feld hat falschen Typ" +"falsche Element-Anzahl im ROW-Konstruktor" +"Dieser Typ kann nicht noch mehr konkretisiert werden" +"BOUND-Objekt zu gross" + +"Warnung in Zeile " +" Zeile " +"in Zeile " +" <----+---> " +" TYPE undefiniert " +" MODE undefiniert " +"Parameter spezifiziert: " +"Parameter Typ(en) sind: " +" B Code, " +" B Paketdaten generiert" +"Operand: " +"Operanden: " +", " +"erwartet " +"gefunden " +" " + +(* 001 *) END +(* 002 *) ENDPACKET +(* 003 *) ENDOP +(* 004 *) ENDOPERATOR +(* 005 *) ENDPROC +(* 006 *) ENDPROCEDURE +(* 007 *) PACKET +(* 008 *) OP +(* 009 *) OPERATOR +(* 010 *) PROC +(* 011 *) PROCEDURE +(* 012 *) FI +(* 013 *) ENDIF +(* 014 *) ENDREP +(* 015 *) ENDREPEAT +(* 016 *) PER +(* 017 *) ELIF +(* 018 *) ELSE +(* 019 *) UNTIL +(* 020 *) CASE +(* 021 *) OTHERWISE +(* 022 *) ENDSELECT +(* 023 *) INTERNAL +(* 024 *) DEFINES +(* 025 *) LET +(* 026 *) TYPE +(* 027 *) INT +(* 028 *) REAL +(* 029 *) DATASPACE +(* 030 *) TEXT +(* 031 *) BOOL +(* 032 *) BOUND +(* 033 *) ROW +(* 034 *) STRUCT +(* 035 *) CONST +(* 036 *) VAR +(* 037 INIT CONTROL *) INTERNAL +(* 038 *) CONCR +(* 039 *) REP +(* 040 *) REPEAT +(* 041 *) SELECT +(* 042 *) EXTERNAL +(* 043 *) IF +(* 044 *) THEN +(* 045 *) OF +(* 046 *) FOR +(* 047 *) FROM +(* 048 *) UPTO +(* 049 *) DOWNTO +(* 050 *) WHILE +(* 051 *) LEAVE +(* 052 *) WITH +(* 053 *) TRUE +(* 054 *) FALSE +(* 055 *) :: SBL := INCR DECR +(* 056 *) + - * / DIV MOD + ** + AND + CAND + OR + COR + NOT + = <> > >= < <= +(*040 *) MAIN +(*043*) ENDOFFILE + +PACKET a : + +PROC out (TEXT CONST t) : + EXTERNAL 60 +ENDPROC out ; + +PROC out text (TEXT CONST t, INT CONST typ) : + INTERNAL 257 ; + IF typ = typ + THEN out (t) + FI +ENDPROC out text ; + +PROC out line (INT CONST typ) : + INTERNAL 258 ; + IF typ = typ + THEN out (""13""10"") + FI +ENDPROC out line ; + +ENDPACKET a ; + diff --git a/system/base/1.7.5/src/integer b/system/base/1.7.5/src/integer new file mode 100644 index 0000000..aefb77f --- /dev/null +++ b/system/base/1.7.5/src/integer @@ -0,0 +1,265 @@ +(* ------------------- STAND : 23.10.85 --------------------*) +PACKET integer DEFINES text, int, MOD, + sign, SIGN, abs, ABS, **, min, max, minint, maxint, + random, initialize random , + last conversion ok, set conversion : + +INT PROC minint : -32767 - 1 ENDPROC minint ; + +INT PROC maxint : 32767 ENDPROC maxint ; + + +TEXT PROC text (INT CONST number) : + + IF number = minint THEN "-32768" + ELIF number < 0 THEN "-" + text(-number) + ELIF number <= 9 THEN code (number + 48) + ELSE text (number DIV 10) + digit + FI . + +digit : + code ( number MOD 10 + 48 ) . + +ENDPROC text ; + +TEXT PROC text (INT CONST number, length) : + + TEXT VAR result := text (number) ; + INT CONST number length := LENGTH result ; + IF number length < length + THEN (length - number length) * " " + result + ELIF number length > length + THEN length * "*" + ELSE result + FI + +ENDPROC text ; + +INT PROC int (TEXT CONST number) : + + skip blanks and sign ; + get value ; + result . + +skip blanks and sign : + BOOL VAR number is positive ; + INT VAR pos := 1 ; + skip blanks ; + IF (number SUB pos) = "-" + THEN number is positive := FALSE ; + pos INCR 1 + ELIF (number SUB pos) = "+" + THEN number is positive := TRUE ; + pos INCR 1 + ELSE number is positive := TRUE + FI . + +get value : + INT VAR value ; + get first digit ; + WHILE is digit REP + value := value * 10 + digit ; + pos INCR 1 + PER ; + set conversion ok result . + +get first digit : + IF is digit + THEN value := digit ; + pos INCR 1 + ELSE set conversion (FALSE) ; + LEAVE int WITH 0 + FI . + +is digit : 0 <= digit AND digit <= 9 . + +digit : code (number SUB pos) - 48 . + +result : + IF number is positive + THEN value + ELSE - value + FI . + +set conversion ok result : + skip blanks ; + conversion ok := (pos > LENGTH number) . + +skip blanks : + WHILE (number SUB pos) = " " REP + pos INCR 1 + PER . + +ENDPROC int ; + +INT OP MOD (INT CONST left, right) : + + EXTERNAL 43 + +ENDOP MOD ; + +INT PROC sign (INT CONST argument) : + + IF argument < 0 THEN -1 + ELIF argument > 0 THEN 1 + ELSE 0 + FI + +ENDPROC sign ; + +INT OP SIGN (INT CONST argument) : + sign (argument) +ENDOP SIGN ; + +INT PROC abs (INT CONST argument) : + + IF argument > 0 THEN argument + ELSE - argument + FI + +ENDPROC abs ; + +INT OP ABS (INT CONST argument) : + abs (argument) +ENDOP ABS ; + +INT OP ** (INT CONST arg, exp) : + + INT VAR x := arg , z := 1 , + counter := exp ; + + IF exp = 0 + THEN LEAVE ** WITH 1 + ELIF exp < 0 + THEN LEAVE ** WITH 1 DIV arg + FI ; + + WHILE counter >= 2 REP + calculate new x and z ; + counter := counter DIV 2 ; + ENDREP ; + z * x . + +calculate new x and z : + IF counter is not even + THEN z := z * x + FI ; + x := x * x . + +counter is not even : + counter MOD 2 = 1 . + +ENDOP ** ; + +INT PROC min (INT CONST first, second) : + + IF first < second THEN first ELSE second FI + +ENDPROC min ; + +INT PROC max (INT CONST first, second) : + + IF first > second THEN first ELSE second FI + +ENDPROC max ; + + + +BOOL VAR conversion ok := TRUE ; + +BOOL PROC last conversion ok : + conversion ok +ENDPROC last conversion ok ; + +PROC set conversion (BOOL CONST success) : + conversion ok := success +ENDPROC set conversion ; + + + +(*******************************************************************) +(* *) +(* Autor: A. Flammenkamp *) +(* RANDOM GENERATOR *) +(* *) +(* x := 4095 * x MOD (4095*4096+4093) *) +(* n+1 n *) +(* *) +(* Periode: 2**24-4 > 16.0e6 *) +(* *) +(* Beachte: x = 4096 * x1 + x0, 0 <= x0,x1 < 4096 *) +(* *) +(*******************************************************************) + + +INT VAR high := 1, low := 0 ; + +PROC initialize random (INT CONST start) : + + low := start MOD 4096 ; + IF start < 0 + THEN high := 256 + 16 + start DIV 4096 ; + IF low <> 0 THEN high DECR 1 FI + ELSE high := 256 + start DIV 4096 + FI + +ENDPROC initialize random ; + +INT PROC random (INT CONST lower bound, upper bound) : + + compute new random value ; + normalize high ; + normalize low ; + map into interval . + +compute new random value : + (* (high,low) := (low-high , 3*high-low) *) + high := low - high ; + low INCR low - 3 * high . + +normalize high : + IF high < 0 + THEN high INCR 4096 ; low DECR 3 + FI . + +normalize low : + (* high INCR low DIV 4096 ; + low := low MOD 4096 + *) + IF low >= 4096 THEN low overflow + ELIF low < 0 THEN low underflow + FI . + +low overflow : + IF low >= 8192 + THEN low DECR 8192 ; high INCR 2 + ELSE low DECR 4096 ; high INCR 1 ; post normalization + FI . + +post normalization : + (* IF (high,low) >= (4095,4093) + THEN (high,low) DECR (4095,4093) + FI + *) + IF high >= 4095 + THEN IF low >= 4093 THEN high DECR 4095 ; low DECR 4093 + ELIF high = 4096 THEN high := 0 ; low INCR 3 + FI + FI . + +low underflow : + low INCR 4096 ; high DECR 1 . + +map into interval : + INT VAR number := high MOD 16 - 8 ; + number INCR 4095 * number + low ; + IF lower bound <= upper bound + THEN lower bound + number MOD (upper bound - lower bound + 1) + ELSE upper bound + number MOD (lower bound - upper bound + 1) + FI . + +ENDPROC random ; + + +ENDPACKET integer ; + diff --git a/system/base/1.7.5/src/local manager b/system/base/1.7.5/src/local manager new file mode 100644 index 0000000..48d024b --- /dev/null +++ b/system/base/1.7.5/src/local manager @@ -0,0 +1,373 @@ +(* ------------------- VERSION 2 24.02.86 ------------------- *) +PACKET local manager (* Autor: J.Liedtke *) + + DEFINES + create, (* neue lokale Datei einrichten *) + new, (* 'create' und Datei liefern *) + old, (* bestehende Datei liefern *) + forget, (* lokale Datei loeschen *) + exists, (* existiert Datei (lokal) ? *) + status, (* setzt und liefert Status *) + rename, (* Umbenennung *) + copy , (* Datenraum in Datei kopieren *) + enter password,(* Passwort einfuehren *) + write password , + read password , + write permission , + read permission , + begin list , + get list entry , + all : + + + +LET size = 200 , + nil = 0 ; + +INT VAR index ; + +TEXT VAR system write password := "" , + system read password := "" , + actual password ; + +INITFLAG VAR this packet := FALSE ; + +DATASPACE VAR password space ; + +BOUND ROW size STRUCT (TEXT write, read) VAR passwords ; + + +THESAURUS VAR dir := empty thesaurus ; + +ROW size STRUCT (DATASPACE ds, + BOOL protected, + TEXT status) VAR crowd ; + + +PROC initialize if necessary : + + IF NOT initialized (this packet) + THEN system write password := "" ; + system read password := "" ; + dir := empty thesaurus ; + password space := nilspace ; + passwords := password space + FI + +ENDPROC initialize if necessary ; + + + +PROC create (TEXT CONST name) : + +IF exists (name ) + THEN error (name, "existiert bereits") ; + index := nil + ELSE insert and initialize entry +FI . + +insert and initialize entry : + disable stop ; + insert (dir, name, index) ; + IF index <> nil + THEN crowd (index).ds := nilspace ; + IF is error + THEN delete (dir, name, index) ; + LEAVE create + FI ; + status (name, "") ; + crowd (index).protected := FALSE + ELIF NOT is error + THEN errorstop ("zu viele Dateien") + FI . + +ENDPROC create ; + +DATASPACE PROC new (TEXT CONST name) : + + create (name) ; + IF index <> nil + THEN crowd (index).ds + ELSE nilspace + FI + +ENDPROC new ; + +DATASPACE PROC old (TEXT CONST name) : + + initialize if necessary ; + index := link (dir, name) ; + IF index = 0 + THEN error (name, "gibt es nicht") ; + nilspace + ELSE space + FI . + +space : crowd (index).ds . + +ENDPROC old ; + +DATASPACE PROC old (TEXT CONST name, INT CONST expected type) : + + initialize if necessary ; + index := link (dir, name) ; + IF index = 0 + THEN error (name, "gibt es nicht") ; + nilspace + ELIF type (space) <> expected type + THEN errorstop ("Datenraum hat falschen Typ") ; + nilspace + ELSE space + FI . + +space : crowd (index).ds . + +ENDPROC old ; + +BOOL PROC exists (TEXT CONST name) : + + initialize if necessary ; + dir CONTAINS name + +ENDPROC exists ; + +PROC forget (TEXT CONST name ) : + + initialize if necessary ; + say ("""") ; + say (name) ; + IF NOT exists (name) THEN say (""" existiert nicht") + ELIF yes (""" loeschen") THEN forget (name, quiet) + FI . + +ENDPROC forget ; + +PROC forget (TEXT CONST name, QUIET CONST q) : + + initialize if necessary ; + disable stop ; + delete (dir, name, index) ; + IF index <> nil + THEN forget ( crowd (index).ds ) ; + crowd (index).status := "" + FI . + +ENDPROC forget ; + +PROC forget : + + BOOL VAR status := command dialogue ; + command dialogue (TRUE) ; + forget (last param) ; + command dialogue (status) + +ENDPROC forget ; + +PROC status (TEXT CONST name, status text) : + + initialize if necessary ; + INT VAR index := link (dir, name) ; + IF index > 0 + THEN crowd (index).status := date + " " + text (status text, 4) + FI + +ENDPROC status ; + +TEXT PROC status (TEXT CONST name) : + + initialize if necessary ; + INT VAR index := link (dir, name) ; + IF index > 0 + THEN crowd (index).status + ELSE "" + FI + +ENDPROC status ; + +PROC status (INT CONST pos, TEXT CONST status pattern) : + + initialize if necessary ; + INT VAR index := 0 ; + WHILE index < highest entry (dir) REP + index INCR 1 ; + replace (actual status, pos , status pattern) + PER . + +actual status : crowd (index).status . + +ENDPROC status ; + +PROC copy (DATASPACE CONST source, TEXT CONST dest name) : + + IF exists (dest name) + THEN error (dest name, "existiert bereits") + ELSE copy file + FI . + +copy file : + disable stop ; + create ( dest name ) ; + INT VAR index := link (dir, dest name) ; + IF index > nil + THEN forget (crowd (index).ds) ; + crowd (index).ds := source + FI + +ENDPROC copy ; + +PROC copy (TEXT CONST source name, dest name) : + + copy (old (source name), dest name) + +ENDPROC copy ; + +PROC rename (TEXT CONST old name, new name) : + + IF exists (new name) + THEN error (new name, "existiert bereits") + ELIF exists (old name) + THEN rename (dir, old name, new name) ; + last param (new name) + ELSE error (old name, "gibt es nicht") + FI . + +ENDPROC rename ; + + +PROC begin list : + + initialize if necessary ; + index := 0 + +ENDPROC begin list ; + +PROC get list entry (TEXT VAR entry, status text) : + + get (dir, entry, index) ; + IF found + THEN status text := crowd (index).status ; + ELSE status text := "" ; + FI . + +found : index > 0 . + +ENDPROC get list entry ; + + +TEXT PROC write password : + + system write password + +ENDPROC write password ; + +TEXT PROC read password : + + system read password + +ENDPROC read password ; + + +PROC enter password (TEXT CONST password) : + + initialize if necessary ; + say (""3""5"") ; + INT CONST slash pos := pos (password, "/") ; + IF slash pos = 0 + THEN system write password := password ; + system read password := password + ELSE system write password := subtext (password, 1, slash pos-1) ; + system read password := subtext (password, slash pos+1) + FI . + +ENDPROC enter password ; + +PROC enter password (TEXT CONST file name, write pass, read pass) : + + INT CONST index := link (dir, file name) ; + IF index > 0 + THEN set protect password + FI . + +set protect password : + IF write pass = "" AND read pass = "" + THEN crowd (index).protected := FALSE + ELSE crowd (index).protected := TRUE ; + passwords (index).write := write pass ; + passwords (index).read := read pass + FI . + +ENDPROC enter password ; + +INT PROC password index (TEXT CONST file name) : + + initialize if necessary ; + INT CONST index := link (dir, file name) ; + IF index > 0 CAND crowd (index).protected + THEN index + ELSE 0 + FI + +ENDPROC password index ; + +BOOL PROC read permission (TEXT CONST name, supply password) : + + (****************************************************************) + (* for reasons of data security the password check algorithm *) + (* must not copy parts of the file password into variables *) + (* located in the standard dataspace! *) + (****************************************************************) + + access file password ; + file has no password COR (supply password <> "-" AND read password match) . + +read password match : + file password.read = supply password OR file password.read = "" . + +access file password : + INT CONST pw index := password index (name) . + +file password : passwords (pw index) . + +file has no password : pw index = 0 . + +ENDPROC read permission ; + +BOOL PROC write permission (TEXT CONST name, supply password) : + + (****************************************************************) + (* for reasons of data security the password check algorithm *) + (* must not copy parts of the file password into variables *) + (* located in the standard dataspace! *) + (****************************************************************) + + access file password ; + file has no password COR (supply password <> "-" AND write password match). + +write password match : + file password.write = supply password OR file password.write = "" . + +access file password : + INT CONST pw index := password index (name) . + +file password : passwords (pw index) . + +file has no password : pw index = 0 . + +ENDPROC write permission ; + +THESAURUS PROC all : + + initialize if necessary ; + THESAURUS VAR result := dir ; (*ueberfluessig ab naechstem Compiler *) + result + +ENDPROC all ; + +PROC error (TEXT CONST file name, error text) : + + errorstop ("""" + file name + """ " + error text) + +ENDPROC error ; + +ENDPACKET local manager ; + diff --git a/system/base/1.7.5/src/local manager 2 b/system/base/1.7.5/src/local manager 2 new file mode 100644 index 0000000..8f70301 --- /dev/null +++ b/system/base/1.7.5/src/local manager 2 @@ -0,0 +1,41 @@ + +PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *) + (* Stand: 25.02.85 *) + list : + + +TEXT VAR file name, status text; + + +PROC list : + + disable stop ; + DATASPACE VAR ds := nilspace ; + FILE VAR list file := sequential file (output, ds) ; + headline (list file, "list") ; + list (list file) ; + show (list file) ; + forget (ds) . + +ENDPROC list ; + +PROC list (FILE VAR f) : + + enable stop ; + begin list ; + putline (f, "") ; + REP + get list entry (file name, status text) ; + IF file name = "" + THEN LEAVE list + FI ; + write (f, status text + " """ ) ; + write (f, file name) ; + write (f, """") ; + line (f) + PER . + +ENDPROC list ; + +ENDPACKET local manager part 2 ; + diff --git a/system/base/1.7.5/src/mathlib b/system/base/1.7.5/src/mathlib new file mode 100644 index 0000000..c726495 --- /dev/null +++ b/system/base/1.7.5/src/mathlib @@ -0,0 +1,268 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PACKET mathlib DEFINES sqrt, **, exp, ln, log2, log10, e, pi, + sin, cos, tan, sind, cosd, tand, + arctan, arctand, random, initializerandom : + +LET pii = 3.141592653589793238462, + pi2 = 1.570796326794896619231, + pi3 = 1.047197551196597746154, + pi6 = 0.523598775598298873077, + pi4 = 1.273239544735162686151, + ln2 = 0.693147180559945309417, + lg2 = 0.301029995663981195213, + ln10 = 2.302585092994045684018, + lge = 0.434294481903251827651, + ei = 2.718281828459045235360, + pi180 = 57.295779513082320876798, + sqrt3 = 1.732050807568877293527, + sqr3 = 0.577350269189625764509, + sqr3p2= 3.732050807568877293527, + sqr3m2= 0.267949192431122706473, + sqr2 = 0.707106781186547524400; + +REAL VAR rdg::0.4711; + +REAL PROC pi: pii END PROC pi; +REAL PROC e : ei END PROC e; + +REAL PROC ln ( REAL CONST x ): + log2(x) * ln2 +END PROC ln; + +REAL PROC log10( REAL CONST x ): + log2(x) * lg2 +END PROC log10; + +REAL PROC log2 ( REAL CONST z ): + REAL VAR t, summe::0.0, x::z; + IF x=1.0 THEN 0.0 + ELIF x>0.0 THEN normal + ELSE errorstop("log2: " + text (x,20)); 0.0 FI. + +normal: + IF x >= 0.5 THEN normalise downwards + ELSE normalise upwards FI; + IF x < sqr2 THEN summe := summe - 0.75; t := trans8 + ELSE summe := summe - 0.25; t := trans2 FI; + summe + reihenentwicklung. + + normalise downwards: + WHILE x >= 8.0 REP x := 0.0625 * x; summe:=summe+4.0 PER; + WHILE x >= 1.0 REP x := 0.5 * x; summe:=summe+1.0 PER. + + normalise upwards: + WHILE x<=0.0625 REP x := 16.0 * x; summe:=summe-4.0 PER; + WHILE x<= 0.5 REP x := 2.0 * x; summe:=summe-1.0 PER. + + trans8: (x - 0.5946035575013605)/(x + 0.5946035575013605). + trans2: (x - 0.8408964152537145)/(x + 0.8408964152537145). + + reihenentwicklung: x := t * t; t * 0.06405572387119384648 * + ((((((3.465*x+4.095)*x+5.005)*x+6.435)*x+9.009)*x+15.015)*x+45.045) +END PROC log2; + +REAL PROC sqrt ( REAL CONST z ): + REAL VAR y0, y1, x::z; + INT VAR p :: decimal exponent(x) DIV 2; + IF p <= -64 THEN 0.0 + ELIF x < 0.0 THEN errorstop("sqrt: " + text (x,20)); 0.0 + ELSE nontrivial FI. + + nontrivial: + set exp (decimal exponent (x) -p-p, x); + IF x<10.0 THEN x := 5.3176703 - 40.760905/( 8.408065 + x ) + ELSE x := 16.81595 - 1288.973 /( 84.08065 + x ) FI; + y0 := x; + set exp (decimal exponent (x) + p, y0); + y1 := 0.5 * ( y0 + z/y0 ); + y0 := 0.5 * ( y1 + z/y1 ); + y1 := 0.5 * ( y0 + z/y0 ); + 0.5 * ( y1 + z/y1 ) +END PROC sqrt; + +REAL PROC exp ( REAL CONST z ): + REAL VAR x::z, a::1.0; BOOL VAR negativ :: x<0.0; + IF negativ THEN x := -x FI; + IF x>292.42830676 + THEN IF NOT negativ THEN errorstop ("REAL-Ueberlauf") FI ; 0.0 + ELIF x<=0.0001 + THEN ( 0.5*z + 1.0 ) * z + 1.0 + ELSE approx + FI. + + approx: + IF x > ln10 + THEN x := lge*x; + a := 1.0; + set exp (int(x), a); + x := frac(x)*ln10 + FI; + IF x >= 2.0 THEN a := 7.389056098930650227230*a; x := x-2.0 FI; + IF x >= 1.0 THEN a := 2.718281828459045235360*a; x := x-1.0 FI; + IF x >= 0.5 THEN a := 1.648721270700128146848*a; x := x-0.5 FI; + IF x >= 0.25 THEN a := 1.284025416687741484073*a; x := x-0.25 FI; + IF x >= 0.125 THEN a := 1.133148453066826316829*a; x := x-0.125 FI; + IF x >= 0.0625THEN a := 1.064494458917859429563*a; x := x-0.0625FI; + a:=a/50.4*(((((((0.01*x+0.07)*x+0.42)*x+2.1)*x+8.4)*x+25.2)*x+50.4)*x+50.4); + IF negativ THEN 1.0/a ELSE a FI . + +ENDPROC exp ; + +REAL PROC tan (REAL CONST x): + IF x < 0.0 THEN - tg( -x * pi4) + ELSE tg( x * pi4) FI +END PROC tan; + +REAL PROC tand (REAL CONST x): + IF x < 0.0 THEN - tg( -x / 45.0) + ELSE tg( x / 45.0) FI +END PROC tand; + +REAL PROC tg (REAL CONST x ): + REAL VAR q::floor(x), s::x-q; INT VAR n; + q := q - floor(0.25*q) * 4.0 ; + IF q < 2.0 + THEN IF q < 1.0 + THEN n:=0; + ELSE n:=1; s := 1.0 - s FI + ELSE IF q < 3.0 + THEN n:=2; + ELSE n:=3; s := 1.0 - s FI + FI; + q := s * s; + q := (((((((((-5.116186989653120e-11*q-5.608325022830701e-10)*q- + 9.526170109403018e-9)*q-1.517906721393745e-7)*q-2.430939946375515e-6)*q- + 3.901461426385464e-5)*q-6.324811612385572e-4)*q-1.076606829172646e-2)*q- + 0.2617993877991508)*q+pi4); + + SELECT n OF + CASE 0 : s/q + CASE 1 : q/s + CASE 2 : -q/s + OTHERWISE : -s/q ENDSELECT . + +END PROC tg; + +REAL PROC sin ( REAL CONST x ): + REAL VAR y, r, q; + IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI; + y := y * pi4; + r := floor(y); + sincos( q+r , y-r ) +END PROC sin; + +REAL PROC sind ( REAL CONST x ): + REAL VAR y, r, q; + IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI; + y := y / 45.0; + r := floor(y); + sincos( q+r , y-r ) +END PROC sind; + +REAL PROC cos ( REAL CONST x ): + REAL VAR y, q; + IF x < 0.0 THEN y := -x ELSE y := x FI; + y := y * pi4; + q := floor(y); + sincos( q+2.0, y-q ) +END PROC cos; + +REAL PROC cosd ( REAL CONST x ): + REAL VAR y, q; + IF x < 0.0 THEN y := -x ELSE y := x FI; + y := y / 45.0; + q := floor(y); + sincos( q+2.0, y-q ) +END PROC cosd; + +REAL PROC sincos ( REAL CONST q, y ): + REAL VAR r :: q - floor( 0.125*q + 0.1 ) * 8.0; + IF r >= 4.0 THEN IF r >= 6.0 THEN IF r >= 7.0 THEN - sin approx(1.0-y) + ELSE - cos approx(y) FI + ELSE IF r >= 5.0 THEN - cos approx(1.0-y) + ELSE - sin approx(y) FI FI + ELSE IF r >= 2.0 THEN IF r >= 3.0 THEN sin approx(1.0-y) + ELSE cos approx(y) FI + ELSE IF r >= 1.0 THEN cos approx(1.0-y) + ELSE sin approx(y) FI FI FI +END PROC sincos; + +REAL PROC sin approx ( REAL CONST x ): + REAL VAR z::x*x; + x*((((((0.6877101540593035e-11*z-0.1757149296873372e-8)*z+0.3133616216672568 + e-6)*z-0.3657620415845891e-4)*z+0.2490394570188737e-2)*z-0.807455121882e-1)* + z+0.7853981633974483) +END PROC sin approx; + +REAL PROC cos approx ( REAL CONST x ): + REAL VAR z::x*x; + ((((((-0.3857761864560276e-12*z+0.115004970178141e-9)*z-0.246113638267419e-7 + )*z+0.3590860445885748e-5)*z-0.3259918869266875e-3)*z+0.1585434424381541e-1) + *z-0.3084251375340425)*z+1.0 +END PROC cos approx; + +REAL PROC arctan ( REAL CONST y ): + REAL VAR f, z, x; BOOL VAR neg :: y < 0.0; + IF neg THEN x := -y ELSE x := y FI; + IF x>1.0 THEN f := a ELSE f := -b; neg := NOT neg FI; + z := x * x; + x := x/(((((((0.0107090276046822*z-0.01647757182108040)*z + +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z + -0.0888888888888888)*z+0.3333333333333333)*z+1.0); + IF neg THEN x - f ELSE f - x FI. + + a:IF x>sqr3p2 THEN x := 1.0/x; pi2 ELSE x := 4.0/(sqrt3+x+x+x)-sqr3; pi3 FI. + b:IF x<sqr3m2 THEN 0.0 ELSE x := sqrt3 - 4.0/(sqrt3+x); pi6 FI +END PROC arctan; + +REAL PROC arctand ( REAL CONST x ): + arctan(x) * pi180 +END PROC arctand; + +REAL OP ** ( REAL CONST b, e ): + IF b=0.0 + THEN IF e=0.0 THEN 1.0 ELSE 0.0 FI + ELIF b < 0.0 + THEN errorstop("("+text(b,20)+") ** "+text(e)); (-b) ** e + ELSE exp( e * log2( b ) * ln2 ) + FI +END OP **; + +REAL OP ** ( REAL CONST a, INT CONST b ) : + + REAL VAR p := 1.0 , + r := a ; + INT VAR n := ABS b , + m ; + IF (a = 0.0 OR a = -0.0) + THEN IF b = 0 + THEN 1.0 + ELSE 0.0 + FI + ELSE WHILE n>0 REP + m := n DIV 2 ; + IF m + m = n + THEN n := m ; + r := r*r + ELSE n DECR 1 ; + p := p*r + FI + END REP ; + IF b>0 + THEN p + ELSE 1.0 / p + FI + FI . + +END OP ** ; + +REAL PROC random: + rdg:=rdg+pii;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg +END PROC random; + +PROC initializerandom ( REAL CONST z ): + rdg := frac(z) +END PROC initializerandom; + +END PACKET mathlib; + diff --git a/system/base/1.7.5/src/pattern match b/system/base/1.7.5/src/pattern match new file mode 100644 index 0000000..f6190d8 --- /dev/null +++ b/system/base/1.7.5/src/pattern match @@ -0,0 +1,768 @@ +PACKET pattern match DEFINES (* Author: P.Heyderhoff *) + (* Date: 09.06.1986 *) + -, + OR, + **, + any, + notion, + bound, + match, + matchpos, + matchend, + somefix, + UNLIKE, + LIKE : + +(*------- Operation codes of the internal intermeadiate language: --------*) + +LET + z = ""0"", + stopz = ""1""0"", + closez = ""2""0"", + closor = ""2""0""3""0"", + or = ""3"", + oralpha = ""3""5"", + open2 = ""4""0""4""0"", + alpha = ""5"", + alphaz = ""5""0"", + lenz = ""6""0"", + nilz = ""6""0""0""0""7""0"", (* = any (0) *) + starz = ""7""0"", + star = ""8""0""2""7""0""1""0"", (* = any ** 1 *) + powerz = ""8""0"", + powerz0 = ""8""0""1"", + notionz = ""9""0"", + fullz = ""10""0"", + boundz = ""11""0""; +(*------------------------------------------------------------------------*) + +LET undefined = 0, (* fixleft value *) + forcer = 0, (* vaHue parameter *) + delimiter = " !""#$%&'()*+,-./:;<=>?§^_`"; (* for 'PROC notion' *) + +TEXT OP - (TEXT CONST alphabet ): + p:= ""; + INT VAR j; + FOR j FROM 0 UPTO 255 + REP IF pos(alphabet,code(j)) = 0 + THEN p CAT code(j) + FI + PER; + p + ENDOP -; + +TEXT OP OR (TEXT CONST a, b): + open2 + notnil (a) + closor + notnil (b) + closez + ENDOP OR; + +TEXT OP ** (TEXT CONST p, INT CONST x): + powerz + code (1+x) + notnil (p) + stopz + ENDOP **; + +TEXT CONST any:= starz; + +TEXT PROC any (INT CONST n): + TEXT VAR t:= " "; + replace (t, 1, ABSn); + lenz + t + starz + ENDPROC any; + +TEXT PROC any (TEXT CONST a): alphaz + a + starz ENDPROC any; + +TEXT PROC any (INT CONST n, TEXT CONST a): + TEXT VAR t:= " "; + replace (t, 1, ABSn); + lenz + t + alphaz + a + starz + ENDPROC any; + +TEXT PROC notion (TEXT CONST t): notionz + notnil(t) + stopz ENDPROC notion; + +TEXT PROC notnil (TEXT CONST t): + IF t = "" + THEN nilz + ELSE t + FI + ENDPROC notnil; + +TEXT CONST bound := boundz; + +TEXT PROC full (TEXT CONST t): fullz + t + stopz ENDPROC full; + +TEXT PROC match (INT CONST x): + subtext (p, matchpos(x), matchend(x)) + ENDPROC match; + +INT PROC matchpos (INT CONST x): mapos (1 + x MOD 256) ENDPROC matchpos; + +INT PROC matchend (INT CONST x): maend (1 + x MOD 256) - 1 + ENDPROC matchend; + +(*----------------- GLOBAL VARIABLES: -----------------------------------*) + +ROW 256 INT VAR + (* Table of match registers. Each entry consists of two *) + (* pointers, which points to the TEXT object 't' *) + mapos, (* points to the beginning of the match *) + maend; (* points to the position after the end of match *) + +INT VAR ppos, tpos, (* workpositions in pattern 'p' and text 't' *) + floatpos, (* accumulation of all pending floatlengths *) + failpos, (* result of 'PROC in alpha' *) + plen, tlen, (* length of pattern 'p' and length of text 't' *) + skipcount, (* for track forward skipping *) + multi, vari; (* for handling of nonexclusive alternatives *) + +TEXT VAR p, (* the pattern to be find or some result *) + stack, (* stack of pending assignments *) + alphabet:=""; (* result of 'PROC find alpha', reset to nil *) + (* after its usage by 'find any' *) + +BOOL VAR fix, (* text position is fixed and not floating *) + no vari; (* not variing the order of alternatives *) + +TEXT PROC somefix (TEXT CONST pattern): + + (* delivers the first text occuring unconditionally in the pattern *) + + p:= pattern; + INT VAR j:= 1, n:= 0, k, len:= LENGTH p; + REP + SELECT text( subtext (p, j, j+1), 2) ISUB 1 OF + CASE 1,3,7,9,10,11: j INCR 2 + CASE 2: j INCR 2; n DECR 1 (* condition closed *) + CASE 4: j INCR 2; n INCR 1 (* condition opened *) + CASE 5: j := pos (p, starz, j+2) + 2 + CASE 6: j INCR 4 + CASE 8: j INCR 3 + OTHERWISE k:= pos(p, z, j+1) - 1; + IF k <= 0 THEN k:= 1+len FI; + IF star found + THEN change (p, starpos, starpos, star); + len:= LENGTH p; + k:= starpos + FI; + IF n = 0 CAND ( p SUB k ) <> or CAND k > j + THEN LEAVE somefix WITH subtext(p,j,k-1) + ELSE j:=k + FI + ENDSELECT + UNTIL j > len + PER; + "" . + + star found: + INT VAR starpos:= pos (p, "*", j); + starpos > 0 CAND starpos <= k . + + ENDPROC somefix; + +PROC skip (TEXT CONST p, BOOL CONST upto or): + + (* skips 'ppos' upto the end of the opened nest, n = nesting level *) + + INT VAR n:= 0; + REP + SELECT text (subtext (p, ppos, ppos+1), 2) ISUB 1 OF + CASE 1,2: IF n = 0 + THEN LEAVE skip + FI; + ppos INCR 2; + nDECR1 + CASE 3: IF n = 0 CAND upto or + THEN LEAVE skip + FI; + ppos INCR 2 + CASE 7: ppos INCR 2 + CASE 4,9,10,11: ppos INCR 2; + n INCR 1 + CASE 5: ppos:= pos (p, starz, ppos+2) + 2 + CASE 6: ppos INCR 4 + CASE 8: ppos INCR 3; + n INCR 1 + OTHERWISE ppos:= pos(p, z, ppos+1) - 1; + IF ppos < 0 + THEN ppos:= plen; + LEAVE skip + FI + ENDSELECT + PER + ENDPROC skip; + +BOOL OP UNLIKE (TEXT CONST t, p): NOT ( t LIKE p ) ENDOP UNLIKE; + +BOOL OP LIKE (TEXT CONST t, pattern): + init; + BOOL CONST found:= find (t,1,1, fixresult, floatresult); + save; + found. + + init: no vari:= TRUE; + vari:= 0; + tlen:= 1 + LENGTH t; + p:= full (pattern); + IF pos (p, bound) > 0 + THEN + IF subtext (p, 14, 15) = bound + THEN p:= subtext (p, 1, 8) + powerz0 + subtext (p, 16) + FI; + plen:= LENGTH p - 7; + IF subtext (p, plen, plen+1) = bound + THEN p:= subtext (p, 1, plen - 1) + stopz + stopz + FI; + FI; + plen:= LENGTH p + 1; + INT VAR fixresult, floatresult; + tpos:= 1; + floatpos:= 0; + stack:= ""; + alphabet:= ""; + fix:= TRUE; + skipcount:= 0; + multi:= 0. + + save: p:= t + + ENDOP LIKE; + +(*-------- Realisation of the pattern matching algorithms 'find' --------*) + +BOOL PROC find + (TEXT CONST t, INT CONST unit, from, INT VAR fixleft, floatlen): + + initialize; + BOOL CONST found:= pattern unit; + SELECT next command * unit OF + CASE 0,1,2: found + CASE 3: next; + find alternative + OTHERWISE find concatenation + ENDSELECT . + + find alternative: + IF found + THEN save left position; + backtrack; + IF find pattern CAND better + THEN note multiplicity + ELSE back to first one + FI + ELSE backtrack multi + FI. + + better: permutation XOR more left. + + permutation: vari MOD 2 = 1. + + save left position: j:= fixleft. + + more left: j > fixleft. + + backtrack multi: multi:= 2 * backmulti + 1; + vari:= backvari DIV 2; + find pattern. + + note multiplicity: multi:= 2 * multi + 1; + vari:= vari DIV 2; + TRUE. + + back to first one: backtrack; + IF find first subpattern + THEN skip (p, FALSE); + note multiplicity + ELSE errorstop ("pattern"); + FALSE + FI. + + find concatenation: + IF found + THEN IF ppos=plen COR find pattern COR track forward + COR ( multi > backmulti CAND vari = 0 CAND find variation ) + THEN TRUE + ELSE backtrack; FALSE + FI + ELSE skip (p, TRUE); FALSE + FI. + + track forward: (* must be performed before variation *) + j:=0; + last multi:= multi; + last vari:= vari; + WHILE skipcount = 0 + REP IF tlen = tpos + THEN LEAVE track forward WITH FALSE + FI; + backtrack; + j INCR 1; + skipcount:= j + UNTIL find first subpattern CAND find pattern + PER; + j:= skipcount; + skipcount:=0; + j=0. + + find variation: + multi:= last multi; + vari:= last vari; + FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1 + REP backtrack with variation; + IF find first subpattern CAND find pattern + THEN vari:=0; + LEAVE find variation WITH TRUE + FI + PER; + FALSE. + + backtrack with variation: + backtrack; + vari:= k. + + find pattern: + find (t, 1, ppos+forcer, fixresult, floatresult) CAND keep result. + + find first subpattern: + find (t, 0, from, fixresult, floatresult) CAND keep result . + + initialize: + INT VAR j, + k, + fixresult, + floatresult, + last multi, + last vari; + BOOL CONST backfix:= fix; + TEXT CONST backstack:= stack; + floatlen:= 0; + INT CONST back:= tpos, + backfloat:= floatpos, + backskip:= skipcount, + backmulti:= multi, + backvari:= vari; + fixleft:= fixleft0. + + fixleft0: IF fix THEN back ELSE undefined FI. + + backtrack: + fix:= backfix; + tpos:= back; + fixleft:= fixleft0; + floatlen:= 0; + floatpos:= backfloat; + stack:= backstack; + skipcount:= backskip; + multi:= backmulti; + vari:= backvari. + + keep result: + IF fixleft = undefined + THEN IF fixresult = undefined + THEN floatlen INCR floatresult + ELSE fixleft := fixresult - floatlen; + floatpos DECR floatlen; + floatlen:= 0 + FI + FI; + TRUE. + + pattern unit: + init ppos; + SELECT command OF + CASE 1,2: find end + CASE 3: find nil + CASE 4: find choice + CASE 5: find alphabet + CASE 6: find fixlength any + CASE 7: find varlength any + CASE 8: find and store match + CASE 9: find notion + CASE 10: find full + CASE 11: next; find nil + OTHERWISE find plain text END SELECT. + + init ppos: ppos:= from + 2. + + command: text (subtext (p, from, from+1), 2) ISUB 1. + + next command: text (subtext (p, ppos, ppos+1), 2) ISUB 1. + + next: ppos INCR 2. + + find end: ppos DECR 2; + fixleft:= tpos; + LEAVE find WITH TRUE; + TRUE. + + find nil: ppos DECR 2; + fixleft:= tpos; + TRUE. + + find choice: IF find pattern + THEN next; TRUE + ELSE next; FALSE + FI. + + find plain text: find text upto next command; + IF fix THEN allow fix position only + ELIF text found THEN allow variable position + ELSE allow backtrack + FI. + + find text upto next command: + ppos:= pos (p, z, from + 1); + IF ppos = 0 + THEN ppos:= plen + ELSE ppos DECR 1 + FI; + IF star found + THEN change (p, starpos, starpos, star); + plen:= 1 + LENGTH p; + ppos:= starpos + FI; + tpos:= pos (t, subtext (p, from, ppos - 1), tpos). + + star found: + INT VAR starpos:= pos (p, "*", from); + starpos > 0 CAND starpos <= ppos . + + text found: + WHILE skipcount > 0 CAND tpos > 0 + REP skipcount DECR 1; + tpos:= pos (t, subtext(p,from,ppos-1), tpos+1) + PER; + tpos > 0 . + + allow fix position only: + IF tpos = back + THEN tpos INCR (ppos-from); TRUE + ELSE tpos:= back; + from = ppos + FI. + + allow variable position: + IF alphabet = "" COR in alpha (t, back, tpos) + THEN fix it; + tpos INCR (ppos-from); + TRUE + ELSE tpos:= back; + FALSE + FI. + + allow backtrack: + tpos:= back; + IF from = ppos + THEN fix it; + TRUE + ELSE FALSE + FI . + + find alphabet: + j:= pos (p, starz, ppos); + alphabet:= subtext (p, ppos, j-1); + ppos := j; + TRUE. + + find fixlength any: + get length value; + find alpha attribut; + IF alphabet = "" + THEN find any with fix length + ELSE find any in alphabet with fix length + FI. + + get length value: + floatlen:= subtext(p, ppos, ppos+1) ISUB 1; + ppos INCR 4. + + find alpha attribut: + IF (p SUB (ppos-2)) = alpha CAND find alphabet + THEN next + FI. + + find any with fix length: + tpos INCR floatlen; + IF tpos > tlen + THEN tpos:= back; + floatlen:=0; + FALSE + ELSE IF fix THEN floatlen:= 0 + ELIF floatlen = 0 + THEN fix it (* unlike niltext 6.6. *) + ELSE floatpos INCR floatlen + FI; + TRUE + FI. + + find any in alphabet with fix length: + IF first character in alpha + THEN IF NOT fix THEN fix it FI; + set fix found + ELSE set fix not found + FI. + + first character in alpha: + (fix COR advance) CAND in alpha (t, tpos, tpos+floatlen). + + advance: + FOR tpos FROM back UPTO tlen + REP IF pos (alphabet, t SUB tpos) > 0 + THEN LEAVE advance WITH TRUE + FI + PER; + FALSE. + + fix it: + fixleft:= back-floatpos; + make fix (back); + fixleft:= tpos. + + set fix found: + tpos INCR floatlen; + floatlen:= 0; + alphabet:= ""; + TRUE. + + set fix not found: tpos:= back; + alphabet:= ""; + floatlen:= 0; + FALSE. + + find varlength any: IF alphabet = "" + THEN really any + ELSE find varlength any in alphabet + FI. + + really any: IF fix + THEN fix:= FALSE; + fixleft:= tpos + ELIF floatpos = 0 + THEN fixleft:= tpos (* 6.6. *) + FI; + TRUE . + + find varlength any in alphabet: + IF fix THEN fixleft := tpos FI; + IF fix CAND pos (alphabet, t SUB tpos) > 0 + COR NOT fix CAND advance + THEN IF NOT fix THEN fix it FI; + set var found + ELSE set var not found + FI. + + set var found: tpos:= end of varlength any; + alphabet:= ""; + TRUE. + set var not found: tpos:= back; + alphabet:= ""; + FALSE. + end of varlength any: IF NOT in alpha(t,tpos,tlen) + THEN failpos + ELSE tlen + FI. + + find and store match: get register name; + IF find pattern + THEN next; + store; + TRUE + ELSE next; + FALSE + FI. + + store: IF fix + THEN mapos (reg):= fixleft; + maend (reg):= tpos + ELSE stack CAT code(floatlen) + + code(floatpos) + code(fixleft) + c + FI. + + get register name: TEXT CONST c:= p SUB (ppos); + INT VAR reg:= code (c); + ppos INCR 1. + + find notion: float notion; + exhaust notion . + + float notion: j:= back; + REP IF find pattern + THEN IF is notion (t, fixleft) + THEN LEAVE find notion WITH TRUE + ELIF backfix + THEN LEAVE float notion + ELSE go ahead FI + ELIF j=back + THEN next; + LEAVE find notion WITH FALSE + ELSE LEAVE float notion + FI + PER. + + go ahead: j INCR 1; + IF simple THEN j:= max (tpos, j) FI; + notion backtrack. + + simple: k:= from; + REP k := pos (p, z, k+2); + IF k > ppos-3 + THEN LEAVE simple WITH TRUE + ELIF pos (oralpha, p SUB k-1) > 0 + THEN LEAVE simple WITH FALSE + FI + PER; + FALSE. + + notion backtrack: tpos:= j; + fix:= backfix; + fixleft:= fixleft0; + floatlen:= 0; + floatpos:= backfloat + tpos - back; + stack:= backstack; + ppos:= from + 2 . + + exhaust notion: IF notion expansion + COR multi > backmulti + CAND no vari + CAND notion variation + THEN TRUE + ELSE backtrack; FALSE + FI. + + notion expansion: j:= 0; + multi:= last multi; + vari:= last vari; + WHILE skipcount = 0 + REP skip and try PER; + j:= skipcount; + skipcount:= 0; + j = 0. + + skip and try: backtrack; + j INCR 1; + skipcount:=j; + ppos:= from + 2; + IF find pattern + THEN IF is notion (t, fixleft) + THEN LEAVE find notion WITH TRUE + FI + ELSE next; LEAVE find notion WITH FALSE + FI . + + notion variation: no vari:= FALSE; + last multi:= multi; + last vari:= vari; + FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1 + REP backtrack with variation; + IF find first subpattern + THEN no vari:= TRUE; + LEAVE find notion WITH TRUE + FI + PER; + no vari:= TRUE; + FALSE. + + find full: + find pattern CAND (end of line COR exhaust line). + + end of line: + next; + IF fix + THEN tpos = tlen + ELSE tpos:= tlen; + make fix (1); + TRUE + FI. + + exhaust line: + IF full expansion COR multi > 0 CAND no vari CAND full variation + THEN TRUE ELSE backtrack; + FALSE + FI. + + full expansion: + j:=0; + last multi:= multi; + last vari:= vari; + WHILE skipcount = 0 + REP IF tlen = tpos + THEN LEAVE full expansion WITH FALSE + FI; + backtrack; + j INCR 1; + skipcount:= j; + ppos:=from + 2 + UNTIL find pattern CAND tpos=tlen + PER; + j:= skipcount; + skipcount:=0; + j=0. + + full variation: + no vari:= FALSE; + multi:= last multi; + vari:= last vari; + FOR k FROM 1 UPTO multi + REP backtrack with variation; + IF find first subpattern + THEN no vari:= TRUE; + LEAVE find WITH TRUE + FI + PER; + no vari:= TRUE; + FALSE. + + ENDPROC find; + +BOOL PROC is notion (TEXT CONST t, INT CONST fixleft): + ppos INCR 2; + ( NOT fix + COR tpos = tlen + COR pos (delimiter, t SUB tpos) > 0 + COR pos (delimiter, t SUB tpos-1) > 0 + COR (t SUB tpos) <= "Z" + CAND (t SUB tpos-1) > "Z" ) + CAND ( fixleft <= 1 + COR pos (delimiter, t SUB fixleft-1) > 0 + COR pos (delimiter, t SUB fixleft) > 0 + COR (t SUB fixleft) > "Z" + CAND (t SUB fixleft-1) <= "Z" ) + + END PROC is notion; + +PROC make fix (INT CONST back): + WHILE stack not empty + REP INT VAR reg:= code (stack SUB top), + pos:= code (stack SUB top-1), + len:= code (stack SUB top-3), + dis:= code (stack SUB top-2) - floatpos; + maend(reg):= min (tpos + dis, tlen); (* 6.6. *) + mapos(reg):= pos or fix or float; + stack:= subtext (stack,1,top-4) + PER; + fix:= TRUE; + floatpos:= 0 . + + stack not empty: INT VAR top:= LENGTH stack; + top > 0. + + pos or fix or float: + IF pos = undefined + THEN IF len = 0 + THEN min (back + dis, tlen) + ELSE maend(reg) - len + FI + ELSE pos + FI. + + ENDPROC make fix; + +BOOL PROC in alpha (TEXT CONST t, INT CONST from, to): + FOR failpos FROM from UPTO to - 1 + REP IF pos (alphabet, t SUB failpos) = 0 + THEN LEAVE in alpha WITH FALSE + FI + PER; + TRUE + ENDPROC in alpha; + +TEXT PROC notion (TEXT CONST t, INT CONST r): notion (t) ** r ENDPROC notion; + +ENDPACKET pattern match; + diff --git a/system/base/1.7.5/src/pcb control b/system/base/1.7.5/src/pcb control new file mode 100644 index 0000000..9bf0e2d --- /dev/null +++ b/system/base/1.7.5/src/pcb control @@ -0,0 +1,79 @@ + +PACKET pcb and init control DEFINES (* Autor: J.Liedtke *) + (* Stand: 25.08.84 *) + session , + pcb , + set line nr , + clock , + INITFLAG , + := , + initialized , + storage , + id , + ke : + + +LET line number field = 1 , + myself id field = 9 ; + +TYPE INITFLAG = INT ; + + +INT PROC session : + EXTERNAL 126 +ENDPROC session ; + +INT PROC pcb (INT CONST field) : + EXTERNAL 80 +ENDPROC pcb ; + +PROC write pcb (INT CONST task nr, field, value) : + EXTERNAL 105 +ENDPROC write pcb ; + +PROC set line nr (INT CONST value) : + write pcb (pcb (myself id field), line number field, value) +ENDPROC set line nr ; + + +OP := (INITFLAG VAR flag, BOOL CONST flagtrue) : + + IF flagtrue + THEN CONCR (flag) := myself no + ELSE CONCR (flag) := 0 + FI . + +myself no : pcb (myself id field) AND 255 . + +ENDOP := ; + +BOOL PROC initialized (INITFLAG VAR flag) : + + IF CONCR (flag) = myself no + THEN TRUE + ELSE CONCR (flag) := myself no ; + FALSE + FI . + +myself no : pcb (myself id field) AND 255 . + +ENDPROC initialized ; + +REAL PROC clock (INT CONST nr) : + EXTERNAL 102 +ENDPROC clock ; + +PROC storage (INT VAR size, used) : + EXTERNAL 89 +ENDPROC storage ; + +INT PROC id (INT CONST no) : + EXTERNAL 129 +ENDPROC id ; + +PROC ke : + EXTERNAL 6 +ENDPROC ke ; + +ENDPACKET pcb and init control ; + diff --git a/system/base/1.7.5/src/real b/system/base/1.7.5/src/real new file mode 100644 index 0000000..3e3c651 --- /dev/null +++ b/system/base/1.7.5/src/real @@ -0,0 +1,442 @@ +(* ------------------- VERSION 6 05.05.86 ------------------- *) +PACKET real DEFINES (* Autor: J.Liedtke *) + + text , + int , + real , + round , + floor , + frac , + decimal exponent , + set exp , + INCR , + DECR , + abs , + ABS , + sign , + SIGN , + MOD , + min , + max , + max real , + small real : + +LET mantissa length = 13 , + digit zero index = 1 , + digit nine index = 10 ; +INT CONST + decimal point index := -1 ; + +TEXT VAR mantissa ; + +ROW 10 REAL VAR real digit ; + +INT VAR i ; REAL VAR d := 0.0 ; +FOR i FROM 1 UPTO 10 REP + real digit (i) := d ; + d := d + 1.0 +PER ; + +REAL PROC max real : 9.999999999999e126 ENDPROC max real ; + +REAL PROC small real : 1.0e-12 ENDPROC small real ; + +PROC sld (INT CONST in, REAL VAR real, INT VAR out) : + EXTERNAL 96 +ENDPROC sld ; + +INT PROC decimal exponent (REAL CONST mantissa) : + EXTERNAL 97 +ENDPROC decimal exponent ; + +PROC set exp (INT CONST exponent, REAL VAR number) : + EXTERNAL 98 +ENDPROC set exp ; + +REAL PROC tenpower (INT CONST exponent) : + REAL VAR result := 1.0 ; + set exp (exponent, result) ; + result +ENDPROC tenpower ; + +REAL PROC floor (REAL CONST real) : + EXTERNAL 99 +ENDPROC floor ; + +REAL PROC round (REAL CONST real, INT CONST digits) : + + REAL VAR result := real ; + IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length) + THEN round result ; + FI ; + result . + +round result : + set exp (decimal exponent (result) + digits, result) ; + IF result >= 0.0 + THEN result := floor (result + 0.5) + ELSE result := floor (result - 0.5) + FI ; + IF result <> 0.0 + THEN set exp (decimal exponent (result) - digits, result) + FI . + +ENDPROC round ; + +TEXT VAR result ; + +TEXT PROC text (REAL CONST real) : + + REAL VAR value := rounded to seven digits ; + IF value = 0.0 + THEN "0.0" + ELSE + process sign ; + get mantissa (value) ; + INT CONST exponent := decimal exponent (value) ; + get short mantissa ; + IF exponent > 7 OR exponent < LENGTH short mantissa - 7 + THEN scientific notation + ELSE short notation + FI + FI . + +rounded to seven digits : + round ( real * tenpower( -decimal exponent(real) ) , 6 ) + * tenpower ( decimal exponent(real) ) . + +process sign : + IF value < 0.0 + THEN result := "-" ; + value := - value + ELSE result := "" + FI . + +get short mantissa : + INT VAR i := 7 ; + WHILE (mantissa SUB i) = "0" REP + i DECR 1 + UNTIL i=1 END REP ; + TEXT CONST short mantissa := subtext (mantissa, 1, i) . + +scientific notation : + result CAT (mantissa SUB 1) ; + result CAT "." ; + result CAT subtext (mantissa, 2, 7) ; + result + "e" + text (exponent) . + +short notation : + IF exponent < 0 + THEN result + "0." + (-exponent - 1) * "0" + short mantissa + ELSE result CAT subtext (short mantissa, 1, exponent+1) ; + result CAT (exponent+1 - LENGTH short mantissa) * "0" ; + result CAT "." ; + result CAT subtext (short mantissa, exponent+2) ; + IF LENGTH short mantissa < exponent + 2 + THEN result + "0" + ELSE result + FI + FI . + +ENDPROC text ; + +PROC get mantissa (REAL CONST number) : + + REAL VAR real mantissa := number ; + mantissa := "" ; + INT VAR i , digit ; + FOR i FROM 1 UPTO mantissa length REP + sld (0, real mantissa, digit) ; + mantissa CAT code (digit + 48) + PER ; + +ENDPROC get mantissa ; + +TEXT PROC text (REAL CONST real, INT CONST length) : + + INT CONST mantissa length := min (length - 7, 13) ; + IF mantissa length > 0 + THEN construct scientific notation + ELSE result := length * "*" + FI ; + result . + +construct scientific notation : + REAL VAR value := rounded real ; + IF value = 0.0 + THEN result := subtext (" 0.0 ", 1, length) + ELSE process sign ; + process mantissa ; + process exponent + FI . + +rounded real : + round (real * tenpower ( -decimal exponent (real)) , mantissa length - 1) + * tenpower (decimal exponent (real)) . + +process sign : + IF value < 0.0 + THEN result := "-" + ELSE result := "+" + FI . + +process mantissa : + get mantissa (value) ; + result CAT (mantissa SUB 1) ; + result CAT "." ; + result CAT subtext (mantissa, 2, mantissa length) . + +process exponent : + IF decimal exponent (value) >= 0 + THEN result CAT "e+" + ELSE result CAT "e-" + FI ; + result CAT text (ABS decimal exponent (value), 3) ; + change all (result, " ", "0") . + +ENDPROC text ; + +TEXT PROC text (REAL CONST real, INT CONST length, fracs) : + + REAL VAR value := round (real, fracs) ; + INT VAR exponent := decimal exponent (value) ; + IF value = 0.0 THEN exponent := 0 FI ; + INT VAR floors := exponent + 1 , + floor length := length - fracs - 1 ; + IF value < 0.0 THEN floor length DECR 1 FI ; + + IF value too big + THEN length * "*" + ELSE transformed value + FI . + +transformed value : + process leading blanks and sign ; + get mantissa (value) ; + result CAT subtext (mantissa, 1, floors) ; + IF LENGTH mantissa < floors + THEN result CAT (floors - LENGTH mantissa) * "0" + FI ; + result CAT "." ; + IF exponent < 0 + THEN result CAT (-floors) * "0" ; + result CAT subtext (mantissa, 1, length - LENGTH result) + ELSE result CAT subtext (mantissa, floors+1, floors + fracs) + FI ; + IF LENGTH result < length + THEN result CAT (length - LENGTH result) * "0" + FI ; + result . + +process leading blanks and sign : + result := (floor length - max(floors,0)) * " " ; + IF value < 0.0 + THEN result CAT "-" ; + value := - value + FI . + +value too big : + floors > floor length . + +ENDPROC text ; + +REAL PROC real (TEXT CONST text) : + + skip leading blanks ; + sign ; + mantissa part ; + exponent ; + result . + +skip leading blanks : + INT VAR pos := 1 ; + skip blanks . + +skip blanks : + WHILE (text SUB pos) = " " REP + pos INCR 1 + PER . + +sign : + BOOL VAR negative ; + IF (text SUB pos) = "-" + THEN negative := TRUE ; + pos INCR 1 + ELIF (text SUB pos) = "+" + THEN negative := FALSE ; + pos INCR 1 + ELSE negative := FALSE + FI . + +mantissa part: + REAL VAR value ; + INT VAR exponent pos := 0 ; + get first digit ; + WHILE pos <= LENGTH text REP + digit := code (text SUB pos) - 47 ; + IF digit >= digit zero index AND digit <= digit nine index + THEN value := value * 10.0 + real digit (digit) ; + pos INCR 1 + ELIF digit = decimal point index AND exponent pos = 0 + THEN pos INCR 1 ; + exponent pos := pos + ELSE LEAVE mantissa part + FI + END REP . + +get first digit : + INT VAR digit := code (text SUB pos) - 47 ; + IF digit = decimal point index + THEN pos INCR 1 ; + exponent pos := pos ; + digit := code (text SUB pos) - 47 + FI ; + IF digit >= digit zero index AND digit <= digit nine index + THEN value := real digit (digit) ; + pos INCR 1 + ELSE set conversion (FALSE) ; + LEAVE real WITH 0.0 + FI . + +exponent : + INT VAR exp ; + IF exponent pos > 0 + THEN exp := exponent pos - pos + ELSE exp := 0 + FI ; + IF (text SUB pos) = "e" + THEN exp INCR int (subtext(text,pos+1)) + ELSE no more nonblank chars permitted + FI . + +no more nonblank chars permitted : + skip blanks ; + IF pos > LENGTH text + THEN set conversion (TRUE) + ELSE set conversion (FALSE) + FI . + +result : + value := value * tenpower (exp) ; + IF negative + THEN - value + ELSE value + FI . + +ENDPROC real ; + + +REAL PROC abs (REAL CONST value) : + + IF value >= 0.0 + THEN value + ELSE -value + FI + +ENDPROC abs ; + +REAL OP ABS (REAL CONST value) : + + abs (value) + +ENDOP ABS ; + +INT PROC sign (REAL CONST value) : + + IF value < 0.0 THEN -1 + ELIF value = 0.0 THEN 0 + ELSE 1 + FI + +ENDPROC sign ; + +INT OP SIGN (REAL CONST value) : + + sign (value) + +ENDOP SIGN ; + +REAL OP MOD (REAL CONST left, right) : + + REAL VAR result := left - floor (left/right) * right ; + IF result < 0.0 + THEN result + abs (right) + ELSE result + FI + +ENDOP MOD ; + +REAL PROC frac (REAL CONST value) : + + value - floor (value) + +ENDPROC frac ; + +REAL PROC max (REAL CONST a, b) : + + IF a > b THEN a ELSE b FI + +ENDPROC max ; + +REAL PROC min (REAL CONST a, b) : + + IF a < b THEN a ELSE b FI + +ENDPROC min ; + +OP INCR (REAL VAR dest, REAL CONST increment) : + + dest := dest + increment + +ENDOP INCR ; + +OP DECR (REAL VAR dest, REAL CONST decrement) : + + dest := dest - decrement + +ENDOP DECR ; + +INT PROC int (REAL CONST value) : + + IF value = minint value + THEN minint + ELSE compute int result ; + IF value < 0.0 + THEN - result + ELSE result + FI + FI . + +compute int result : + INT VAR result := 0, digit ,i ; + REAL VAR mantissa := value ; + + FOR i FROM 0 UPTO decimal exponent (value) REP + sld (0, mantissa, digit) ; + result := result * 10 + digit + PER . + +minint value : - 32768.0 . +minint : - 32767 - 1 . + +ENDPROC int ; + +REAL PROC real (INT CONST value) : + + IF value < 0 + THEN - real (-value) + ELIF value < 10 + THEN real digit (value+1) + ELSE split value into head and last digit ; + real (head) * 10.0 + real digit (last digit+1) + FI . + +split value into head and last digit : + INT CONST + head := value DIV 10 , + last digit := value - head * 10 . + +ENDPROC real ; + +ENDPACKET real ; + diff --git a/system/base/1.7.5/src/scanner b/system/base/1.7.5/src/scanner new file mode 100644 index 0000000..35a632c --- /dev/null +++ b/system/base/1.7.5/src/scanner @@ -0,0 +1,325 @@ +(* ------------------- VERSION 4 14.05.86 ------------------- *) +PACKET scanner DEFINES (* Autor: J.Liedtke *) + + scan , + continue scan , + next symbol : + + +LET tag = 1 , + bold = 2 , + number = 3 , + text = 4 , + operator= 5 , + delimiter = 6 , + end of file = 7 , + within comment = 8 , + within text = 9 ; + +LET digit 0 = 48 , + digit 9 = 57 , + upper case a = 65 , + upper case z = 90 , + lower case a = 97 , + lower case z = 122; + + +TEXT VAR line := "" , + char := "" , + chars:= "" ; + +INT VAR position := 0 , + comment depth ; +BOOL VAR continue text ; + + +PROC scan (TEXT CONST scan text) : + + comment depth := 0 ; + continue text := FALSE ; + continue scan (scan text) + +ENDPROC scan ; + +PROC continue scan (TEXT CONST scan text) : + + line := scan text ; + position := 0 ; + nextchar + +ENDPROC continue scan ; + +PROC next symbol (TEXT VAR symbol) : + + INT VAR type ; + next symbol (symbol, type) + +ENDPROC next symbol ; + +PROC next symbol (TEXT VAR symbol, INT VAR type) : + + skip blanks ; + IF is begin comment THEN process comment + ELIF comment depth > 0 THEN comment depth DECR 1 ; + process comment + ELIF is quote OR continue text THEN process text + ELIF is lower case letter THEN process tag + ELIF is upper case letter THEN process bold + ELIF is digit THEN process number + ELIF is delimiter THEN process delimiter + ELIF is niltext THEN eof + ELSE process operator + FI . + + +process comment : + read comment ; + IF comment depth = 0 + THEN next symbol (symbol, type) + ELSE type := within comment ; + symbol := "" + FI . + +process tag : + type := tag ; + assemble chars (lower case a, lower case z) ; + symbol := chars ; + REP + skip blanks ; + IF is lower case letter + THEN assemble chars (lower case a, lower case z) + ELIF is digit + THEN assemble chars (digit 0, digit 9) + ELSE LEAVE process tag + FI ; + symbol CAT chars + PER ; + nextchar . + +process bold : + type := bold ; + assemble chars (upper case a, upper case z) ; + symbol := chars . + +process number : + type := number ; + assemble chars (digit 0, digit 9) ; + symbol := chars ; + IF char = "." AND ahead char is digit + THEN process fraction ; + IF char = "e" + THEN process exponent + FI + FI . + +ahead char is digit : + digit 0 <= code (ahead char) AND code (ahead char) <= digit 9 . + +process fraction : + symbol CAT char ; + nextchar ; + assemble chars (digit 0, digit 9) ; + symbol CAT chars . + +process exponent : + symbol CAT char ; + nextchar ; + IF char = "+" OR char = "-" + THEN symbol CAT char ; + nextchar + FI ; + assemble chars (digit 0, digit 9) ; + symbol CAT chars . + +process text : + type := text ; + symbol := "" ; + IF continue text + THEN continue text := FALSE + ELSE next char + FI ; + WHILE not end of text REP + assemble chars (35, 254) ; + symbol CAT chars ; + IF NOT is quote + THEN symbol CAT char ; + nextchar + FI + ENDREP . + +not end of text : + IF is niltext + THEN continue text := TRUE ; type := within text ; FALSE + ELIF is quote + THEN end of text or exception + ELSE TRUE + FI . + +end of text or exception : + next char ; + IF is quote + THEN get quote ; TRUE + ELIF is digit + THEN get special char ; TRUE + ELSE FALSE + FI . + +get quote : + symbol CAT char ; + nextchar . + +get special char : + assemble chars (digit 0, digit 9) ; + symbol CAT code (int (chars) ) ; + nextchar . + +process delimiter : + type := delimiter ; + symbol := char ; + nextchar . + +process operator : + type := operator ; + symbol := char ; + nextchar ; + IF symbol = ":" + THEN IF char = "=" OR char = ":" + THEN symbol := ":=" ; + nextchar + ELSE type := delimiter + FI + ELIF is relational double char + THEN symbol CAT char ; + nextchar + ELIF symbol = "*" AND char = "*" + THEN symbol := "**" ; + next char + FI . + +eof : + type := end of file ; + symbol := "" . + +is lower case letter : + lower case a <= code (char) AND code (char) <= lower case z . + +is upper case letter : + upper case a <= code (char) AND code (char) <= upper case z . + +is digit : + digit 0 <= code (char) AND code (char) <= digit 9 . + +is delimiter : pos ( "()[].,;" , char ) > 0 . + +is relational double char : + TEXT VAR double := symbol + char ; + double = "<>" OR double = "<=" OR double = ">=" . + +is quote : char = """" . + +is niltext : char = "" . + +is begin comment : char = "{" OR char = "(" AND ahead char = "*" . + +ENDPROC next symbol ; + +PROC next char : + + position INCR 1 ; + char := line SUB position + +ENDPROC next char ; + +PROC skip blanks : + + position := pos (line, ""33"", ""254"", position) ; + IF position = 0 + THEN position := LENGTH line + 1 + FI ; + char := line SUB position . + +ENDPROC skip blanks ; + +TEXT PROC ahead char : + + line SUB position+1 + +ENDPROC ahead char ; + +PROC assemble chars (INT CONST low, high) : + + INT CONST begin := position ; + position behind valid text ; + chars := subtext (line, begin, position-1) ; + char := line SUB position . + +position behind valid text : + position := pos (line, ""32"", code (low-1), begin) ; + IF position = 0 + THEN position := LENGTH line + 1 + FI ; + INT CONST higher pos := pos (line, code (high+1), ""254"", begin) ; + IF higher pos <> 0 AND higher pos < position + THEN position := higher pos + FI . + +ENDPROC assemble chars ; + + +PROC read comment : + + TEXT VAR last char ; + comment depth INCR 1 ; + REP + last char := char ; + nextchar ; + IF is begin comment + THEN read comment + FI ; + IF char = "" + THEN LEAVE read comment + FI + UNTIL is end comment PER ; + comment depth DECR 1 ; + next char ; + skip blanks . + +is end comment : + char = "}" OR char = ")" AND last char = "*" . + +is begin comment : + char = "{" OR char = "(" AND ahead char = "*" . + +ENDPROC read comment ; + + +PROC scan (FILE VAR f) : + + getline (f, line) ; + scan (line) + +ENDPROC scan ; + +PROC next symbol (FILE VAR f, TEXT VAR symbol) : + + INT VAR type ; + next symbol (f, symbol, type) + +ENDPROC next symbol ; + +TEXT VAR scanned ; + +PROC next symbol (FILE VAR f, TEXT VAR symbol, INT VAR type) : + + next symbol (symbol, type) ; + WHILE type >= 7 AND NOT eof (f) REP + getline (f, line) ; + continue scan (line) ; + next symbol (scanned, type) ; + symbol CAT scanned + PER . + +ENDPROC next symbol ; + +ENDPACKET scanner ; + diff --git a/system/base/1.7.5/src/screen b/system/base/1.7.5/src/screen new file mode 100644 index 0000000..7e64961 --- /dev/null +++ b/system/base/1.7.5/src/screen @@ -0,0 +1,33 @@ + +PACKET screen description DEFINES + + xsize, ysize, marksize, mark refresh line mode : + + +INT VAR xs := 80, ys := 24, ms := 1; + +INT PROC xsize: xs END PROC xsize; + +INT PROC ysize: ys END PROC ysize; + +INT PROC marksize: ms END PROC marksize; + +PROC xsize (INT CONST i): xs := i END PROC xsize; + +PROC ysize (INT CONST i): ys := i END PROC ysize; + +PROC marksize (INT CONST i): ms := i END PROC marksize; + + +BOOL VAR line mode := FALSE; + +BOOL PROC mark refresh line mode: + line mode +END PROC mark refresh line mode; + +PROC mark refresh line mode (BOOL CONST b): + line mode := b +END PROC mark refresh line mode; + +END PACKET screen description ; + diff --git a/system/base/1.7.5/src/std transput b/system/base/1.7.5/src/std transput new file mode 100644 index 0000000..94c51db --- /dev/null +++ b/system/base/1.7.5/src/std transput @@ -0,0 +1,264 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PACKET std transput DEFINES + + sysout , + sysin , + put , + putline , + line , + page , + write , + get , + getline , + get secret line : + + +LET cr = ""13"" , + cr lf = ""13""10"" , + home clear = ""1""4"" , + esc = ""27"" , + rubout = ""12"" , + bell = ""7"" , + back blank back = ""8" "8"" , + del line cr lf = ""5""13""10"" ; + +TEXT VAR number word , exit char ; + +BOOL VAR console output := TRUE, console input := TRUE ; + +FILE VAR outfile, infile ; +TEXT VAR outfile name := "", infile name := "" ; + + +PROC sysout (TEXT CONST file name) : + + outfile name := file name ; + IF file name = "" + THEN console output := TRUE + ELSE outfile := sequential file (output, file name) ; + console output := FALSE + FI + +ENDPROC sysout ; + +TEXT PROC sysout : + outfile name +ENDPROC sysout ; + +PROC sysin (TEXT CONST file name) : + + infile name := file name ; + IF file name = "" + THEN console input := TRUE + ELSE infile := sequential file (input, file name) ; + console input := FALSE + FI + +ENDPROC sysin ; + +TEXT PROC sysin : + infile name +ENDPROC sysin ; + + +PROC put (TEXT CONST word) : + + IF console output + THEN out (word) ; out (" ") + ELSE put (outfile, word) + FI + +ENDPROC put ; + +PROC put (INT CONST number) : + + put (text (number)) + +ENDPROC put ; + +PROC put (REAL CONST number) : + + put (text (number)) + +ENDPROC put ; + +PROC putline (TEXT CONST textline) : + + IF console output + THEN out (textline) ; out (cr lf) + ELSE putline (outfile, textline) + FI + +ENDPROC putline ; + +PROC line : + + IF console output + THEN out (cr lf) + ELSE line (outfile) + FI + +ENDPROC line ; + +PROC line (INT CONST times) : + + INT VAR i ; + FOR i FROM 1 UPTO times REP + line + PER + +ENDPROC line ; + +PROC page : + + IF console output + THEN out (home clear) + FI + +ENDPROC page ; + +PROC write (TEXT CONST word) : + + IF console output + THEN out (word) + ELSE write (outfile, word) + FI + +ENDPROC write ; + + +PROC get (TEXT VAR word) : + + IF console input + THEN get from console + ELSE get (infile, word) + FI . + +get from console : + REP + word := "" ; + editget (word, " ", "", exit char) ; + echoe exit char + UNTIL word <> "" AND word <> " " PER ; + delete leading blanks . + +delete leading blanks : + WHILE (word SUB 1) = " " REP + word := subtext (word,2) + PER . + +ENDPROC get ; + +PROC get (TEXT VAR word, TEXT CONST separator) : + + IF console input + THEN get from console + ELSE get (infile, word, separator) + FI . + +get from console : + word := "" ; + editget (word, separator, "", exit char) ; + echoe exit char . + +ENDPROC get ; + +PROC echoe exit char : + + IF exit char = ""13"" + THEN out (""13""10"") + ELSE out (exit char) + FI + +ENDPROC echoe exit char ; + +PROC get (INT VAR number) : + + get (number word) ; + number := int (number word) + +ENDPROC get ; + +PROC get (REAL VAR number) : + + get (number word) ; + number := real (number word) + +ENDPROC get ; + +PROC get (TEXT VAR word, INT CONST length) : + + IF console input + THEN get from console + ELSE get (infile, word, length) + FI . + +get from console : + word := "" ; + editget (word, length, exit char) ; + echoe exit char . + +ENDPROC get ; + +PROC getline (TEXT VAR textline) : + + IF console input + THEN get from console + ELSE getline (infile, textline) + FI . + +get from console : + textline := "" ; + editget (textline, "", "", exit char) ; + echoe exit char + +ENDPROC getline ; + +PROC get secret line (TEXT VAR textline) : + + TEXT VAR char ; + textline := "" ; + get start cursor position ; + get line very secret ; + IF char = esc + THEN get line little secret + FI ; + cursor to start position ; + out (del line cr lf) . + +get line very secret : + REP + inchar (char) ; + IF char = esc OR char = cr + THEN LEAVE get line very secret + ELIF char = rubout + THEN delete last char + ELIF char >= " " + THEN textline CAT char ; + out (".") + ELSE out (bell) + FI + PER . + +delete last char : + IF LENGTH textline = 0 + THEN out (bell) + ELSE out (back blank back) ; + delete char (textline, LENGTH textline) + FI . + +get line little secret : + cursor to start position ; + editget (textline, "", "", exit char) . + +get start cursor position : + INT VAR x, y; + get cursor (x, y) . + +cursor to start position : + cursor (x, y) . + +ENDPROC get secret line ; + +ENDPACKET std transput ; + diff --git a/system/base/1.7.5/src/tasten b/system/base/1.7.5/src/tasten new file mode 100644 index 0000000..752303b --- /dev/null +++ b/system/base/1.7.5/src/tasten @@ -0,0 +1,113 @@ + +PACKET tasten verwaltung DEFINES (* #009 *) + (***************) + + lernsequenz auf taste legen, + lernsequenz auf taste, + kommando auf taste legen, + kommando auf taste, + taste enthaelt kommando, + std tastenbelegung : + + + +LET kommandoidentifikation = ""0"" , + esc = ""27"" , + niltext = "" , + hop right left up down cr tab rubin rubout mark esc + = ""1""2""8""3""10""13""9""11""12""16""27"" ; + + +ROW 256 TEXT VAR belegung; +INT VAR i; FOR i FROM 1 UPTO 256 REP belegung (i) := "" PER; + +std tastenbelegung; + + +PROC lernsequenz auf taste legen (TEXT CONST taste, lernsequenz) : + + belege (belegung (code (taste) + 1), taste, lernsequenz) + +ENDPROC lernsequenz auf taste legen ; + +PROC belege (TEXT VAR tastenpuffer, TEXT CONST taste, lernsequenz) : + tastenpuffer := lernsequenz ; + verhindere rekursives lernen . + +verhindere rekursives lernen : + loesche alle folgen esc taste aber nicht esc esc taste ; + IF taste ist freies sonderzeichen + THEN change all (tastenpuffer, taste, niltext) + FI . + +loesche alle folgen esc taste aber nicht esc esc taste : + INT VAR i := pos (tastenpuffer, esc + taste) ; + WHILE i > 0 REP + IF ist esc esc taste + THEN i INCR 1 + ELSE change (tastenpuffer, i, i+1, niltext) + FI ; + i := pos (tastenpuffer, esc + taste, i) + PER . + +ist esc esc taste : + (tastenpuffer SUB i-1) = esc AND (tastenpuffer SUB i-2) <> esc . + +taste ist freies sonderzeichen : + taste < ""32"" AND + pos (hop right left up down cr tab rubin rubout mark esc, taste) = 0 . + +END PROC belege ; + + +TEXT PROC lernsequenz auf taste (TEXT CONST taste) : + IF taste enthaelt kommando (taste) + THEN "" + ELSE belegung (code (taste) + 1) + FI +END PROC lernsequenz auf taste; + + +PROC kommando auf taste legen (TEXT CONST taste, kommando) : + + belegung (code (taste) + 1) := kommandoidentifikation; + belegung (code (taste) + 1) CAT kommando + +END PROC kommando auf taste legen; + + +TEXT PROC kommando auf taste (TEXT CONST taste) : + IF taste enthaelt kommando (taste) + THEN subtext (belegung (code (taste) + 1), 2) + ELSE "" + FI +END PROC kommando auf taste; + + +BOOL PROC taste enthaelt kommando (TEXT CONST taste) : + (belegung (code (taste) + 1) SUB 1) = kommandoidentifikation +END PROC taste enthaelt kommando; + + +PROC std tastenbelegung: + lernsequenz auf taste legen ("(", ""91""); + lernsequenz auf taste legen (")", ""93""); + lernsequenz auf taste legen ("<", ""123""); + lernsequenz auf taste legen (">", ""125""); + lernsequenz auf taste legen ("A", ""214""); + lernsequenz auf taste legen ("O", ""215""); + lernsequenz auf taste legen ("U", ""216""); + lernsequenz auf taste legen ("a", ""217""); + lernsequenz auf taste legen ("o", ""218""); + lernsequenz auf taste legen ("u", ""219""); + lernsequenz auf taste legen ("k", ""220""); + lernsequenz auf taste legen ("-", ""221""); + lernsequenz auf taste legen ("#", ""222""); + ler�sequenz auf taste legen (" ", ""223""); + lernsequenz auf taste legen ("B", ""251""); + lernsequenz auf taste legen ("s", ""251""); +END PROC std tastenbelegung; + + +END PACKET tasten verwaltung; + diff --git a/system/base/1.7.5/src/text b/system/base/1.7.5/src/text new file mode 100644 index 0000000..4c659cf --- /dev/null +++ b/system/base/1.7.5/src/text @@ -0,0 +1,391 @@ +(* ------------------- VERSION 3 06.03.86 ------------------- *) +PACKET text DEFINES + + max text length , + SUB , + subtext , + text , + length , LENGTH , + CAT , + + , + * , + replace , + change , + change all , + compress , + pos , + code , + ISUB , + RSUB , + delete char , + insert char , + delete int , + insert int , + heap size , + collect heap garbage , + stranalyze , + LEXEQUAL , + LEXGREATER , + LEXGREATEREQUAL : + + + +TEXT VAR text buffer , tail buffer ; + +INT CONST max text length := 32000 ; + +TEXT OP SUB (TEXT CONST text, INT CONST pos ) : + EXTERNAL 48 +END OP SUB ; + +TEXT PROC subtext (TEXT CONST source, INT CONST from, to ): + EXTERNAL 49 +ENDPROC subtext ; + +TEXT PROC subtext (TEXT CONST source, INT CONST from ) : + EXTERNAL 50 +ENDPROC subtext ; + +INT PROC code (TEXT CONST text) : + EXTERNAL 46 +END PROC code ; + +TEXT PROC code (INT CONST code) : + EXTERNAL 47 +ENDPROC code ; + +INT OP ISUB (TEXT CONST text, INT CONST index) : + EXTERNAL 44 +ENDOP ISUB ; + +PROC replace (TEXT VAR text, INT CONST index, value) : + EXTERNAL 45 +ENDPROC replace ; + +REAL OP RSUB (TEXT CONST text, INT CONST index) : + EXTERNAL 100 +ENDOP RSUB ; + +PROC replace (TEXT VAR text, INT CONST index, REAL CONST code) : + EXTERNAL 101 +ENDPROC replace ; + + +PROC replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) : + EXTERNAL 51 +ENDPROC replace ; + +TEXT PROC text (TEXT CONST source, INT CONST length ) : + + IF length < LENGTH source + THEN text buffer := subtext (source,1,length) + ELSE text buffer := source ; + mit blanks auffuellen + FI ; + text buffer . + +mit blanks auffuellen : + INT VAR i ; + FOR i FROM 1 UPTO length - LENGTH source REP + text buffer CAT " " + PER . + +ENDPROC text ; + +TEXT PROC text (TEXT CONST source, INT CONST length, from) : + text ( subtext (source, from) , length ) +ENDPROC text ; + +OP CAT (TEXT VAR right, TEXT CONST left ) : + EXTERNAL 52 +ENDOP CAT ; + +TEXT OP + (TEXT CONST left, right) : + text buffer := left ; + text buffer CAT right ; + text buffer +ENDOP + ; + +TEXT OP * (INT CONST times, TEXT CONST source ) : + + text buffer := "" ; + INT VAR i ; + FOR i FROM 1 UPTO times REP + text buffer CAT source + PER ; + text buffer + +ENDOP * ; + +INT PROC length (TEXT CONST text ) : + EXTERNAL 53 +ENDPROC length ; + +INT OP LENGTH (TEXT CONST text ) : + EXTERNAL 53 +ENDOP LENGTH ; + +INT PROC pos (TEXT CONST source, pattern) : + EXTERNAL 54 +ENDPROC pos ; + +INT PROC pos (TEXT CONST source, pattern, INT CONST from) : + EXTERNAL 55 +ENDPROC pos ; + +INT PROC pos (TEXT CONST source, pattern, INT CONST from, to) : + EXTERNAL 56 +ENDPROC pos ; + +INT PROC pos (TEXT CONST source, low, high, INT CONST from) : + EXTERNAL 58 +ENDPROC pos ; + +TEXT PROC compress (TEXT CONST text) : + + INT VAR begin, end ; + + search first non blank ; + search last non blank ; + text buffer := subtext (text, begin, end) ; + text buffer . + +search first non blank : + begin := 1 ; + WHILE (text SUB begin) = " " REP + begin INCR 1 + PER . + +search last non blank : + end := LENGTH text ; + WHILE (text SUB end) = " " REP + end DECR 1 + PER . + +ENDPROC compress ; + +PROC change (TEXT VAR destination, INT CONST from, to, TEXT CONST new) : + + IF LENGTH new = to - from + 1 AND to <= LENGTH destination + THEN replace (destination, from, new) + ELSE change via buffer + FI . + +change via buffer : + text buffer := subtext (destination, 1, from-1) ; + text buffer CAT new ; + tail buffer := subtext (destination, to + 1) ; + text buffer CAT tail buffer ; + destination := text buffer + +ENDPROC change ; + +PROC change (TEXT VAR destination, TEXT CONST old, new) : + + INT CONST position := pos (destination, old) ; + IF position > 0 + THEN change (destination, position, position + LENGTH old -1, new) + FI + +ENDPROC change ; + +PROC change all (TEXT VAR destination, TEXT CONST old, new) : + + INT VAR position := pos (destination, old) ; + IF LENGTH old = LENGTH new + THEN change by replace + ELSE change by change + FI . + +change by replace : + WHILE position > 0 REP + replace (destination, position, new) ; + position := pos (destination, old, position + LENGTH new) + PER . + +change by change : + WHILE position > 0 REP + change (destination, position, position + LENGTH old - 1 , new) ; + position := pos (destination, old, position + LENGTH new) + PER . + +ENDPROC change all ; + +PROC delete char (TEXT VAR string, INT CONST delete pos) : + + IF delete pos > 0 + THEN tail buffer := subtext (string, delete pos + 1) ; + string := subtext (string, 1, delete pos - 1) ; + string CAT tail buffer + FI + +END PROC delete char ; + +PROC insert char (TEXT VAR string, TEXT CONST char, + INT CONST insert pos) : + + IF insert pos > 0 AND insert pos <= LENGTH string + 1 + THEN tail buffer := subtext (string, insert pos) ; + string := subtext (string, 1, insert pos - 1) ; + string CAT char ; + string CAT tail buffer + FI + +END PROC insert char ; + +INT PROC heap size : + EXTERNAL 93 +ENDPROC heap size ; + +PROC collect heap garbage : + EXTERNAL 94 +ENDPROC collect heap garbage ; + +PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum, + TEXT CONST string, INT VAR index, INT CONST to, + INT VAR exit code) : + EXTERNAL 57 +ENDPROC stranalyze ; + +(*******************************************************************) +(* lexikographische Vergleiche *) +(* Nach DIN 5007, Abschnitt 1 und Abschnitt 3.2 (Bindestrich) *) +(* Autor: Rainer Hahn, Jochen Liedtke *) +(* Stand: 1.7.4 (Jan. 1985) *) +(*******************************************************************) +LET first umlaut = ""214"" , + umlauts = ""214""215""216""217""218""219""251"" ; + + +TEXT VAR left letter, right letter; + +BOOL OP LEXEQUAL (TEXT CONST left, right) : + + compare (left, right) ; + left letter = right letter + +ENDOP LEXEQUAL ; + +BOOL OP LEXGREATER (TEXT CONST left, right) : + + compare (left, right) ; + left letter > right letter + +ENDOP LEXGREATER ; + +BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) : + + compare (left, right) ; + left letter >= right letter + +ENDOP LEXGREATEREQUAL ; + +PROC compare (TEXT CONST left, right) : + + to begin of lex relevant text ; + REP + get left letter ; + get right letter + UNTIL NOT letter match OR both ended PER . + +to begin of lex relevant text : + INT VAR + left pos := pos (left, ""65"",""254"", 1) , + right pos := pos (right,""65"",""254"", 1) ; + IF left pos = 0 + THEN left pos := LENGTH left + 1 + FI ; + IF right pos = 0 + THEN right pos := LENGTH right + 1 + FI . + +get left letter : + left letter := left SUB left pos ; + left pos INCR 1 . + +get right letter : + right letter := right SUB right pos ; + right pos INCR 1 . + +letter match : + IF left letter = right letter + THEN TRUE + ELSE dine (left, left letter, left pos) ; + dine (right, right letter, right pos) ; + IF exactly one letter is double letter + THEN expand other letter + FI ; + left letter = right letter + FI . + +exactly one letter is double letter : + LENGTH left letter <> LENGTH right letter. + +expand other letter : + IF LENGTH left letter = 1 + THEN left letter CAT (left SUB left pos) ; + left pos INCR 1 + ELSE right letter CAT (right SUB right pos) ; + right pos INCR 1 + FI . + +both ended : left letter = "" . + +ENDPROC compare ; + +PROC dine (TEXT CONST string, TEXT VAR char, INT VAR string pos) : + + skip non letter chars ; + IF is capital letter + THEN translate to small letter + ELIF char >= first umlaut + THEN translate umlaut + FI . + +skip non letter chars : + WHILE NOT (is letter OR end of string) REP + char := string SUB string pos ; + string pos INCR 1 + PER . + +translate to small letter : + char := code (code (char) + 32) . + +translate umlaut : + SELECT pos (umlauts, char) OF + CASE 1,4 : char := "ae" + CASE 2,5 : char := "oe" + CASE 3,6 : char := "ue" + CASE 7 : char := "ss" + ENDSELECT . + +is capital letter : + INT VAR char code := code (char) ; + 65 <= char code AND char code <= 90 . + +is letter : + char code := code (char) OR 32 ; + (97 <= char code AND char code <= 122) OR char code >= 128 . + +end of string : char = "" . + +ENDPROC dine ; + +OP CAT (TEXT VAR result, INT CONST number) : + result CAT " "; + replace (result, LENGTH result DIV 2, number); +END OP CAT; + +PROC insert int (TEXT VAR result, INT CONST insert pos, number) : + INT VAR pos := insert pos * 2 - 1; + change (result, pos, pos - 1, " "); + replace (result, insert pos, number); +END PROC insert int; + +PROC delete int (TEXT VAR result, INT CONST delete pos) : + INT VAR pos := delete pos * 2; + change (result, pos - 1, pos, "") +END PROC delete int; + +ENDPACKET text ; + diff --git a/system/base/1.7.5/src/texter errors b/system/base/1.7.5/src/texter errors new file mode 100644 index 0000000..9c4383d --- /dev/null +++ b/system/base/1.7.5/src/texter errors @@ -0,0 +1,284 @@ +(* ------------------- VERSION 66 vom 06.03.86 -------------------- *) +PACKET texter errors and common DEFINES + only command line, + skip input, + char pos move, + begin of this char, + number chars, + display and pause, + report text processing error, + report text processing warning: + +(* Programm zur zentralen Haltung aller Fehlermeldungen der Textkosmetik + Autor: Rainer Hahn + Stand: 1.7.1 Febr. 1984 + 1.7.3 Juli " + 1.7.4 Febr. 1985 + *) + +LET escape = ""27""; + +TEXT VAR fehlerdummy; + +BOOL PROC only command line (TEXT CONST zeile): +INT VAR anfang, ende; +LET kommando zeichen = "#"; + IF pos (zeile, kommando zeichen) = 1 + THEN ende := pos (zeile, kommando zeichen, 2); + IF ende > 0 + THEN zaehle kommandos durch; + LEAVE only command line WITH richtiges kommandoende + FI + FI; + FALSE. + +zaehle kommandos durch: + WHILE ende + 1 = pos (zeile, kommando zeichen, ende +1) REP + anfang := pos (zeile, kommando zeichen, ende + 1); + ende := pos (zeile, kommando zeichen, anfang + 1) + END REP. + +richtiges kommandoende: + ende > 0 AND + (ende = length (zeile) OR (ende = length (zeile) - 1 AND absatzzeile)). + +absatzzeile: + (zeile SUB length (zeile)) = " ". +END PROC only command line; + +PROC skip input: + REP + TEXT CONST zeichen :: incharety; + IF zeichen = escape + THEN errorstop ("Abbruch durch ESC") + FI + UNTIL zeichen = "" END REP +END PROC skip input; + +PROC char pos move (TEXT CONST ein text, INT VAR zpos, INT CONST richtung): + zpos INCR richtung; + IF within kanji (ein text, zpos) + THEN zpos INCR richtung + FI +END PROC char pos move; + +PROC begin of this char (TEXT CONST ein text, INT VAR zpos): + IF zpos < 1 OR zpos > length (ein text) + THEN display and pause (7) + ELSE suche zeichenposition + FI. + +suche zeichenposition: + IF within kanji (ein text, zpos) + THEN zpos DECR 1 + FI. +END PROC begin of this char; + +INT PROC number chars (TEXT CONST ein text, INT CONST von pos, bis pos): + INT VAR index :: von pos, anz :: 0; + WHILE index <= bis pos REP + IF index > length (ein text) OR index > bis pos + THEN display and pause (5); LEAVE number chars WITH 0 + FI; + IF is kanji esc (ein text SUB index) + THEN index INCR 2 + ELSE index INCR 1 + FI; + anz INCR 1 + END REP; + anz +END PROC number chars; + +PROC display and pause (INT CONST nr): + line ; put ("LINER ERROR"); put (nr); pause +END PROC display and pause; + +PROC report text processing error (INT CONST error nr, + INT CONST line nr, + TEXT VAR message, + TEXT CONST addition): + + einfache meldung aufbauen; + meldung in fehlerdatei ausgeben. + +einfache meldung aufbauen: + message := "FEHLER Zeile "; + message CAT text (line nr); + message CAT ": "; + message CAT simple message; + message CAT " "; + message CAT addition. + +meldung in fehlerdatei ausgeben: + note (message); + note line; + fehlerdummy := " >>> "; + fehlerdummy CAT zusatz; + note (fehlerdummy); + note line. + +simple message: + SELECT error nr OF + CASE 1: "Unbekannter Schriftyp ignoriert:" + CASE 2: "#-Zeichen fehlt" + CASE 3: "foot in Fußnote (ignoriert)" + CASE 4: "cm-Angabe fehlt (REAL) (ignoriert):" + CASE 5: "INT-Parameter erwartet (ignoriert):" + CASE 6: "(versuchte) Trennung in Macro-Text" + CASE 7: "ie-Anweisung fehlt bei Seitenende" + CASE 8: "Unbekannte Anweisung (ignoriert):" + CASE 9: "Nicht kompilierbares Programm:" + CASE 10: "Einrückung (Leerzeichen am Zeilenanfang) zu groß" + CASE 11: "Anweisung hier nicht erlaubt (ignoriert):" + CASE 12: "Tabellen-Position liegt innerhalb eines b pos:" + CASE 13: "free-Wert > Textteil der Seite (ignoriert)" + CASE 14: "Mehr als 1 Zeichen in pagenr (ignoriert)" + CASE 15: "Macro innerhalb eines Macros definiert (ignoriert):" + CASE 16: "Mehr als drei Seitenzeichen" + CASE 17: "Mehr als zehn Zeilen im Index" + CASE 18: "Index Parameter inkorrekt (ignoriert): " + CASE 19: "Hinter Anweisung darf nichts mehr stehen (ignoriert):" + CASE 20: "Doppelter Index ignoriert:" + CASE 21: "ib(..) fehlt:" + CASE 22: "Inkorrekte Anweisung:" + CASE 23: "2 Byte Zeichen ohne zweites Zeichen am Zeilenende" + CASE 24: "free-Wert größer Seitenlänge (ignoriert):" + CASE 25: "Seitenende in head, bottom oder foot-Bereich plaziert" + CASE 26: "Anzahl columns < 2 ignoriert" + CASE 27: "INT-Parameter <= 0 ignoriert:" + CASE 28: "Kein Textzeichen vor oder hinter b" + CASE 29: "Nochmaliges columns ohne columns end (ignoriert)" + CASE 30: "set count-Parameter inkorrekt (ignoriert):" + CASE 31: "end ohne vorangehendes head, bottom oder foot" + CASE 32: "Max. Anzahl von Tabellen-Positionen überschritten" + CASE 33: "Macro-Aufruf oder -Definition in einem Macro (ignoriert):" + CASE 34: "counter nicht initialisiert (ignoriert):" + CASE 35: "store counter Kennung bereits vorhanden (ignoriert):" + CASE 36: "Spaltenbreite > limit" + CASE 37: "Zentimeter-Angabe in limit = 0 (ignoriert)" + CASE 38: "Zentimeter-Angabe inkorrekt (ignoriert):" + CASE 39: "Zentimeter-Angabe > als eingestelltes limit (ignoriert):" + CASE 40: "Makro-Definition (ignoriert):" + CASE 41: "Nochmaliges table ohne table end (ignoriert)" + CASE 42: "pos bereits hier gesetzt (ignoriert):" + CASE 43: "Druckposition (pos) nicht vorhanden:" + CASE 44: "Text breiter als Spalte bei:" + CASE 45: "rpos überschreibt vorherige Spalte bei:" + CASE 46: "cpos überschreibt vorherige Spalte bei:" + CASE 47: "dpos überschreibt vorherige Spalte bei:" + CASE 48: "Geblockter Text breiter als Spalte bei:" + CASE 49: "table end fehlt" + CASE 50: "Zentrierzeichen für dpos fehlt bei:" + CASE 51: "e-Anweisung ohne vorangehendes d oder u" + CASE 52: "fehlendes e auf dieser Zeile" + CASE 53: "Wort mit Exponent oder Index zu lang" + CASE 54: "Modifikation bereits angeschaltet bei on:" + CASE 55: "Modifikation nicht angeschaltet bei off:" + CASE 56: "Index bereits angeschaltet bei ib:" + CASE 57: "Index nicht angeschaltet bei ie:" + CASE 58: "Inkorrekte direkte Drucker-Anweisung (TEXT-Denoter):" + CASE 59: "tableend ohne vorangehendes table" + CASE 60: "put counter fehlt für:" + CASE 61: "store counter fehlt für:" + OTHERWISE "" + ENDSELECT. + +zusatz: + SELECT error nr OF + CASE 1: "type-Anweisung korrigieren" + CASE 2: "Bitte Einfügen" + CASE 3: "Geschachtelte Fußnoten sind nicht möglich" + CASE 4: "Beispiel: limit(16.0)" + CASE 5: "Beispiele: page(4), pagenr(""%"",4)" + CASE 6: "Trennung erscheint nicht im Ausdruck!" + CASE 7: "Index in Indexdatei ggf. vervollständigen" + CASE 10: "für Zeilenbreite (limit): Leerzeichen entfernen" + CASE 11: "(In head-, bottom- und foot-Bereichen)" + CASE 13: "Parameterwert verkleinern" + CASE 14: "Beispiel: pagenr(""$"",5)" + CASE 15: "Macros kontrollieren und ggf. neu laden" + CASE 16: "sind z.Z. nicht zugelassen" + CASE 17: "ie(..) vergessen?" + CASE 18: "1.Parameter gibt die Index-Nummer (1-10) an. Beispiel: ie(9)" + CASE 19: "Anweisung muß alleine oder am Zeilenende stehen" + CASE 24: "in einem head, bottom oder foot-Bereich" + CASE 25: "Vor oder hinter den Bereich plazieren" + CASE 26: "1.Parameter in columns korrigieren" + CASE 27: "Beispiel: page(20)" + CASE 29: "page und columnsend vorher einfügen" + CASE 30: "Beispiele: setcount(0); setcount(27)" + CASE 31: "end ggf. entfernen" + CASE 34: "Bitte set counter einfuegen" + CASE 37: "Muß positiv sein" + CASE 38: "Beispiel: limit(16.0)" + CASE 40: "pos-Anweisungen vor table plazieren" + CASE 41: "tableend vergessen?" + CASE 42: "Bitte pos-Anweisungen überprüfen" + CASE 43: "in clear pos-Anweisung" + CASE 48: "Ggf. lineform über die Spalte" + CASE 49: "Bitte vor Dateiende einfügen" + CASE 51, 52: "Bitte u und d-Anweisungen kontrollieren" + CASE 53: "e-Anweisung vergessen?" + CASE 54, 55, 56, 57: "Anweisung in angegebener Zeilennummer überprüfen" + CASE 60: "Bitte store counter Anweisungen überprüfen" + OTHERWISE "Bitte Korrigieren" + END SELECT. +END PROC report text processing error; + +PROC report text processing warning (INT CONST error nr, + INT CONST line nr, + TEXT VAR message, + TEXT CONST addition): + + einfache meldung aufbauen; + meldung in fehlerdatei ausgeben. + +einfache meldung aufbauen: + message := "WARNUNG Zeile "; + message CAT text (line nr); + message CAT ": "; + message CAT simple message; + message CAT " "; + message CAT addition. + +meldung in fehlerdatei ausgeben: + note (message); + note line; + fehlerdummy := " >>> "; + fehlerdummy CAT zusatz; + note (fehlerdummy); + note line. + +simple message: + SELECT error nr OF + CASE 1, 2: "" + CASE 3: "Nicht referenziert:" + CASE 4: "Ziel-Referenz fehlt:" + CASE 5: "Modifikation bei Dateiende nicht ausgeschaltet:" + CASE 6: "Index bei Dateiende nicht ausgeschaltet:" + CASE 7: "Nicht getrenntes Wort zu lang für Zeilenbreite:" + CASE 8: "Umschaltung auf gleichen Schrifttyp:" + CASE 9: "Kennzeichen schon vorhanden (Duplikat ignoriert):" + CASE 10: "Tabellenzeile breiter als limit" + CASE 11: "Mehr Spalten als Tabellen-Positionen bei:" + CASE 12: "Überschreibung nach" + CASE 13: "Leerzeichen vor:" + CASE 14: "Weniger Spalten als Tabellen-Positionen" + CASE 15: "counter mit dieser Kennung bereits initialisiert:" + OTHERWISE "" + ENDSELECT. + +zusatz: + SELECT error nr OF + CASE 3: "topage oder value fehlt" + CASE 4: "goalpage oder value fehlt" + CASE 7: "Bitte nachträglich trennen!" + CASE 8: "Schrifttyp wurde darum nicht verändert!" + CASE 9: "count und goalpage überprüfen" + CASE 12: "Bitte fehlende Leerzeichen einfügen" + CASE 13: "erzeugt ggf. zusätzliche Leerzeile" + OTHERWISE "Bitte überprüfen" + END SELECT. +END PROC report text processing warning; +END PACKET texter errors and common; + diff --git a/system/base/1.7.5/src/thesaurus b/system/base/1.7.5/src/thesaurus new file mode 100644 index 0000000..5ef7251 --- /dev/null +++ b/system/base/1.7.5/src/thesaurus @@ -0,0 +1,332 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PACKET thesaurus handling (* Autor: J.Liedtke *) + + DEFINES THESAURUS , + := , + empty thesaurus , + insert, (* fuegt ein Element ein *) + delete, (* loescht ein Element falls vorhanden*) + rename, (* aendert ein Element falls vorhanden*) + CONTAINS , (* stellt fest, ob enthalten *) + link , (* index in thesaurus *) + name , (* name of entry *) + get , (* get next entry ("" is eof)*) + highest entry : (* highest valid index of thes*) + + +TYPE THESAURUS = TEXT ; + +LET thesaurus size = 200 , + nil = 0 , + niltext = "" , + max name length = 80 , + + begin entry char = ""0"" , + end entry char = ""1"" , + + nil entry = ""0""1"" , + nil name = "" , + + quote = """" ; + +TEXT VAR entry ; +INT VAR cache index := 0 , + cache pos ; + + +PROC access (THESAURUS CONST thesaurus, TEXT CONST name) : + + construct entry ; + IF NOT cache identifies entry + THEN search through thesaurus list + FI ; + IF entry found + THEN cache index := code (list SUB (cache pos - 1)) + ELSE cache index := 0 + FI . + +construct entry : + entry := begin entry char ; + entry CAT name ; + decode invalid chars (entry, 2) ; + entry CAT end entry char . + +search through thesaurus list : + cache pos := pos (list, entry) . + +cache identifies entry : + cache pos <> 0 AND + pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos . + +entry found : cache pos > 0 . + +list : CONCR (thesaurus) . + +ENDPROC access ; + +PROC access (THESAURUS CONST thesaurus, INT CONST index) : + + IF cache identifies index + THEN cache index := index ; + construct entry + ELSE cache pos := pos (list, code (index) + begin entry char) ; + IF entry found + THEN cache pos INCR 1 ; + cache index := index ; + construct entry + ELSE cache index := 0 ; + entry := niltext + FI + FI . + +construct entry : + entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) . + +cache identifies index : + subtext (list, cache pos-1, cache pos) = code (index) + begin entry char . + +entry found : cache pos > 0 . + +list : CONCR (thesaurus) . + +ENDPROC access ; + + + +THESAURUS PROC empty thesaurus : + + THESAURUS : (""1"") + +ENDPROC empty thesaurus ; + + +OP := (THESAURUS VAR dest, THESAURUS CONST source ) : + + CONCR (dest) := CONCR (source) . + +ENDOP := ; + +TEXT VAR insert name ; + +PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) : + + insert name := name ; + decode invalid chars (insert name, 1) ; + IF insert name = "" OR LENGTH insert name > max name length + THEN index := nil ; errorstop ("Name unzulaessig") + ELSE insert element + FI . + +insert element : + search free entry ; + IF entry found + THEN insert into directory + ELSE add entry to directory if possible + FI . + +search free entry : + access (thesaurus, nil name) . + +insert into directory : + change (list, cache pos + 1, cache pos, insert name) ; + index := cache index . + +add entry to directory if possible : + INT CONST next free index := code (list SUB LENGTH list) ; + IF next free index <= thesaurus size + THEN add entry to directory + ELSE directory overflow + FI . + +add entry to directory : + list CAT begin entry char ; + cache pos := LENGTH list ; + cache index := next free index ; + list CAT insert name ; + list CAT end entry char + code (next free index + 1) ; + index := cache index . + +directory overflow : + index := nil . + +entry found : cache index > 0 . + +list : CONCR (thesaurus) . + +ENDPROC insert ; + +PROC decode invalid chars (TEXT VAR name, INT CONST start pos) : + + INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ; + WHILE invalid char pos > 0 REP + change (name, invalid char pos, invalid char pos, decoded char) ; + invalid char pos := pos (name, ""0"", ""31"", invalid char pos) + PER . + +decoded char : quote + text(code(name SUB invalid char pos)) + quote. + +ENDPROC decode invalid chars ; + +PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) : + + INT VAR index ; + insert (thesaurus, name, index) ; + IF index = nil AND NOT is error + THEN errorstop ("THESAURUS-Ueberlauf") + FI . + +ENDPROC insert ; + +PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) : + + access (thesaurus, name) ; + index := cache index ; + delete (thesaurus, index) . + +ENDPROC delete ; + +PROC delete (THESAURUS VAR thesaurus, INT CONST index) : + + access (thesaurus, index) ; + IF entry found + THEN delete entry + FI . + +delete entry : + IF is last entry of thesaurus + THEN cut off as much as possible + ELSE set to nil entry + FI . + +set to nil entry : + change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) . + +cut off as much as possible : + WHILE predecessor is also nil entry REP + set cache to this entry + PER ; + list := subtext (list, 1, cache pos - 1) ; + erase cache . + +predecessor is also nil entry : + subtext (list, cache pos - 3, cache pos - 2) = nil entry . + +set cache to this entry : + cache pos DECR 3 . + +erase cache : + cache pos := 0 ; + cache index := 0 . + +is last entry of thesaurus : + pos (list, end entry char, cache pos) = LENGTH list - 1 . + +list : CONCR (thesaurus) . + +entry found : cache index > nil . + +ENDPROC delete ; + + +BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) : + + IF name = niltext OR LENGTH name > max name length + THEN FALSE + ELSE access (thesaurus, name) ; entry found + FI . + +entry found : cache index > nil . + +ENDOP CONTAINS ; + +PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) : + + rename (thesaurus, link (thesaurus, old), new) + +ENDPROC rename ; + +PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) : + + insert name := new ; + decode invalid chars (insert name, 1) ; + IF insert name = "" OR LENGTH insert name > max name length + THEN errorstop ("Name unzulaessig") + ELSE change to new name + FI . + +change to new name : + access (thesaurus, index) ; + IF cache index <> 0 AND entry <> "" + THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name) + FI . + +list : CONCR (thesaurus) . + +ENDPROC rename ; + +INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) : + + access (thesaurus, name) ; + cache index . + +ENDPROC link ; + +TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) : + + access (thesaurus, index) ; + subtext (entry, 2, LENGTH entry - 1) . + +ENDPROC name ; + +PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) : + + identify index ; + REP + to next entry + UNTIL end of list COR valid entry found PER . + +identify index : + IF index = 0 + THEN cache index := 0 ; + cache pos := 1 + ELSE access (thesaurus, index) + FI . + +to next entry : + cache pos := pos (list, begin entry char, cache pos + 1) ; + IF cache pos > 0 + THEN get entry + ELSE get nil entry + FI . + +get entry : + cache index INCR 1 ; + index := cache index ; + name := subtext (list, cache pos + 1, end entry pos - 1) . + +get nil entry : + cache index := 0 ; + cache pos := 0 ; + index := 0 ; + name := "" . + +end entry pos : pos (list, end entry char, cache pos) . + +end of list : index = 0 . + +valid entry found : name <> "" . + +list : CONCR (thesaurus) . + +ENDPROC get ; + +INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*) + + code (list SUB LENGTH list) - 1 . + +list : CONCR (thesaurus) . + +ENDPROC highest entry ; + +ENDPACKET thesaurus handling ; + diff --git a/system/dos/1.8.7/doc/dos-dat-handbuch b/system/dos/1.8.7/doc/dos-dat-handbuch new file mode 100644 index 0000000..a1e4fd4 --- /dev/null +++ b/system/dos/1.8.7/doc/dos-dat-handbuch @@ -0,0 +1,650 @@ +____________________________________________________________________________ + + +#on("b")##on ("u")# +#center#Betriebssystem E U M E L +#off ("u")# + + +#center#MS-DOS-DAT + + + + +#off("b")# +#center#Lizenzfreie Software der +#on ("b")# + +#center#Gesellschaft für Mathematik und Datenverarbeitung mbH, +#center#5205 Sankt Augustin + + +#off("b")# +#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für +#center#nichtkommerzielle Zwecke gestattet. + +#center#Gewährleistung und Haftung werden ausgeschlossen + + +____________________________________________________________________________ +#page# +#free(4.5)# + +#center#Lesen und Schreiben +#center#von +#center#MS-DOS Dateien + +#on ("b")##center#MS-DOS-DAT#off ("b")# +#free(1.5)# + + +#center#Version 2.0 + +#center#Stand 10.09.87 +#page# +#pagenr ("%",1)##setcount (1)##block##pageblock##count per page# +#headeven# +% #center#MS-DOS-DAT +#center#____________________________________________________________ + +#end# +#headodd# +#center#MS-DOS-DAT#right#% +#center#____________________________________________________________ + +#end# +#on("bold")# +#ib#1. Allgemeines#ie# +#off ("b")# + +Dieses Programm ermöglicht MS-DOS Dateien vom EUMEL aus von Disketten zu +lesen und auf Disketten zu schreiben. Die Benutzerschnittstelle ist ähnlich der des +EUMEL-Archivs organisiert. Der Benutzer kommuniziert mit einer Task des +EUMEL-Systems, nämlich mit der Task 'DOS'. Diese wickelt dann über das Archiv +laufwerk die Diskettenzugriffe ab. Der Benutzer meldet die MS-DOS Diskette mit +'reserve ("...", /"DOS")' an und kann dann mit 'list (/"DOS")', 'fetch ("...", /"DOS")', +'save ("...", /"DOS")' und weiteren Kommandos auf die MS-DOS Diskette zugreifen. +Für das Schreiben und Lesen (save, fetch) stehen insgesamt 7 verschiedene Be +triebsarten zur Verfügung. Man kann in eine Datei im ASCII Code mit und ohne +Anpassung der Umlaute, im IBM-ASCII Code, im Atari-ST Code oder ganz ohne +Codeumsetzung lesen bzw. schreiben. Die Betriebsart selbst wird beim Anmelden der +MS-DOS Diskette durch den Textparameter des 'reserve'-Kommandos bestimmt. + +Die gleiche Benutzerschnittstelle gilt für die Kommunikation mit der Task 'DOS HD'. +Diese Task liest und schreibt aber nicht auf der Diskette, sondern in der MS-DOS +Partition der Festplatte (falls vorhanden). + + +#on("bold")# +#ib#2. Benutzeranleitung #ie# +#off ("b")# +Im Normalfall will man als Benutzer eine EUMEL-Textdatei auf eine MS-DOS +Diskette schreiben oder eine mit z.B. Word-Star erstellte MS-DOS-Textdatei in +das EUMEL-System einlesen (implementierte Formate siehe Abschnitt 3). + +Lesen einer MS-DOS-Datei: + +#linefeed (1.25)# +#on ("b")# + reserve ("file ascii german", /"DOS"); + (* MS-DOS-Diskette ins Laufwerk einlegen *) + fetch (filename, /"DOS"); + release (/"DOS") +#off ("b")# + +Schreiben einer MS-DOS-Datei: + +#on ("b")# + reserve ("file ascii german", /"DOS"); + (* MS-DOS-Diskette ins Laufwerk einlegen *) + save (filename, /"DOS"); + release (/"DOS") +#off("b")# +#linefeed (1.0)# + + +Sollen statt der Umlaute []{|}\ verwendet werden, so ist statt "file ascii german" "file +ascii" einzustellen. Eine genaue Beschreibung aller 7 möglichen Betriebsarten wird in +Abschnitt 6 gegeben. Der Dateiname 'file name' unterliegt den im Abschnitt 4 be +schriebenen Einschränkungen. + + +#on("bold")# +#ib#3. Implementierte Formate#ie# +#off("b")# + +Diese Hardware ermöglicht das Bearbeiten von MS-DOS Disketten mit Hilfe der +Task /"DOS" und (falls es sich um einen MS-DOS fähigen Rechner mit MS-DOS Parti +tion auf der Festplatte handelt) das Bearbeiten von Daten in der MS-DOS Partition +der Platte. + +#on("bold")# +#ib#3.1 Arbeiten mit der Task /"DOS"#ie# +#off ("b")# + +Die Task /"DOS" verwendet das Archivlaufwerk als MS-DOS Datenträger. Es sind +alle mit dem IBM-Format der DOS Version 2 und 3 kompatiblen Formate für 5.25 +Zoll und 3.5 Zoll Disketten implementiert, sofern diese 512 Byte große Sektoren +verwenden und im ersten Sektor einen erweiterten BIOS-Parameterblock (BPB) +enthalten (hierzu gehören auch mit dem Atari ST bearbeitete Disketten). Weiterhin +sind die beiden von IBM verwendeten Formate der DOS Version 1 implementiert (5.25 +Zoll, ein- bzw. zweiseitig, 40 Spuren a 8 Sektoren). + +Die einzige Hardwarevoraussetzung besteht darin, daß der Hardwareanpassungs +modul (SHard) alle von DOS benutzten Sektoren lesen und schreiben können muß. + +#on("bold")# +#ib#3.2 Arbeiten mit der Task /"DOS HD"#ie# +#off ("b")# + +Die Task /"DOS HD" verwendet die MS-DOS Partition der Festplatte als Daten +träger (falls eine solche vorhanden ist und das SHard diese ansprechen kann). Hier +gibt es keine Beschränkungen bezüglich des Plattentyps. + + +#on("bold")# +#ib#4. Dateibenennung#ie# +#off ("b")# + +Die Namen für MS-DOS Dateien unterliegen bestimmten Regeln. Ein Dateiname +kann aus +- einem bis acht Zeichen oder +- einem bis acht Zeichen gefolgt von einem Punkt und einer Namenserweiterung + von einem bis drei Zeichen +bestehen. + +Gültige Zeichen sind +- die Buchstaben A bis Z +- die Ziffern 0 bis 9 +- die Sonder- und Satzzeichen $ \# & § ! ( ) { } + +Da weitere Sonderzeichen in verschiedenen MS-DOS Versionen in unterschiedlich +em Umfang erlaubt sind, ist ihre Verwendung beim Schreiben (save) vom EUMEL aus +nicht zugelassen. Beim Lesen und Löschen dagegen sind sie erlaubt. + +Außerdem sind die Buchstaben a - z erlaubt. Diese werden beim Zugriff auf das +MS-DOS Inhaltsverzeichnis (Directory) in große Buchstaben konvertiert. Durch das +Kommando 'fetch ("Test", /"DOS")' wird also die MS-DOS Datei mit dem Namen +'TEST' in die EUMEL Datei mit dem Namen 'Test' gelesen; 'save ("test", /"DOS")' +überschreibt dann die MS-DOS-Datei 'TEST' (natürlich nach Anfrage). + + +#on("bold")# +#ib#5. Beschreibung der Kommandos#ie# +#off ("b")# + +In diesem Abschnitt steht der Begriff Dostask beim Arbeiten mit der Floppy für die +Task /"DOS" und beim Arbeiten mit der MS-DOS Partition der Platte für die Task +/"DOS HD". Analog steht der Begriff Dosbereich beim Arbeiten mit der Floppy für die +Floppy und beim Arbeiten mit der MS-DOS Partition der Platte für diese Partition. + +#on("bold")# +THESAURUS OP ALL (TASK CONST task) +#off ("b")# + Wird der 'ALL'-Operator für die Dostask aufgerufen, so wird ein Thesaurus ge + liefert. In diesem Thesaurus sind alle im Dosbereich vorhandenen Dateien einge + tragen. Die vorhandenen Unterinhaltsverzeichnisse (Subdirectories) werden nicht + eingetragen. + + +#on("bold")# +PROC check (TEXT CONST filename, TASK CONST task) +#off ("b")# + Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' im Dosbe + reich prüfgelesen. Es werden nur die mit Daten belegten Blöcke prüfgelesen. Sollen + auch der Einträge im Inhaltsverzeichnis überprüft werden, so erreicht man dies + durch vorheriges neues Anmelden mit der Prozedur 'reserve'. + + +#on("bold")# +PROC clear (TASK CONST task) +#off ("b")# + Durch Aufruf dieser Prozedur für die Task /"DOS" wird die gesamte Diskette ge + löscht. Mit dieser Prozedur können #on ("u")#nur MS-DOS formatierte Disketten#off ("u")# behandelt + werden. Soll eine Diskette dagegen für den Gebrauch unter MS-DOS initialisiert + werden, so ist sie auf einem MS-DOS-Rechner zu formatieren. + + Der Aufruf dieser Prozedur für die Task /DOS HD" ist aus Sicherheitsgründen nicht + erlaubt. + + +#on("bold")# +PROC erase (TEXT CONST filename, TASK CONST task) +#off ("b")# + Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' im Dosbe + reich gelöscht. + + +#on("bold")# +BOOL PROC exists (TEXT CONST name, TASK CONST task) +#off ("b")# + Wird diese Prozedur für die Dostask aufgerufen, so liefert sie 'TRUE', falls eine + Datei mit dem Namen 'name' im Dosbereich existiert. Andernfalls liefert sie + 'FALSE'. + + +#on("bold")# +PROC fetch (TEXT CONST filename, TASK CONST task) +#off ("b")# + Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' aus dem + Dosbereich gelesen. Hierbei wird in der beim Anmelden (reserve ("...", dostask)) + bestimmten Betriebsart gelesen (siehe Abschnitt 6). + + +#on("bold")# +PROC list (TASK CONST task) +#off ("b")# + Wird diese Prozedur für die Dostask aufgerufen, so werden alle Dateien des In + haltsverzeichnisses und alle Unterverzeichnisse des Dosbereichs aufgelistet. + + +#on("bold")# +PROC release (TASK CONST task) +#off ("b")# + Der Aufruf dieser Prozedur für die Task Dostask hebt deren Reservierung auf. + Gleichzeitig wird auch der für block i/o benutzte Kanal freigegeben, so daß bei + Benutzung der Task /"DOS" der Archivkanal durch das EUMEL-Archiv wieder + benutzt werden kann. + + Um möglichst effizient arbeiten zu können, werden Inhaltsverzeichnis und Ket + tungsblock des Dosbereichs als Kopie im EUMEL gehalten. Der hierdurch belegte + Speicher wird beim 'release' wieder freigegeben. Dies ist bei kleinen Systemen + besonders wichtig. + + +#on("bold")# +PROC reserve (TEXT CONST mode, TASK CONST task) +#off ("b")# + Durch Aufruf für die Dostask werden Operationen mit dem Dosbereich angemel + det. Gleichzeitig koppelt sich die Dostask an den entsprechenden Kanal an. + (/"DOS" an Kanal 31 und /"DOS HD" an Kanal 29). Die Anmeldung wird abge + lehnt, wenn der für die MS-DOS Operationen benötigte Kanal belegt ist (z.B. bei + Kanal 31 durch eine ArchivOperation). Ähnlich wie beim EUMEL-Archiv bleibt + diese Reservierung bis 5 Minuten nach dem letzten Zugriff gültig. + + Wird beim Arbeiten mit der Task /"DOS" die MS-DOS Diskette gewechselt, so + muß erneut 'reserve ("...", /"DOS")' aufgerufen werden. Nur so ist gewährleistet, + daß das Inhaltsverzeichnis der neuen Diskette geladen wird. + + Der Text 'mode' gibt die Betriebsart für das Schreiben und Lesen der Diskette + sowie den Pfad für das Bearbeiten von Subdirectories an und nicht wie beim + EUMEL-Archiv den Diskettennamen. Es gilt folgende Systax: + + modus :[\directory][\directory]...[\directory] + + Hierbei sind die Angaben in eckigen Klammern optional. Wird kein Pfad angege + ben, so wird mit dem Hauptdirektory der Diskette gearbeitet. Ansonsten wird mit + dem Directory gearbeitet, welches durch den hinter dem Doppelpunkt angegeben + Pfad bezeichnet wird. Als 'modus' können alle in Abschnitt 6 beschriebenen Be + triebsarten verwendet werden. + + +#on("bold")# +PROC save (TEXT CONST filename, TASK CONST task) +#off ("b")# + Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' in den + Dosbereich geschrieben. Hierbei wird in der beim Anmelden (reserve ("...", + dostask)) bestimmten Betriebsart geschrieben (siehe Abschnitt 6). + + +#on("bold")# +#ib#6. Die Betriebsarten von 'fetch' und 'save'#ie# + +#ib#6.1 Betriebsart: file ascii#ie# + +#on("bold")# +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei + werden von allen Zeichen nur die niederwertigen 7 Bit gemäß DIN 66 003, ASCII + Code, internationale Referenzversion interpretiert. Die Datei wird so aufbereitet, daß + ein Bearbeiten mit dem EUMEL-Editor möglich ist. Dies geschieht folgenderma + ßen: + - Alle im EUMEL darstellbaren Zeichen werden auf diese abgebildet. + - Die Zeichenfolgen CR LF, LF CR, LF, CR (CR = carriage return, LF = line + feed) beenden einen Satz in der MS-DOS-Datei. Dementsprechend wird + eumelseitig die aktuelle Zeile beendet. + - Das Zeichen FF (form feed) beendet eumelseitig die aktuelle Zeile. Außerdem + wird ein Satz mit dem Inhalt "\#page\#" eingefügt. + - TAB's (Code 9) werden mit Blanks zur nächsten 8ter-Position expandiert. + - 'Ctrl z' in der MS-DOS Datei wird als Dateiende interpretiert. Fehlt dieses, + so wird bis zum letzten Zeichen des letzten Sektors der Datei gelesen. + - Alle anderen Zeichen mit 0 <= code (zeichen) <= 31 (Steuerzeichen) + werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird + als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt). + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS + wird der ASCII Code, internationale Referenzversion gemäß DIN 66 003 verwendet. + Dies geschieht folgendermaßen: + - Die EUMEL-spezifischen Druckzeichen (Trenn -, Trenn k, Druck \#, ge + schütztes Blank) werden in -, k, \# und Blank umgesetzt. + - Alle in der internationalen Referenzversion des ASCII Codes vorhandenen + Eumel-Zeichen werden auf diese abgebildet. + - Alle in der internationalen Referenzversion des ASCII Codes nicht vorhande + nen Eumel-Zeichen werden durch eine Ersatzdarstellung dargestellt (der + Code des Zeichens wird als 3 stellige Dezimalzahl eingeschlossen von + \#-Zeichen dargestellt) + - Steht in einer Zeile nur das Kommando '\#page\#' so wird dieses in ein Sei + tenvorschubsteuerzeichen (""12"") umgewandelt. + - Eine dreistellige Dezimalzahl eingeschlossen von \# Zeichen wird als Ersatz + darstellung für das Zeichen mit dem durch die Dezimalzahl angegebenen + Code betrachte. Diese Ersatzdarstellung wird beim Schreiben aufgelöst (d.h. + durch das entsprechende Zeichen ersetzt). + - Nach jeder Zeile wird 'carriage return' und ' linefeed' angefügt + - Am Ende der Datei wird 'ctrl z' angehängt. + + +#on("bold")# +#ib#6.2 Betriebsart: file ascii german#ie# + +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei + werden von allen Zeichen nur die niederwertigen 7 Bit gemäß DIN 66 003, ASCII + Code, deutsche Referenzversion interpretiert. Die Datei wird so aufbereitet, daß ein + Bearbeiten mit dem EUMEL-Editor möglich ist. Dies geschieht wie in der Be + triebsart 'file ascii', jedoch stehen statt []{}|\ die Umlaute und ß zur Verfügung. + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS + wird der ASCII Code, deutsche Referenzversion gemäß DIN 66 003 verwendet. Dies + geschieht wie in der Betriebsart 'file ascii', jedoch stehen statt []{}|\ die Umlaute + zur Verfügung. + + +#on("bold")# +#ib#6.3 Betriebsart: file ibm#ie# + +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei + werden alle Zeichen wie in der von IBM verwendeten Version des ASCII Codes + interpretiert. Die Datei wird so aufbereitet, daß ein Bearbeiten mit dem EUMEL- + Editor möglich ist. Dies geschieht folgendermaßen: + - Alle im EUMEL darstellbaren Zeichen werden auf diese abgebildet. + - Die Zeichenfolgen CR LF, LF CR, LF, CR (CR = carriage return, LF = line + feed) beenden einen Satz in der MS-DOS-Datei. Dementsprechend wird + eumelseitig die aktuelle Zeile beendet. + - Das Zeichen FF (form feed) beendet eumelseitig die aktuelle Zeile. Außerdem + wird ein Satz mit dem Inhalt "\#page\#" eingefügt. + - TAB's (Code 9) werden mit Blanks zur nächsten 8ter-Position expandiert. + - Alle anderen Zeichen mit 0 <= code (zeichen) <= 31 (Steuerzeichen) + werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird + als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt). + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS + wird der ASCII Code in der von IBM verwendeten Version verwendet. Dies ge + schieht folgendermaßen: + - Die EUMEL-spezifischen Druckzeichen (Trenn -, Trenn k, Druck \#, ge + schütztes Blank) werden in -, k, \# und Blank umgesetzt. + - Alle in der IBM Version des ASCII Codes vorhandenen Eumel-Zeichen + werden auf diese abgebildet. + - Alle in der IBM Version des ASCII Codes nicht vorhandenen Eumel-Zeichen + werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird + als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt) + - Steht in einer Zeile nur das Kommando '\#page\#' so wird dieses in ein Sei + tenvorschubsteuerzeichen (""12"") umgewandelt. + - Eine dreistellige Dezimalzahl eingeschlossen von \# Zeichen wird als Ersatz + darstellung für das Zeichen mit dem durch die Dezimalzahl angegebenen + Code betrachte. Diese Ersatzdarstellung wird beim Schreiben aufgelöst (d.h. + durch das entsprechende Zeichen ersetzt). + - Nach jeder Zeile wird 'carriage return' und ' linefeed' angefügt + + +#on("bold")# +#ib#6.4 Betriebsart: file atari st#ie# + +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei + werden alle Zeichen wie in der vom Atari ST verwendeten Version des ASCII Codes + interpretiert. Die Datei wird so aufbereitet, daß ein Bearbeiten mit dem EUMEL- + Editor möglich ist. Dies geschieht folgendermaßen: + - Alle im EUMEL darstellbaren Zeichen werden auf diese abgebildet. + - Die Zeichenfolgen CR LF, LF CR, LF, CR (CR = carriage return, LF = line + feed) beenden einen Satz in der MS-DOS-Datei. Dementsprechend wird + eumelseitig die aktuelle Zeile beendet. + - Das Zeichen FF (form feed) beendet eumelseitig die aktuelle Zeile. Außerdem + wird ein Satz mit dem Inhalt "\#page\#" eingefügt. + - TAB's (Code 9) werden mit Blanks zur nächsten 8ter-Position expandiert. + - Alle anderen Zeichen mit 0 <= code (zeichen) <= 31 (Steuerzeichen) + werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird + als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt). + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS + wird der ASCII Code in der vom Atari ST verwendeten Version verwendet. Dies + geschieht folgendermaßen: + - Die EUMEL-spezifischen Druckzeichen (Trenn -, Trenn k, Druck \#, ge + schütztes Blank) werden in -, k, \# und Blank umgesetzt. + - Alle in der vom Atari ST verwendeten Version des ASCII Codes vorhandenen + Eumel-Zeichen werden auf diese abgebildet. + - Alle in der vom Atari ST verwendeten Version des ASCII Codes nicht + vorhandenen Eumel-Zeichen werden durch eine Ersatzdarstellung dargestellt + (der Code des Zeichens wird als 3 stellige Dezimalzahl eingeschlossen von + \#-Zeichen dargestellt) + - Steht in einer Zeile nur das Kommando '\#page\#' so wird dieses in ein Sei + tenvorschubsteuerzeichen (""12"") umgewandelt. + - Eine dreistellige Dezimalzahl eingeschlossen von \# Zeichen wird als Ersatz + darstellung für das Zeichen mit dem durch die Dezimalzahl angegebenen + Code betrachte. Diese Ersatzdarstellung wird beim Schreiben aufgelöst (d.h. + durch das entsprechende Zeichen ersetzt). + - Nach jeder Zeile wird 'carriage return' und ' linefeed' angefügt + + +#on("bold")# +#ib#6.5 Betriebsart: file transparent#ie# + +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei + werden von allen Zeichen alle 8 Bit interpretiert. Es werden keine Zeichen einge + fügt, gelöscht oder gewandelt. Somit stehen dann auch CR und LF Zeichen in der + EUMEL-Datei. + + Da eine solche Datei noch Steuerzeichen enthält, ist beim Bearbeiten mit dem + Editor Vorsicht geboten. + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Es werden keine + Codeumsetzungen durchgeführt. Insbesondere muß die EUMEL-Datei auch die CR + LF Sequenzen für das Zeilenende enthalten. + + +#on("bold")# +#ib#6.6 Betriebsart: row text#ie# +#off ("b")# + +Diese Betriebsart ist nur für Programmierer interessant. Sie ist für die Umsetzung +exotischer Codes in den EUMEL-Code mittels ELAN-Programmen gedacht. + +#on("bold")# +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird in einen Datenraum mit folgender Struktur + kopiert: + + STRUCT (INT benutzte texte, ROW 4000 TEXT datensatz) + + Dabei bekommt der Datenraum den Type 1000. Der Integer 'benutzte texte' gibt an, + wieviele Elemente des ROW 4000 TEXT benutzt sind. In jedem benutzten Element + des ROW 4000 TEXT steht der Inhalt einer logischen Gruppe der MS-DOS Disket + te. (Eine logische Gruppe umfaßt bei einer einseitig beschriebenen MS-DOS + Diskette 512 Byte und bei einer zweiseitig beschriebenen 1024 bzw. 2048 Byte). In + dieser Betriebsart werden keine Zeichen der MS-DOS Datei konvertiert oder + interpretiert, so daß also auch alle Steuerzeichen erhalten bleiben. + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Hier bezeichnet 'filename' einen Datenraum der Struktur: + + STRUCT (INT benutzte texte, ROW 4000 TEXT datensatz) + + Dieser Datenraum muß den Type 1000 haben. + Es werden die benutzten Texte (1 bis benutzte texte) aneinandergehängt und ohne + irgendwelche Konvertierungen bzw. Interpretationen als MS-DOS Datei 'filename' + geschrieben. Dies bedeutet, daß die Texte auch alle von MS-DOS benötigten + Steuerzeichen (z.B. 'ctrl z' als Dateiendekennzeichen) enthalten müssen. + + +#on("bold")# +#ib#6.7 Betriebsart: ds#ie# +#off ("b")# +Diese Betriebsart ist nur für den Programmierer interessant. Sie ermöglicht das Abbil +den von Datenstrukturen zwischen MS-DOS und EUMEL. + +#on("bold")# +fetch ("filename", dostask) +#off ("b")# + Die MS-DOS Datei 'filename' wird blockweise in den Datenraum 'filename' ko + piert. Hierbei wird der erste Block der MS-DOS Datei in die 2. Seite des Daten + raums kopiert. (Die 2. Seite eines Datenraums ist die erste, die von einer Daten + struktur voll überdeckt werden kann). + + +#on("bold")# +save ("filename", dostask) +#off ("b")# + Der Datenraum 'filename' wird ab seiner 2. Seite in die MS-DOS Datei 'filename' + geschrieben. Hierbei werden alle Seiten des Datenraums (auch die nicht allokier + ten) bis einschließlich der letzten allokierten Datenraumseite geschrieben. + + +#on("bold")# +#ib#7. Installation#ie# +#off ("b")# + +Die Software zur Generierung der Tasks /"DOS" und /"DOS HD" wird auf einem +EUMEL-Archiv ausgeliefert. + +#on("bold")# +#ib#7.1 Installation der Task /"DOS"#ie# + +#ib#7.1.1 Installation im Multi-User#ie# +#off ("b")# + +Die Software muß in einer privilegierten Task mit dem Namen 'DOS' installiert wer +den. Dies geschieht folgendermaßen: + + + begin ("DOS", "SYSUR") + + archive ("austausch"); + fetch ("dos inserter", archive); + run ("dos inserter") + + +Danach stehen die Prozeduren + + + PROC dos manager + PROC dos manager (INT CONST channel) + + +zur Verfügung. Beide Prozeduren machen die aufrufende Task zur Kommunikations +task für das Schreiben und Lesen von MS-DOS Disketten. Die erste benutzt dazu +den Archivkanal (Kanal 31), bei der zweiten ist der Kanal über den Parameter ein +stellbar. Eine dieser Prozeduren muß jetzt aufgerufen werden. + +#on("bold")# +#ib#7.1.2. Installation im Single-User#ie# +#off ("b")# + +Die Software wird im Monitor ('gib Kommando'-Modus) durch folgende Kommandos +installiert: + + + archive ("austausch"); + fetch ("dos inserter", archive); + run ("dos inserter") + + +Für das Schreiben und Lesen von MS-DOS Disketten wird der Archivkanal (Kanal +31) benutzt. + + +#on("bold")# +#ib#7.2 Installation der Task /"DOS HD"#ie# +#off ("b")# + +Die Software muß in einer privilegierten Task mit dem Namen 'DOS HD' installiert +werden. Dies geschieht folgendermaßen: + + + begin ("DOS HD", "SYSUR") + + archive ("austausch"); + fetch ("dos hd inserter", archive); + run ("dos hd inserter") + + +Danach steht die Prozedur + + + PROC dos manager + + +zur Verfügung. Sie macht die aufrufende Task zur Kommunikationstask für das +Schreiben und Lesen in der MS-DOS Partition der Platte. Sie benutzt dazu den +Kanal 29, der, wie im Portierungshandbuch für den 8086 beschrieben, implementiert +sein muß. + +#page# +#headeven# +#end# + + + + + +Herausgegeben von: + + Gesellschaft für Mathematik und Datenverarbeitung mbH + (GMD) + Schloß Birlinghoven + 5205 Sankt Augustin 1 + + und + + Hochschulrechenzentrum der Universität Bielefeld + (HRZ) + Universitätsstraße + 4800 Bielefeld 1 + +Autor: + + Frank Klapper + +überarbeitet von: + + Thomas Müller + Hansgeorg Freese (GMD) + +Umschlaggestaltung: + + Hannelotte Wecken + + + + + + diff --git a/system/dos/1.8.7/source-disk b/system/dos/1.8.7/source-disk new file mode 100644 index 0000000..cc5ebe0 --- /dev/null +++ b/system/dos/1.8.7/source-disk @@ -0,0 +1 @@ +187_ergos/04_dos.img diff --git a/system/dos/1.8.7/src/block i-o b/system/dos/1.8.7/src/block i-o new file mode 100644 index 0000000..554fcca --- /dev/null +++ b/system/dos/1.8.7/src/block i-o @@ -0,0 +1,180 @@ +PACKET disk block io DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 05.01.87 *) + read disk block, + read disk block and close work if error, + read disk cluster, + write disk block, + write disk block and close work if error, + write disk cluster, + first non dummy ds page, + + block no dump modus: + +BOOL VAR block no dump flag := FALSE; + +LET write normal = 0; + +INT CONST first non dummy ds page := 2; + +INT VAR error; + +PROC read disk block (DATASPACE VAR ds, + INT CONST ds page no, + INT CONST block no): + IF block no dump flag THEN dump ("READ ", block no) FI; + check rerun; + read block (ds, ds page no, eublock (block no), error); + IF error > 0 + THEN lesefehler (error) + FI. + +END PROC read disk block; + +PROC read disk block (DATASPACE VAR ds, + INT CONST ds page no, + REAL CONST block no): + IF block no dump flag THEN dump ("READ ", block no) FI; + check rerun; + read block (ds, ds page no, eublock (block no), error); + IF error > 0 + THEN lesefehler (error) + FI. + +END PROC read disk block; + +PROC read disk block and close work if error (DATASPACE VAR ds, + INT CONST ds page no, + INT CONST block no): + IF block no dump flag THEN dump ("READ ", block no) FI; + check rerun; + read block (ds, ds page no, eublock (block no), error); + IF error > 0 + THEN close work; + lesefehler (error) + FI. + +END PROC read disk block and close work if error; + +PROC read disk block and close work if error (DATASPACE VAR ds, + INT CONST ds page no, + REAL CONST block no): + IF block no dump flag THEN dump ("READ ", block no) FI; + check rerun; + read block (ds, ds page no, eublock (block no), error); + IF error > 0 + THEN close work; + lesefehler (error) + FI. + +END PROC read disk block and close work if error; + +PROC read disk cluster (DATASPACE VAR ds, + INT CONST first ds page no, + REAL CONST cluster no): + IF block no dump flag THEN dump ("CLUSTER ", cluster no) FI; + INT VAR i; + FOR i FROM 0 UPTO sectors per cluster - 1 REP + read disk block (ds, first ds page no + i, block no + real (i)) + PER. + +block no: + begin of cluster (cluster no). + +END PROC read disk cluster; + +PROC lesefehler (INT CONST fehler code): + error stop (fehlertext). + +fehlertext: + SELECT fehler code OF + CASE 1: "Diskettenlaufwerk nicht betriebsbereit" + CASE 2: "Lesefehler" + OTHERWISE "Lesefehler " + text (fehler code) + END SELECT. + +END PROC lesefehler; + +PROC write disk block (DATASPACE CONST ds, + INT CONST ds page no, + INT CONST block no): + IF block no dump flag THEN dump ("WRITE", block no) FI; + check rerun; + write block (ds, ds page no, write normal, eublock (block no), error); + IF error > 0 + THEN schreibfehler (error) + FI. + +END PROC write disk block; + +PROC write disk block (DATASPACE CONST ds, + INT CONST ds page no, + REAL CONST block no): + IF block no dump flag THEN dump ("WRITE", block no) FI; + check rerun; + write block (ds, ds page no, write normal, eublock (block no), error); + IF error > 0 + THEN schreibfehler (error) + FI. + +END PROC write disk block; + +PROC write disk block and close work if error (DATASPACE CONST ds, + INT CONST ds page no, + INT CONST block no): + IF block no dump flag THEN dump ("WRITE", block no) FI; + check rerun; + write block (ds, ds page no, write normal, eublock (block no), error); + IF error > 0 + THEN close work; + schreibfehler (error) + FI. + +END PROC write disk block and close work if error; + +PROC write disk block and close work if error (DATASPACE CONST ds, + INT CONST ds page no, + REAL CONST block no): + IF block no dump flag THEN dump ("WRITE", block no) FI; + check rerun; + write block (ds, ds page no, write normal, eublock (block no), error); + IF error > 0 + THEN close work; + schreibfehler (error) + FI. + +END PROC write disk block and close work if error; + +PROC write disk cluster (DATASPACE CONST ds, + INT CONST first ds page no, + REAL CONST cluster no): + IF block no dump flag THEN dump ("CLUSTER ", cluster no) FI; + INT VAR i; + FOR i FROM 0 UPTO sectors per cluster - 1 REP + write disk block (ds, first ds page no + i, block no + real (i)) + PER. + +block no: + begin of cluster (cluster no). + +END PROC write disk cluster; + +PROC schreibfehler (INT CONST fehler code): + error stop (fehlertext). + +fehlertext: + SELECT fehler code OF + CASE 1: "Diskettenlaufwerk nicht betriebsbereit" + CASE 2: "Schreibfehler" + OTHERWISE "Schreibfehler " + text (fehler code) + END SELECT. + +END PROC schreibfehler; + +PROC block no dump modus (BOOL CONST status): + block no dump flag := status + +END PROC block no dump modus; + +END PACKET disk block io; + diff --git a/system/dos/1.8.7/src/bpb ds b/system/dos/1.8.7/src/bpb ds Binary files differnew file mode 100644 index 0000000..dabf721 --- /dev/null +++ b/system/dos/1.8.7/src/bpb ds diff --git a/system/dos/1.8.7/src/dir.dos b/system/dos/1.8.7/src/dir.dos new file mode 100644 index 0000000..08456b5 --- /dev/null +++ b/system/dos/1.8.7/src/dir.dos @@ -0,0 +1,693 @@ +PACKET dir DEFINES (* Copyright (c) 1986, 87 *) + (* Frank Klapper *) + open dir, (* 02.03.88 *) + insert dir entry, + delete dir entry, + init dir ds, + file info, + format dir, + + dir list, + file exists, + subdir exists, + all files, + all subdirs: + +LET max dir entrys = 1000; + +(*-------------------------------------------------------------------------*) + +INITFLAG VAR dir block ds used := FALSE; +DATASPACE VAR dir block ds; +BOUND STRUCT (ALIGN dummy, ROW 64 REAL daten) VAR dir block; +REAL VAR last read dir block no; + +PROC init dir block io: + last read dir block no := -1.0; + IF NOT initialized (dir block ds used) + THEN dir block ds := nilspace; + dir block := dir block ds + FI. + +END PROC init dir block io; + +PROC read dir block (REAL CONST block nr): + IF last read dir block no <> block nr + THEN last read dir block no := -1.0; + read disk block and close work if error (dir block ds, 2, block nr); + last read dir block no := block nr + FI. + +END PROC read dir block; + +PROC write dir block (REAL CONST block nr): + write disk block and close work if error (dir block ds, 2, block nr); + last read dir block no := block nr. + +END PROC write dir block; + +PROC write dir block: + IF last read dir block no < 0.0 + THEN error stop ("Lesefehler") + FI; + write dir block (last read dir block no) + +END PROC write dir block; + +PROC get dir entry (TEXT VAR entry buffer, INT CONST block entry no): + (* 0 <= block entry no <= 15 *) + entry buffer := 32 * "."; + INT CONST replace offset := 4 * block entry no; + replace (entry buffer, 1, dir block.daten [replace offset + 1]); + replace (entry buffer, 2, dir block.daten [replace offset + 2]); + replace (entry buffer, 3, dir block.daten [replace offset + 3]); + replace (entry buffer, 4, dir block.daten [replace offset + 4]). + +END PROC get dir entry; + +PROC put dir entry (TEXT CONST entry buffer, INT CONST block entry no): + (* 0 <= block entry no <= 15 *) + INT CONST offset := 4 * block entry no; + dir block.daten [offset + 1] := entry buffer RSUB 1; + dir block.daten [offset + 2] := entry buffer RSUB 2; + dir block.daten [offset + 3] := entry buffer RSUB 3; + dir block.daten [offset + 4] := entry buffer RSUB 4. + +END PROC put dir entry; + +(*-------------------------------------------------------------------------*) + +LET DIRPOS = REAL; (* 16.0 * msdos block nr + entry no *) + (* 0 <= entry no <= 15 *) + +DIRPOS PROC dirpos (REAL CONST block nr, INT CONST entry nr): + block nr * 16.0 + real (entry nr). + +END PROC dir pos; + +REAL PROC block no (DIRPOS CONST p): + floor (p / 16.0) + +END PROC block no; + +INT PROC entry no (DIRPOS CONST p): + int (p MOD 16.0) + +END PROC entry no; + +PROC incr (DIRPOS VAR p): + p INCR 1.0. + +END PROC incr; + +(*-------------------------------------------------------------------------*) + +LET FREELIST = STRUCT (ROW max dir entrys DIRPOS stack, + INT stacktop, + DIRPOS begin of free area, + end of dir, + REAL dir root); (* erste Clusterno, 0 für Main Dir *) + +PROC init free list (FREELIST VAR flist, REAL CONST root): + flist.stacktop := 0; + flist.begin of free area := dir pos (9.0e99, 0); + flist.end of dir := dir pos (-1.0, 0); + flist.dir root := root. + +END PROC init free list; + +PROC store (FREELIST VAR flist, DIRPOS CONST free pos): + flist.stacktop INCR 1; + flist.stack [flist.stack top] := free pos. + +END PROC store; + +PROC store begin of free area (FREELIST VAR flist, DIRPOS CONST begin): + flist.begin of free area := begin + +END PROC store begin of free area; + +PROC store end of dir (FREELIST VAR flist, DIRPOS CONST end): + flist.end of dir := end + +END PROC store end of dir; + +DIRPOS PROC free dirpos (FREELIST VAR flist): + enable stop; + DIRPOS VAR result; + IF flist.stacktop > 0 + THEN pop + ELIF NOT free area empty + THEN first of free area + ELIF expansion alloweded + THEN allocate new dir cluster; + result := free dirpos (flist) + ELSE error stop ("Directory voll") + FI; + result. + +pop: + result := flist.stack [flist.stacktop]; + flist.stacktop DECR 1. + +free area empty: + flist.begin of free area > flist.end of dir. + +first of free area: + result := flist.begin of free area; + incr (flist.begin of free area). + +expansion alloweded: + flist.dir root >= 2.0. + +allocate new dir cluster: + REAL CONST new dir cluster :: available fat entry; + REAL VAR last entry no; + search last entry no of fat chain; + fat entry (new dir cluster, last fat chain entry); + fat entry (last entry no, new dir cluster); + write fat; + store begin of free area (flist, dir pos (first new block, 0)); + store end of dir (flist, dir pos (last new block, 15)); + init new dir cluster. + +search last entry no of fat chain: + last entry no := flist.dir root; + WHILE NOT is last fat chain entry (fat entry (last entry no)) REP + last entry no := fat entry (last entry no) + PER. + +first new block: + begin of cluster (new dir cluster). + +last new block: + begin of cluster (new dir cluster) + real (sectors per cluster - 1). + +init new dir cluster: + TEXT CONST empty dir entry :: 32 * ""0""; + INT VAR i; + FOR i FROM 0 UPTO 15 REP + put dir entry (empty dir entry, i) + PER; + disable stop; + REAL VAR block no := first new block; + WHILE block no <= last new block REP + write dir block (block no) + PER. + +END PROC free dirpos; + +(*-------------------------------------------------------------------------*) + +LET FILEENTRY = STRUCT (TEXT date and time, + REAL size, + first cluster, + DIRPOS dirpos), + + FILELIST = STRUCT (THESAURUS thes, + ROW max dir entrys FILEENTRY entry); + +PROC init file list (FILELIST VAR flist): + flist.thes := empty thesaurus. + +END PROC init file list; + +PROC store file entry (FILELIST VAR flist, TEXT CONST entry text, DIRPOS CONST position): + INT VAR entry index; + insert (flist.thes, file name, entry index); + store file entry (flist.entry [entry index], entry text, position). + +file name: + TEXT CONST name pre :: compress (subtext (entry text, 1, 8)), + name post :: compress (subtext (entry text, 9, 11)); + IF name post <> "" + THEN name pre + "." + name post + ELSE name pre + FI. + +END PROC store file entry; + +PROC store file entry (FILEENTRY VAR fentry, TEXT CONST entry text, DIRPOS CONST position): + fentry.first cluster := real (entry text ISUB 14); + fentry.date and time := dos date + " " + dos time; + fentry.size := dint (entry text ISUB 15, entry text ISUB 16); + fentry.dirpos := position. + +dos date: + day + "." + month + "." + year. + +day: + text2 (code (entry text SUB 25) MOD 32). + +month: + text2 (code (entry text SUB 25) DIV 32 + 8 * (code (entry text SUB 26) MOD 2)). + +year: + text (80 + code (entry text SUB 26) DIV 2, 2). + +dos time: + hour + ":" + minute. + +hour: + text2 (code (entry text SUB 24) DIV 8). + +minute: + text2 (code (entry text SUB 23) DIV 32 + 8 * (code (entry text SUB 24) MOD 8)). + +END PROC store file entry; + +TEXT PROC text2 (INT CONST intvalue): + IF intvalue < 10 + THEN "0" + text (intvalue) + ELSE text (int value) + FI. + +END PROC text2; + +DIRPOS PROC file entry pos (FILELIST CONST flist, TEXT CONST file name): + INT CONST link index :: link (flist.thes, file name); + IF link index = 0 + THEN error stop ("Die Datei """ + file name + """ gibt es nicht") + FI; + flist.entry [link index].dir pos. + +END PROC file entry pos; + +PROC delete (FILELIST VAR flist, TEXT CONST file name): + INT VAR dummy; + delete (flist.thes, file name, dummy). + +END PROC delete; + +PROC file info (FILELIST CONST flist, TEXT CONST file name, REAL VAR first cluster no, storage): + INT CONST link index :: link (flist.thes, file name); + IF link index = 0 + THEN error stop ("Die Datei """ + file name + """ gibt es nicht") + FI; + first cluster no := flist.entry [link index].first cluster; + storage := flist.entry [link index].size + +END PROC file info; + +BOOL PROC contains (FILELIST VAR flist, TEXT CONST file name): + flist.thes CONTAINS file name + +END PROC contains; + +PROC list (FILE VAR f, FILELIST CONST flist): + INT VAR index := 0; + TEXT VAR name; + get (flist.thes, name, index); + WHILE index > 0 REP + list file; + get (flist.thes, name, index) + PER. + +list file: + write (f, centered name); + write (f, " "); + write (f, text (flist.entry [index].size, 11, 0)); + write (f, " Bytes belegt "); + write (f, flist.entry [index].date and time); +(*COND TEST*) + write (f, " +++ "); + write (f, text (flist.entry [index].first cluster)); +(*ENDCOND*) + line (f). + +centered name: + INT VAR point pos := pos (name, "."); + IF point pos > 0 + THEN name pre + "." + name post + ELSE text (name, 12) + FI. + +name pre: + text (subtext (name, 1, point pos - 1), 8). + +name post: + text (subtext (name, point pos + 1, point pos + 4), 3). + +END PROC list; + +(*-------------------------------------------------------------------------*) + +LET DIRENTRY = REAL, + + DIRLIST = STRUCT (THESAURUS thes, + ROW max dir entrys DIRENTRY entry); + +PROC init dir list (DIRLIST VAR dlist): + dlist.thes := empty thesaurus. + +END PROC init dir list; + +PROC store subdir entry (DIRLIST VAR dlist, TEXT CONST entry text): + INT VAR entry index; + insert (dlist.thes, subdir name, entry index); + dlist.entry [entry index] := real (entry text ISUB 14). + +subdir name: + TEXT CONST name pre :: compress (subtext (entry text, 1, 8)), + name post :: compress (subtext (entry text, 9, 11)); + IF name post <> "" + THEN name pre + "." + name post + ELSE name pre + FI. + +END PROC store subdir entry; + +REAL PROC first cluster of subdir (DIRLIST CONST dlist, TEXT CONST name): + INT CONST link index := link (dlist.thes, name); + IF link index = 0 + THEN error stop ("Das Unterverzeichnis """ + name + """ gibt es nicht") + FI; + dlist.entry [link index]. + +END PROC first cluster of subdir; + +BOOL PROC contains (DIRLIST CONST dlist, TEXT CONST subdir name): + dlist.thes CONTAINS subdir name + +END PROC contains; + +PROC list (FILE VAR f, DIRLIST CONST dlist): + INT VAR index := 0; + TEXT VAR name; + get (dlist.thes, name, index); + WHILE index > 0 REP + list dir; + get (dlist.thes, name, index) + PER. + +list dir: + write (f, centered name); + write (f, " <DIR>"); +(*COND TEST*) + write (f, " +++ "); + write (f, text (dlist.entry [index])); +(*ENDCOND*) + line (f). + +centered name: + INT VAR point pos := pos (name, "."); + IF point pos > 0 + THEN name pre + "." + name post + ELSE text (name, 12) + FI. + +name pre: + text (subtext (name, 1, point pos - 1), 8). + +name post: + text (subtext (name, point pos + 1, point pos + 4), 3). + +END PROC list; + +(*-------------------------------------------------------------------------*) + +LET DIR = BOUND STRUCT (FILELIST filelist, + DIRLIST dirlist, + FREELIST freelist, + TEXT path); + +DIR VAR dir; +DATASPACE VAR dir ds; +INITFLAG VAR dir ds used := FALSE; + +PROC open dir (TEXT CONST path string): + init dir block io; + init dir ds; + dir.path := path string; + load main dir; + TEXT VAR rest path := path string; + WHILE rest path <> "" REP + TEXT CONST sub dir name := next sub dir name (rest path); + load sub dir + PER. + +load main dir: + init file list (dir.filelist); + init dir list (dir.dirlist); + init free list (dir.free list, 0.0); + store end of dir (dir.freelist, dirpos (last main dir sector, 15)); + BOOL VAR was last dir sector := FALSE; + REAL VAR block no := first main dir sector; + INT VAR i; + FOR i FROM 1 UPTO dir sectors REP + load dir block (block no, was last dir sector); + block no INCR 1.0 + UNTIL was last dir sector + PER. + +first main dir sector: + real (begin of dir). + +last main dir sector: + real (begin of dir + dir sectors - 1). + +load sub dir: + REAL VAR cluster no := first cluster of sub dir (dir.dirlist, sub dir name); + was last dir sector := FALSE; + init file list (dir.filelist); + init dir list (dir.dirlist); + init free list (dir.free list, cluster no); + WHILE NOT is last fat chain entry (cluster no) REP + load sub dir entrys of cluster; + cluster no := fat entry (cluster no) + UNTIL was last dir sector + PER. + +load sub dir entrys of cluster: + store end of dir (dir.freelist, dirpos (last block no of cluster, 15)); + block no := begin of cluster (cluster no); + FOR i FROM 1 UPTO sectors per cluster REP + load dir block (block no, was last dir sector); + block no INCR 1.0 + UNTIL was last dir sector + PER. + +last block no of cluster: + begin of cluster (cluster no) + real (sectors per cluster - 1). + +END PROC open dir; + +PROC load dir block (REAL CONST block no, BOOL VAR was last block): + was last block := FALSE; + read dir block (block no); + INT VAR entry no; + TEXT VAR entry; + FOR entry no FROM 0 UPTO 15 REP + get dir entry (entry, entry no); + process entry + UNTIL was last block + PER. + +process entry: + SELECT pos (""0"."229"", entry SUB 1) OF + CASE 1: end of dir search + CASE 2: (* root des aktuellen directorys oder des übergeordneten, also nichts tun *) + CASE 3: free entry + OTHERWISE volume label or file entry or subdir entry + END SELECT. + +end of dir search: + was last block := TRUE; + store begin of free area (dir.freelist, dir pos (block no, entry no)). + +free entry: + store (dir.freelist, dir pos (block no, entry no)). + +volume label or file entry or subdir entry: + INT CONST byte 11 :: code (entry SUB 12); + IF (byte 11 AND 8) > 0 + THEN (* volume label *) + ELIF (byte 11 AND 16) > 0 + THEN sub dir entry + ELSE file entry + FI. + +sub dir entry: + store subdir entry (dir.dir list, entry). + +file entry: + store file entry (dir.file list, entry, dir pos (block no, entry no)). + +END PROC load dir block; + +TEXT PROC next subdir name (TEXT VAR path string): + TEXT VAR subdir name; + IF (path string SUB 1) <> "\" + THEN error stop ("ungültige Pfadbezeichnung") + FI; + INT CONST backslash pos :: pos (path string, "\", 2); + IF backslash pos = 0 + THEN subdir name := subtext (path string, 2); + path string := "" + ELSE subdir name := subtext (path string, 2, backslash pos - 1); + path string := subtext (path string, backslash pos) + FI; + dos name (subdir name, read modus). + +END PROC next subdir name; + +PROC init dir ds: + IF initialized (dir ds used) + THEN forget (dir ds) + FI; + dir ds := nilspace; + dir := dir ds. + +END PROC init dir ds; + +PROC insert dir entry (TEXT CONST name, REAL CONST start cluster, storage): + DIRPOS CONST ins pos :: free dirpos (dir.free list); + TEXT CONST entry string :: entry name + ""32"" + (10 * ""0"") + dos time + + dos date + entry start cluster + entry storage; + write entry on disk; + write entry in dir ds. + +entry name: + INT CONST point pos := pos (name, "."); + IF point pos > 0 + THEN subtext (name, 1, point pos - 1) + (9 - point pos) * " " + + subtext (name, point pos + 1) + (3 - LENGTH name + point pos) * " " + ELSE name + (11 - LENGTH name) * " " + FI. + +dos time: + TEXT CONST akt time :: time of day (clock (1)); + code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8). + +hour: + int (subtext (akt time, 1, 2)). + +minute: + int (subtext (akt time, 4, 5)). + +dos date: + TEXT CONST akt date :: date (clock (1)); + code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8). + +day: + int (subtext (akt date, 1, 2)). + +month: + int (subtext (akt date, 4, 5)). + +year: + int (subtext (akt date, 7, 8)). + +entry start cluster: + TEXT VAR buffer2 := "12"; + replace (buffer2, 1, low word (start cluster)); + buffer2. + +entry storage: + TEXT VAR buffer4 := "1234"; + replace (buffer4, 1, low word (storage)); + replace (buffer4, 2, high word (storage)); + buffer4. + +write entry on disk: + read dir block (block no (ins pos)); + put dir entry (entry string, entry no (ins pos)); + write dir block. + +write entry in dir ds: + store file entry (dir.file list, entry string, ins pos). + +END PROC insert dir entry; + +PROC delete dir entry (TEXT CONST name): + TEXT VAR entry; + DIRPOS CONST del pos :: file entry pos (dir.filelist, name); + read dir block (block no (del pos)); + get dir entry (entry, entry no (del pos)); + put dir entry (""229"" + subtext (entry, 2, 32), entry no (del pos)); + write dir block; + delete (dir.filelist, name); + store (dir.freelist, del pos). + +END PROC delete dir entry; + +PROC format dir: + init dir block io; + init dir ds; + build empty dir block; + REAL VAR block no := real (begin of dir); + disable stop; + FOR i FROM 1 UPTO dir sectors REP + write dir block (block no); + block no INCR 1.0 + PER; + enable stop; + dir.path := ""; + init file list (dir.file list); + init dir list (dir.dir list); + init free list (dir.free list, 0.0); + store begin of free area (dir.free list, dir pos (real (begin of dir), 0)); + store end of dir (dir.free list, dir pos (last main dir sector, 15)). + +build empty dir block: + INT VAR i; + FOR i FROM 0 UPTO 15 REP + put dir entry (32 * ""0"", i) + PER. + +last main dir sector: + real (begin of dir + dir sectors - 1). + +END PROC format dir; + +PROC file info (TEXT CONST file name, REAL VAR start cluster, size): + file info (dir.file list, file name, start cluster, size) + +END PROC file info; + +THESAURUS PROC all files: + THESAURUS VAR t := dir.filelist.thes; + t + +END PROC all files; + +THESAURUS PROC all subdirs: + dir.dirlist.thes + +END PROC all subdirs; + +BOOL PROC file exists (TEXT CONST file name): + contains (dir.filelist, file name) + +END PROC file exists; + +BOOL PROC subdir exists (TEXT CONST subdir name): + contains (dir.dirlist, subdir name) + +END PROC subdir exists; + +PROC dir list (DATASPACE VAR ds): + open list file; + head line (list file, list file head); + list (list file, dir.file list); + list (list file, dir.dir list). + +open list file: + forget (ds); + ds := nilspace; + FILE VAR list file := sequential file (output, ds); + putline (list file, ""). + +list file head: + "DOS" + path string. + +path string: + IF dir.path <> "" + THEN " PATH: " + dir.path + ELSE "" + FI. + +END PROC dir list; + +END PACKET dir; + diff --git a/system/dos/1.8.7/src/disk descriptor.dos b/system/dos/1.8.7/src/disk descriptor.dos new file mode 100644 index 0000000..0b0d7fc --- /dev/null +++ b/system/dos/1.8.7/src/disk descriptor.dos @@ -0,0 +1,339 @@ +PACKET dos disk DEFINES (* Copyright (C) 1986, 87 *) + (* Frank Klapper *) + (* Referenz: 3-22 *) (* 11.09.87 *) + + open dos disk, + + sectors per cluster, + fat copies, + dir sectors, + media descriptor, + fat sectors, + + begin of fat, + fat entrys, + begin of dir, + begin of cluster, + cluster size, + + bpb exists, + write bpb, + + eu block, + + bpb dump modus: + +INITFLAG VAR bpb ds initialisiert := FALSE; +DATASPACE VAR bpb ds; +BOUND STRUCT (ALIGN dummy, ROW 512 INT daten) VAR bpb; + +BOOL VAR bpb dump flag := FALSE; + +REAL VAR begin of data area; +INT VAR sectors per track, + heads; + +IF exists ("shard interface") + THEN load shard interface table +FI; + +TEXT CONST bpb type 254 :: ""00""00""00"" + + ""69""85""77""69""76""66""80""66"" + + ""00""02"" + + ""01"" + + ""01""00"" + + ""02"" + + ""64""00"" + + ""64""01"" + + ""254"" + + ""01""00"" + + ""08""00"" + + ""01""00"" + + ""00""00"", + bpb type 255 :: ""00""00""00"" + + ""69""85""77""69""76""66""80""66"" + + ""00""02"" + + ""02"" + + ""01""00"" + + ""02"" + + ""112""00"" + + ""128""02"" + + ""255"" + + ""01""00"" + + ""08""00"" + + ""02""00"" + + ""00""00""; + +PROC open dos disk: + enable stop; + bpb ds an bound koppeln; + bpb lesen; + IF bpb ungueltig + THEN versuche pseudo bpb zu verwenden + FI; + ueberpruefe bpb auf gueltigkeit; + globale variablen initialisieren; + IF bpb dump flag + THEN dump schreiben + FI. + +bpb ds an bound koppeln: + IF NOT initialized (bpb ds initialisiert) + THEN bpb ds := nilspace; + bpb := bpb ds + FI. + +bpb lesen: + INT VAR return; + check rerun; + read block (bpb ds, 2, 0, return); + IF return <> 0 + THEN lesefehler (return) + FI. + +bpb ungueltig: + (* Byte 12 = Byte 13 = ... = Byte 23 <==> Word 6 = ... = Word 11 *) + INT VAR word no; + FOR word no FROM 6 UPTO 10 REP + IF bpb.daten [word no + 1] <> bpb.daten [word no + 2] + THEN LEAVE bpb ungueltig WITH FALSE + FI + PER; + TRUE. + +versuche pseudo bpb zu verwenden: + lies ersten fat sektor; + IF fat sektor gueltig und pseudo bpb vorhanden + THEN pseudo bpb laden + ELSE error stop ("Format unbekannt") + FI. + +lies ersten fat sektor: + (* da der bpb in diesem Fall ungültig, lese ich den fat sektor in den bpb + Datenraum *) + check rerun; + read block (bpb ds, 2, 1, return); + IF return <> 0 + THEN lesefehler (return) + FI. + +fat sektor gueltig und pseudo bpb vorhanden: + TEXT VAR fat start := "1234"; + replace (fat start, 1, bpb.daten [1]); + replace (fat start, 2, bpb.daten [2]); + (fat start SUB 2) = ""255"" CAND (fat start SUB 3) = ""255"" CAND + pseudo bpb vorhanden. + +pseudo bpb vorhanden: + pos (""254""255"", fat start SUB 1) > 0. + +pseudo bpb laden: + INT VAR i; + FOR i FROM 1 UPTO 15 REP + bpb.daten [i] := bpb puffer ISUB i + PER. + +bpb puffer: + IF pseudo bpb name = ""255"" + THEN bpb type 255 + ELSE bpb type 254 + FI. + +pseudo bpb name: + fat start SUB 1. + +ueberpruefe bpb auf gueltigkeit: + IF bytes per sector <> 512 + THEN error stop ("DOS Format nicht implementiert (unzulässige Sektorgröße)") + FI; + IF (fat sectors > 64) + THEN error stop ("ungültige DOS Disk (BPB)") + FI. + +globale variablen initialisieren: + sectors per track := bpb byte (25) * 256 + bpb byte (24); + heads := bpb byte (27) * 256 + bpb byte (26); + begin of data area := real (reserved sectors + fat copies * fat sectors + dir sectors). + +dump schreiben: + dump ("Sektoren pro Cluster", sectors per cluster); + dump ("Fat Kopien ", fat copies); + dump ("Dir Sektoren ", dir sectors); + dump ("Media Descriptor ", media descriptor); + dump ("Sektoren pro Fat ", fat sectors); + dump ("Fat Anfang (0) ", begin of fat (0)); + dump ("Fat Einträge ", fat entrys); + dump ("Dir Anfang ", begin of dir). + +END PROC open dos disk; + +PROC lesefehler (INT CONST fehler code): + error stop (fehlertext). + +fehlertext: + SELECT fehler code OF + CASE 1: "Diskettenlaufwerk nicht betriebsbereit" + CASE 2: "Lesefehler" + OTHERWISE "Lesefehler " + text (fehler code) + END SELECT. + +END PROC lesefehler; + +TEXT VAR konvertier puffer := "12"; + +INT PROC bpb byte (INT CONST byte no): + replace (konvertier puffer, 1, bpb.daten [byte no DIV 2 + 1]); + code (konvertier puffer SUB puffer pos). + +puffer pos: + IF even byte no + THEN 1 + ELSE 2 + FI. + +even byte no: + (byte no MOD 2) = 0. + +END PROC bpb byte; + +INT PROC bytes per sector: + bpb byte (12) * 256 + bpb byte (11) + +END PROC bytes per sector; + +INT PROC sectors per cluster: + bpb byte (13) + +END PROC sectors per cluster; + +INT PROC reserved sectors: + bpb byte (15) * 256 + bpb byte (14) + +END PROC reserved sectors; + +INT PROC fat copies: + bpb byte (16) + +END PROC fat copies; + +INT PROC dir sectors: + dir entrys DIV dir entrys per sector. + +dir entrys: + bpb byte (18) * 256 + bpb byte (17). + +dir entrys per sector: + 16. + +END PROC dir sectors; + +REAL PROC dos sectors: + real (bpb byte (20)) * 256.0 + real (bpb byte (19)) + +END PROC dos sectors; + +INT PROC media descriptor: + bpb byte (21) + +END PROC media descriptor; + +INT PROC fat sectors: + bpb byte (23) * 256 + bpb byte (22) + +END PROC fat sectors; + +INT PROC begin of fat (INT CONST fat copy no): + (* 0 <= fat copy no <= fat copies - 1 *) + reserved sectors + fat copy no * fat sectors + +END PROC begin of fat; + +INT PROC fat entrys: + anzahl daten cluster + 2. + +anzahl daten cluster: + int ((dos sectors - tabellen sektoren) / real (sectors per cluster)). + +tabellen sektoren: + real (reserved sectors + fat copies * fat sectors + dir sectors). + +END PROC fat entrys; + +INT PROC begin of dir: + reserved sectors + fat copies * fat sectors. + +END PROC begin of dir; + +REAL PROC begin of cluster (REAL CONST cluster no): + begin of data area + (cluster no - 2.0) * real (sectors per cluster) + +END PROC begin of cluster; + +INT PROC cluster size: + 512 * sectors per cluster + +END PROC cluster size; + +BOOL PROC bpb exists (INT CONST no): + + exists ("bpb ds") AND no > 0 AND no < 4. + +END PROC bpb exists; + +PROC write bpb (INT CONST no): + INT VAR return; + write block (old ("bpb ds"), no + 1, 0, 0, return); + IF return <> 0 + THEN error stop ("Schreibfehler") + FI. + +END PROC write bpb; + +(* Da DOS-Partitionen maximal 32 MByte groß sein können, können die Blocknummern + durch 16 BIT unsigned Integer dargestellt werden. Die Werte die die 'eublock'- + Prozeduren liefern sind als solche zu verstehen *) + +INT PROC eu block (INT CONST dos block no): + IF hd version + THEN dos block no + ELSE dos block no floppy format + FI. + +dos block no floppy format: + IF page format + THEN head * eu sectors per head + trac * eu sectors + sector + ELSE head * eu sectors + trac * abs (eu heads) * eu sectors + sector + FI. + +page format: + eu heads < 0. + +sector: + dos block no MOD sectors per track. + +trac: + (dos block no DIV sectors per track) DIV heads. + +head: + (dos block no DIV sectors per track) MOD heads. + +eu sectors per head: + eu sectors * eu tracks. + +eu sectors: + eu last sector - eu first sector + 1. + +END PROC eu block; + +INT PROC eu block (REAL CONST dos block no): + eublock (low word (dos block no)). + +END PROC eublock; + +PROC bpb dump modus (BOOL CONST status): + bpb dump flag := status + +END PROC bpb dump modus; + +END PACKET dos disk; + diff --git a/system/dos/1.8.7/src/dos hd inserter b/system/dos/1.8.7/src/dos hd inserter new file mode 100644 index 0000000..24be82b --- /dev/null +++ b/system/dos/1.8.7/src/dos hd inserter @@ -0,0 +1,41 @@ +IF NOT single user + THEN do ("IF name (myself) <> ""DOS HD"" THEN error stop (""Bitte der Task den Namen 'DOS HD' geben und neu starten"") FI"); +FI; + +archive ("austausch"); +check off; +command dialogue (FALSE); +fetch ("insert.dos", archive); +fetch ("bpb ds", archive); +IF single user + THEN do (PROC (TEXT CONST) gen s, ALL "insert.dos"); + gen s ("manager/S.dos") + ELSE fetch (ALL "insert.dos", archive); + fetch ("manager/M.dos", archive); + release (archive); + do (PROC (TEXT CONST) gen m, ALL "insert.dos"); + gen m ("manager/M.dos"); +FI; +do ("hd version (TRUE)"); +forget ("insert.dos", quiet); +forget ("dos hd inserter", quiet); +IF NOT single user + THEN do ("dos manager (29)") +FI. + +single user: + (pcb (9) AND 255) = 1. + +PROC gen m (TEXT CONST name): + insert (name); + forget (name, quiet) + +END PROC gen m; + +PROC gen s (TEXT CONST t): + fetch (t, archive); + insert (t); + forget (t, quiet) + +END PROC gen s; + diff --git a/system/dos/1.8.7/src/dos inserter b/system/dos/1.8.7/src/dos inserter new file mode 100644 index 0000000..2f70b28 --- /dev/null +++ b/system/dos/1.8.7/src/dos inserter @@ -0,0 +1,59 @@ +IF NOT single user + THEN do ("IF name (myself) <> ""DOS"" THEN error stop (""Bitte der Task den Namen 'DOS' geben und neu starten"") FI"); +FI; + +archive ("austausch"); +check off; +command dialogue (FALSE); +hol ("shard interface"); +hol ("bpb ds"); +hol ("insert.dos"); +IF single user + THEN do (PROC (TEXT CONST) gen s, ALL "insert.dos"); + gen s ("manager/S.dos") + ELSE do (PROC (TEXT CONST) hol, ALL "insert.dos"); + hol ("manager/M.dos"); + release (archive); + do (PROC (TEXT CONST) gen m, ALL "insert.dos"); + gen m ("manager/M.dos"); + putline ("jetzt mit 'dos manager' bzw. 'dos manager (channnel)' starten"); +FI; +do ("hd version (FALSE)"); +do ("load shard interface table"); +forget ("shard interface", quiet); +forget ("insert.dos", quiet); +forget ("dos inserter", quiet). + +single user: + (pcb (9) AND 255) = 1. + +PROC gen m (TEXT CONST name): + insert (name); + forget (name, quiet) + +END PROC gen m; + +PROC gen s (TEXT CONST t): + hol (t); + insert (t); + forget (t, quiet) + +END PROC gen s; + +PROC hol (TEXT CONST t): + IF NOT exists (t) + THEN fetch (t, archive) + FI + +END PROC hol; + + + + + + + + + + + diff --git a/system/dos/1.8.7/src/dump b/system/dos/1.8.7/src/dump new file mode 100644 index 0000000..5138162 --- /dev/null +++ b/system/dos/1.8.7/src/dump @@ -0,0 +1,49 @@ +PACKET dump DEFINES + + dump: + +TEXT VAR ergebnis := ""; + +PROC dump (TEXT CONST kommentar, dump text): + ergebnis := kommentar; + ergebnis CAT ": "; + INT VAR i; + FOR i FROM 1 UPTO LENGTH dump text REP + zeichen schreiben + PER; + ergebnis schreiben. + +zeichen schreiben: + INT CONST char code :: code (dump text SUB i); + IF char code < 32 + THEN ergebnis CAT ("$" + text (char code) + "$") + ELSE ergebnis CAT code (char code) + FI. + +END PROC dump; + +PROC dump (TEXT CONST kommentar, INT CONST dump int): + ergebnis := kommentar; + ergebnis CAT ": "; + ergebnis CAT text (dump int); + ergebnis schreiben. + +END PROC dump; + +PROC dump (TEXT CONST kommentar, REAL CONST dump real): + ergebnis := kommentar; + ergebnis CAT ": "; + ergebnis CAT text (dump real); + ergebnis schreiben. + +END PROC dump; + +PROC ergebnis schreiben: + FILE VAR f := sequential file (output, "logbuch"); + putline (f, ergebnis); + ergebnis := "". + +END PROC ergebnis schreiben; + +END PACKET dump; + diff --git a/system/dos/1.8.7/src/eu disk descriptor b/system/dos/1.8.7/src/eu disk descriptor new file mode 100644 index 0000000..5a61367 --- /dev/null +++ b/system/dos/1.8.7/src/eu disk descriptor @@ -0,0 +1,107 @@ +PACKET eu disk DEFINES (* Copyright (C) 1986, 87 *) + (* Frank Klapper *) + (* 05.01.87 *) + load shard interface table, + open eu disk, + eu size, + eu heads, + eu tracks, + eu first sector, + eu last sector: + +LET table length = 15, + + size field = 1, + head field = 2, + track field = 3, + first sector field = 4, + last sector field = 5; + +ROW table length ROW 5 INT VAR format table; + +INT VAR table top := 0, + table pointer; + +PROC open eu disk: + enable stop; + init check rerun; + IF hd version + THEN LEAVE open eu disk + FI; + INT CONST blocks := archive blocks; + IF blocks <= 0 + THEN error stop ("keine Diskette eingelegt") + FI; + search format table entry. + +search format table entry: + IF table top < 1 + THEN error stop ("SHard-Interfacetabelle nicht geladen") + FI; + table pointer := 1; + WHILE format table [table pointer][size field] <> blocks REP + table pointer INCR 1; + IF table pointer > table top + THEN error stop ("Diskettenformat nicht implementiert") + FI + PER. + +END PROC open eu disk; + +PROC load shard interface table: + FILE VAR f := sequential file (input, "shard interface"); + TEXT VAR line; + table top := 0; + WHILE NOT eof (f) REP + get line (f, line); + IF (line SUB 1) <> ";" + THEN load line + FI + PER. + +load line: + table top INCR 1; + IF table top > table length + THEN error stop ("Shard Interface Tabelle zu groß") + FI; + INT VAR blank pos := 1; + format table [table top][size field] := next int; + format table [table top][head field] := next int; + format table [table top][track field] := next int; + format table [table top][first sector field] := next int; + format table [table top][last sector field] := next int. + +next int: + line := compress (subtext (line, blank pos)) + " "; + blank pos := pos (line, " "); + int (subtext (line, 1, blank pos - 1)). + +END PROC load shard interface table; + +INT PROC eu size: + format table [table pointer][size field] + +END PROC eu size; + +INT PROC eu heads: + format table [table pointer][head field] + +END PROC eu heads; + +INT PROC eu tracks: + format table [table pointer][track field] + +END PROC eu tracks; + +INT PROC eu first sector: + format table [table pointer][first sector field] + +END PROC eu first sector; + +INT PROC eu last sector: + format table [table pointer][last sector field] + +END PROC eu last sector; + +END PACKET eu disk; + diff --git a/system/dos/1.8.7/src/fat.dos b/system/dos/1.8.7/src/fat.dos new file mode 100644 index 0000000..2890b1a --- /dev/null +++ b/system/dos/1.8.7/src/fat.dos @@ -0,0 +1,369 @@ +PACKET dos fat DEFINES (* Copyright (C) 1985, 86, 87 *) + (* Frank Klapper *) + (* 11.09.87 *) + read fat, + write fat, + first fat block ok, + clear fat ds, + format fat, + + fat entry, + last fat chain entry, + is last fat chain entry, + erase fat chain, + available fat entry: + + (* Referenz: 4. *) + +LET fat size = 16 384, (* maximal 64 Sektoren a 512 Byte (256 Worte) *) + max anzahl fat sektoren = 64; + +LET FAT = BOUND STRUCT (ALIGN dummy, + ROW 256 INT block row, (* für Kopie des 1. Fatsektors *) + ROW fat size INT fat row); + +DATASPACE VAR fat ds; +INITFLAG VAR fat ds used := FALSE; +FAT VAR fat struktur; + +.fat: fat struktur.fat row. + +REAL VAR erster moeglicher freier eintrag; + +BOOL VAR kleines fat format; + +PROC read fat: + fat ds initialisieren; + fat bloecke lesen; + fat format bestimmen; + erster moeglicher freier eintrag := 2.0. + +fat ds initialisieren: + clear fat ds; + fat struktur := fat ds. + +fat bloecke lesen: + LET kein testblock = FALSE; + INT VAR block no; + FOR block no FROM 0 UPTO fat sectors - 1 REP + fat block lesen (block no, kein testblock) + PER. + +fat format bestimmen: + IF fat entrys <= 4086 + THEN kleines fat format := TRUE + ELSE kleines fat format := FALSE + FI. + +END PROC read fat; + +PROC write fat: + disable stop; + INT VAR block nr; + FOR block nr FROM 0 UPTO fat sectors - 1 REP + fat block schreiben (block nr) + PER. + +END PROC write fat; + +BOOL PROC first fat block ok: + (* überprüft, ob der erste Block der Fat auf Diskette und im Speicher + gleich ist *) + enable stop; + LET testblock = TRUE; + fat block lesen (0, testblock); + INT VAR i; + FOR i FROM 1 UPTO 256 REP + vergleiche woerter + PER; + TRUE. + +vergleiche woerter: + IF fat [i] <> fat struktur.block row [i] + THEN LEAVE first fat block ok WITH FALSE + FI. + +END PROC first fat block ok; + +PROC clear fat ds: + IF initialized (fat ds used) + THEN forget (fat ds) + FI; + fat ds := nilspace. + +END PROC clear fat ds; + +PROC format fat: + fat ds initialisieren; + fat format bestimmen; + erster moeglicher freier eintrag := 2.0; + write first four fat bytes; + write other fat bytes; + vermerke schreibzugriffe; + write fat. + +fat ds initialisieren: + clear fat ds; + fat struktur := fat ds. + +fat format bestimmen: + IF fat entrys <= 4086 + THEN kleines fat format := TRUE + ELSE kleines fat format := FALSE + FI. + +write first four fat bytes: + fat [1] := word (media descriptor, 255); + IF kleines fat format + THEN fat [2] := word (255, 0) + ELSE fat [2] := word (255, 255) + FI. + +write other fat bytes: + INT VAR i; + FOR i FROM 3 UPTO 256 * fat sectors REP + fat [i] := 0 + PER. + +vermerke schreibzugriffe: + FOR i FROM 0 UPTO fat sectors - 1 REP + schreibzugriff (i) + PER. + +END PROC format fat; + +(*-------------------------------------------------------------------------*) + +REAL PROC fat entry (REAL CONST real entry no): + (* 0 <= entry no <= 22 000 *) + INT CONST entry no :: int (real entry no); + IF kleines fat format + THEN construct 12 bit value + ELSE dint (fat [entry no + 1], 0) + FI. + +construct 12 bit value: + INT CONST first byte no := entry no + entry no DIV 2; + IF entry no MOD 2 = 0 + THEN real ((right byte MOD 16) * 256 + left byte) + ELSE real (right byte * 16 + left byte DIV 16) + FI. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (first byte no + 1). + +END PROC fat entry; + +TEXT VAR convert buffer := "12"; + +INT PROC fat byte (INT CONST no): + replace (convert buffer, 1, word); + IF even byte no + THEN code (convert buffer SUB 1) + ELSE code (convert buffer SUB 2) + FI. + +even byte no: + no MOD 2 = 0. + +word: + fat [no DIV 2 + 1]. + +END PROC fat byte; + +PROC fat entry (REAL CONST real entry no, real value): + (* 0 <= entry no <= 22 000 *) + INT CONST entry no :: int (real entry no), + value :: low word (real value); + IF kleines fat format + THEN write 12 bit value + ELSE fat [entry no + 1] := value; + schreibzugriff (entry no DIV 256) + FI; + update first possible available entry. + +write 12 bit value: + INT CONST first byte no :: entry no + entry no DIV 2; + schreibzugriff (fat block of first byte); + schreibzugriff (fat block of second byte); + write value. + +fat block of first byte: + first byte no DIV 512. + +fat block of second byte: + second byte no DIV 512. + +write value: + IF even entry no + THEN write fat byte (first byte no, value MOD 256); + write fat byte (second byte no, + (right byte DIV 16) * 16 + value DIV 256) + ELSE write fat byte (first byte no, + (left byte MOD 16) + 16 * (value MOD 16)); + write fat byte (second byte no, value DIV 16) + FI. + +even entry no: + entry no MOD 2 = 0. + +second byte no: + first byte no + 1. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (second byte no). + +update first possible available entry: + IF value = 0 + THEN erster moeglicher freier eintrag := + min (erster moeglicher freier eintrag, real entry no) + FI. + +END PROC fat entry; + +PROC write fat byte (INT CONST byte no, new value): + read old word; + change byte; + write new word. + +read old word: + replace (convert buffer, 1, word). + +write new word: + word := convert buffer ISUB 1. + +word: + fat [byte no DIV 2 + 1]. + +change byte: + replace (convert buffer, byte pos, code (new value)). + +byte pos: + byte no MOD 2 + 1. + +END PROC write fat byte; + +REAL PROC last fat chain entry: + IF kleines fat format + THEN 4 088.0 + ELSE 65 528.0 + FI. + +END PROC last fat chain entry; + +BOOL PROC is last fat chain entry (REAL CONST value): + value >= last fat chain entry + +END PROC is last fat chain entry; + +PROC erase fat chain (REAL CONST first entry no): + REAL VAR next entry no := first entry no, + act entry no := 0.0; + WHILE next entry exists REP + act entry no := next entry no; + next entry no := fat entry (act entry no); + fat entry (act entry no, 0.0) + PER. + +next entry exists: + NOT is last fat chain entry (next entry no). + +END PROC erase fat chain; + +REAL PROC available fat entry: + (* da die fat weniger als 22 000 Einträge umfaßt, kann ich diese als + INTEGER berechnen *) + INT VAR i; + REAL VAR real i := erster moeglicher freier eintrag; + FOR i FROM int (erster moeglicher freier eintrag) UPTO fat entrys - 1 REP + IF fat entry (real i) = 0.0 + THEN erster moeglicher freier eintrag := real i; + LEAVE available fat entry WITH erster moeglicher freier eintrag + FI; + real i INCR 1.0 + PER; + close work; + error stop ("MS-DOS Datentraeger voll"); + 1.0e99. + +END PROC available fat entry; + +(*-------------------------------------------------------------------------*) + +PROC fat block lesen (INT CONST block nr, BOOL CONST test block): + (* 0 <= block nr <= fat sectors - 1 *) + disable stop; + IF NOT test block + THEN kein schreibzugriff (block nr) + FI; + INT VAR kopie nr; + FOR kopie nr FROM 0 UPTO fat copies - 1 REP + clear error; + read disk block (fat ds, ds seiten nr, disk block nr) + UNTIL NOT is error + PER; + IF is error + THEN close work + FI. + +ds seiten nr: + IF test block + THEN 2 + ELSE block nr + 2 + 1 + FI. + +disk block nr: + begin of fat (kopie nr) + block nr. + +END PROC fat block lesen; + +PROC fat block schreiben (INT CONST block nr): + IF war schreibzugriff (block nr) + THEN wirklich schreiben + FI. + +wirklich schreiben: + disable stop; + INT VAR kopie nr; + FOR kopie nr FROM 0 UPTO fat copies - 1 REP + write disk block and close work if error (fat ds, ds seiten nr, disk block nr) + PER; + kein schreibzugriff (block nr). + +ds seiten nr: + block nr + 2 + 1. + +disk block nr: + begin of fat (kopie nr) + block nr. + +END PROC fat block schreiben; + +(*-------------------------------------------------------------------------*) + +ROW max anzahl fat sektoren BOOL VAR schreib zugriff tabelle; + +PROC schreibzugriff (INT CONST fat sektor): + schreibzugriff tabelle [fat sektor + 1] := TRUE + +END PROC schreibzugriff; + +PROC kein schreibzugriff (INT CONST fat sektor): + schreibzugriff tabelle [fat sektor + 1] := FALSE + +END PROC kein schreibzugriff; + +BOOL PROC war schreibzugriff (INT CONST fat sektor): + schreibzugriff tabelle [fat sektor + 1] + +END PROC war schreibzugriff; + +(*-------------------------------------------------------------------------*) + +END PACKET dos fat; + diff --git a/system/dos/1.8.7/src/fetch b/system/dos/1.8.7/src/fetch new file mode 100644 index 0000000..7cb7571 --- /dev/null +++ b/system/dos/1.8.7/src/fetch @@ -0,0 +1,371 @@ +PACKET fetch DEFINES (* Copyright (C) 1985, 86, 87 *) + (* Frank Klapper *) + (* 27.04.87 *) + fetch, + check file: + +LET ascii = 1, + ascii german = 2, + transparent = 3, + row text = 5, + ds = 6, + dump = 7, + atari st = 10, + ibm = 11, + + (*line end chars = ""10""12""13"",*) + min line end char = ""10"", + max line end char = ""13"", + lf = ""10"", + cr = ""13"", + tab code = 9, + lf code = 10, + ff code = 12, + cr code = 13, + ctrl z = ""26"", + + page cmd = "#page#", + + row text length = 4000, + row text type = 1000; + +BOUND STRUCT (INT size, + ROW row text length TEXT cluster row) VAR cluster struct; + +FILE VAR file; + +TEXT VAR buffer; +INT VAR buffer length; + +PROC fetch (TEXT CONST name, DATASPACE VAR file ds, INT CONST mode): + + SELECT mode OF + CASE ascii, ascii german, atari st, ibm, transparent: + fetch filemode (file ds, name, mode) + CASE row text : fetch row textmode (file ds, name) + CASE ds : fetch dsmode (file ds, name) + CASE dump : fetch dumpmode (file ds, name) + OTHERWISE error stop ("Unzulässige Betriebsart") + END SELECT. + +END PROC fetch; + +PROC fetch filemode (DATASPACE VAR file space, TEXT CONST name, + INT CONST code type): + enable stop; + initialize fetch filemode; + open fetch dos file (name); + WHILE NOT was last fetch cluster REP + get text of cluster; + write lines; +(***************************************) + IF lines (file) > 3900 + THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES KÖNNEN DATEN FEHLEN <<<"); + LEAVE fetch filemode + FI; +(***************************************) + UNTIL file end via ctrl z + PER; + write last line if necessary; + close fetch dos file. + +initialize fetch filemode: + buffer := ""; + buffer length := 0; + forget (file space); + file space := nilspace; + file := sequential file (output, file space); + BOOL VAR file end via ctrl z := FALSE. + +get text of cluster: + cat next fetch dos cluster (buffer); + IF ascii code + THEN ctrl z is buffer end + FI; + adapt code (buffer, buffer length + 1, code type); + buffer length := length (buffer). + +ascii code: + (code type = ascii) OR (code type = ascii german). + +ctrl z is buffer end: + INT CONST ctrl z pos :: pos (buffer, ctrl z, buffer length + 1); + file end via ctrl z := ctrl z pos > 0; + IF file end via ctrl z + THEN buffer := subtext (buffer, 1, ctrl z pos - 1); + buffer length := length (buffer) + FI. + +write lines: + INT VAR line begin pos := 1, line end pos; + compute line end pos; + WHILE line end pos > 0 REP + putline (file, subtext (buffer, line begin pos, line end pos)); + exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type); + line begin pos := line end pos + 1; + compute line end pos + PER; + buffer := subtext (buffer, line begin pos); + buffer length := length (buffer); + IF buffer length > 5 000 + THEN putline (file, buffer); + exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type); + buffer := ""; + buffer length := 0 + FI. + +compute line end pos: + line end pos := line begin pos; + REP + line end pos := pos (buffer, min line end char, max line end char, line end pos); + INT CONST line end code :: code (buffer SUB line end pos); + SELECT line end code OF + CASE lf code: look for cr + CASE 11 : line end pos INCR 1 + CASE cr code: look for lf + END SELECT + UNTIL line end code <> 11 + PER. + +look for cr: + IF line end pos = buffer length + THEN line end pos := 0 + ELIF (buffer SUB line end pos + 1) = cr + THEN line end pos INCR 1 + FI. + +look for lf: + IF line end pos = buffer length + THEN line end pos := 0 + ELIF (buffer SUB line end pos + 1) = lf + THEN line end pos INCR 1 + FI. + +write last line if necessary: + IF buffer length > 0 + THEN putline (file, buffer); + exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type); + FI. + +END PROC fetch filemode; + +PROC adapt code (TEXT VAR text buffer, INT CONST start pos, code type): + SELECT code type OF + CASE ascii : cancel bit 8 + CASE ascii german: cancel bit 8; ascii german adaption + CASE atari st : atari st adaption + CASE ibm : ibm adaption + (*CASE transparent : do nothing *) + END SELECT. + +cancel bit 8: + INT VAR set pos := pos (text buffer, ""128"", ""255"", start pos); + WHILE set pos > 0 REP + replace (text buffer, set pos, seven bit char); + set pos := pos (text buffer, ""128"", ""255"", set pos + 1) + PER. + +seven bit char: + code (code (text buffer SUB set pos) AND 127). + +ascii german adaption: + change all by replace (text buffer, start pos, "[", "Ä"); + change all by replace (text buffer, start pos, "\", "Ö"); + change all by replace (text buffer, start pos, "]", "Ü"); + change all by replace (text buffer, start pos, "{", "ä"); + change all by replace (text buffer, start pos, "|", "ö"); + change all by replace (text buffer, start pos, "}", "ü"); + change all by replace (text buffer, start pos, "~", "ß"). + +atari st adaption: + change all by replace (text buffer, start pos, ""142"", "Ä"); + change all by replace (text buffer, start pos, ""153"", "Ö"); + change all by replace (text buffer, start pos, ""154"", "Ü"); + change all by replace (text buffer, start pos, ""132"", "ä"); + change all by replace (text buffer, start pos, ""148"", "ö"); + change all by replace (text buffer, start pos, ""129"", "ü"); + change all by replace (text buffer, start pos, ""158"", "ß"). + +ibm adaption: + change all by replace (text buffer, start pos, ""142"", "Ä"); + change all by replace (text buffer, start pos, ""153"", "Ö"); + change all by replace (text buffer, start pos, ""154"", "Ü"); + change all by replace (text buffer, start pos, ""132"", "ä"); + change all by replace (text buffer, start pos, ""148"", "ö"); + change all by replace (text buffer, start pos, ""129"", "ü"); + change all by replace (text buffer, start pos, ""225"", "ß"). + +END PROC adapt code; + +PROC change all by replace (TEXT VAR string, INT CONST begin pos, + TEXT CONST old, new): + + INT VAR p := pos (string, old, begin pos); + WHILE p > 0 REP + replace (string, p, new); + p := pos (string, old, p + 1) + PER. + +END PROC change all by replace; + +PROC control char conversion (TEXT VAR string, INT CONST code type): + + IF code type <> transparent + THEN code conversion + FI. + +code conversion: + INT VAR p := pos (string, ""0"", ""31"", 1); + WHILE p > 0 REP + convert char; + p := pos (string, ""0"", ""31"", p) + PER. + +convert char: + INT CONST char code := code (string SUB p); + SELECT char code OF + CASE tab code: expand tab + CASE lf code: change (string, p, p, "") + CASE ff code: change (string, p, p, page cmd) + CASE cr code: change (string, p, p, "") + OTHERWISE ersatzdarstellung + END SELECT. + +expand tab: + change (string, p, p, (8 - (p - 1) MOD 8) * " "). + +ersatzdarstellung: + TEXT CONST t := text (char code); + change (string, p, p, "#" + (3 - length (t)) * "0" + t + "#"). + +END PROC control char conversion; + +PROC fetch rowtextmode (DATASPACE VAR file space, + TEXT CONST name): + enable stop; + open fetch dos file (name); + initialize fetch rowtext mode; + WHILE NOT was last fetch cluster REP + cluster struct.size INCR 1; + cluster struct.cluster row [cluster struct.size] := ""; + cat next fetch dos cluster (cluster struct.cluster row [cluster struct.size]) + PER; + close fetch dos file. + +initialize fetch row text mode: + forget (file space); + file space := nilspace; + cluster struct := file space; + type (file space, row text type); + cluster struct.size := 0. + +END PROC fetch rowtext mode; + +PROC fetch ds mode (DATASPACE VAR in ds, TEXT CONST name): + enable stop; + open fetch dos file (name); + init fetch dsmode; + WHILE NOT was last fetch cluster REP + read next fetch dos cluster (in ds, ds block no); + PER; + close fetch dos file. + +init fetch dsmode: + forget (in ds); + in ds := nilspace; + INT VAR ds block no := 2. + +END PROC fetch ds mode; + +PROC fetch dumpmode (DATASPACE VAR file space, TEXT CONST name): + enable stop; + open fetch dos file (name); + initialize fetch dumpmode; + WHILE NOT was last fetch cluster REP + TEXT VAR cluster buffer := ""; + cat next fetch dos cluster (cluster buffer); + dump cluster + UNTIL offset > 50 000.0 + PER; + close fetch dos file. + +initialize fetch dump mode: + BOOL VAR fertig := FALSE; + REAL VAR offset := 0.0; + forget (file space); + file space := nilspace; + file := sequential file (output, file space). + +dump cluster: + TEXT VAR dump line; + INT VAR line, column; + FOR line FROM 0 UPTO (cluster size DIV 16) - 1 REP + build dump line; + putline (file, dump line); + offset INCR 16.0 + UNTIL fertig + PER. + +build dump line: + TEXT VAR char line := ""; + dump line := text (offset, 6, 0); + dump line := subtext (dump line, 1, 5); + dump line CAT " "; + FOR column FROM 0 UPTO 7 REP + convert char; + dump line CAT " " + PER; + dump line CAT " "; + FOR column FROM 8 UPTO 15 REP + convert char; + dump line CAT " " + PER; + dump line CAT " "; + dump line CAT char line. + +convert char: + TEXT CONST char :: cluster buffer SUB (line * 16 + column + 1); + IF char = "" + THEN fertig := TRUE; + dump line CAT " "; + LEAVE convert char + FI; + INT CONST char code := code (char); + LET hex chars = "0123456789ABCDEF"; + dump line CAT (hex chars SUB (char code DIV 16 + 1)); + dump line CAT (hex chars SUB (char code MOD 16 + 1)); + charline CAT show char. + +show char: + IF (char code > 31 AND char code < 127) + THEN char + ELSE "." + FI. + +END PROC fetch dump mode; + +PROC check file (TEXT CONST name): + disable stop; + DATASPACE VAR test ds := nilspace; + enable check file (name, test ds); + forget (test ds); + IF is error + THEN clear error; + error stop ("Fehler beim Prüflesen der Datei """ + name + """") + FI. + +END PROC check file; + +PROC enable check file (TEXT CONST name, DATASPACE VAR test ds): + enable stop; + open fetch dos file (name); + WHILE NOT was last fetch cluster REP + INT VAR dummy := 2; + read next fetch dos cluster (test ds, dummy) + PER; + close fetch dos file. + +END PROC enable check file; + +END PACKET fetch; + diff --git a/system/dos/1.8.7/src/fetch save interface b/system/dos/1.8.7/src/fetch save interface new file mode 100644 index 0000000..27b4925 --- /dev/null +++ b/system/dos/1.8.7/src/fetch save interface @@ -0,0 +1,70 @@ +PACKET fetch save DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + save fetch mode, (* 22.04.87 *) + path: + +LET ascii = 1, + ascii german = 2, + transparent = 3, + row text = 5, + ds = 6, + dump = 7, + atari st = 10, + ibm = 11; + +INT PROC save fetch mode (TEXT CONST reserve string): + TEXT VAR modus; + INT CONST p := pos (reserve string, ":"); + IF p = 0 + THEN modus := reserve string + ELSE modus := subtext (reserve string, 1, p - 1) + FI; + modus normieren; + IF modus = "FILEASCII" + THEN ascii + ELIF modus = "FILEASCIIGERMAN" + THEN asciigerman + ELIF modus = "FILEATARIST" + THEN atari st + ELIF modus = "FILEIBM" + THEN ibm + ELIF modus = "FILETRANSPARENT" + THEN transparent + ELIF modus = "ROWTEXT" + THEN row text + ELIF modus = "DS" + THEN ds + ELIF modus = "DUMP" + THEN dump + ELSE error stop ("Unzulässige Betriebsart"); -1 + FI. + +modus normieren: + change all (modus, " ", ""); + INT VAR i; + FOR i FROM 1 UPTO LENGTH modus REP + INT CONST char code :: code (modus SUB i); + IF is lower case + THEN replace (modus, i, upper case char) + FI + PER. + +is lower case: + char code > 96 AND char code < 123. + +upper case char: + code (char code - 32). + +END PROC save fetch mode; + +TEXT PROC path (TEXT CONST reserve string): + INT CONST p :: pos (reserve string, ":"); + IF p = 0 + THEN "" + ELSE subtext (reserve string, p + 1) + FI. + +END PROC path; + +END PACKET fetch save; + diff --git a/system/dos/1.8.7/src/get put interface.dos b/system/dos/1.8.7/src/get put interface.dos new file mode 100644 index 0000000..1d6de92 --- /dev/null +++ b/system/dos/1.8.7/src/get put interface.dos @@ -0,0 +1,368 @@ +PACKET dos get put DEFINES (* Copyright (C) 1986, 87 *) + (* Frank Klapper *) + (* 11.12.87 *) + log modus, + + open dos disk, + close dos disk, + access dos disk, + + open fetch dos file, + close fetch dos file, + cat next fetch dos cluster, + read next fetch dos cluster, + was last fetch cluster, + + open save dos file, + write next save dos cluster, + close save dos file, + + erase dos file, + + all dosfiles, + all dossubdirs, + dosfile exists, + dos list, + + clear dos disk, + format dos disk: + +BOOL VAR log flag := FALSE; + +PROC log modus (BOOL CONST status): + log flag := status + +END PROC log modus; + +(*-------------------------------------------------------------------------*) + +LET max cluster size = 8192, (* 8192 * 8 = 64 KB *) + reals per sector = 64; + +LET CLUSTER = BOUND STRUCT (ALIGN dummy, + ROW max cluster size REAL cluster row); + +CLUSTER VAR cluster; +DATASPACE VAR cluster ds; +INITFLAG VAR cluster ds used := FALSE; + +TEXT VAR convert buffer; +INT VAR convert buffer length; + +PROC init cluster handle: + IF initialized (cluster ds used) + THEN forget (cluster ds) + FI; + cluster ds := nilspace; + cluster := cluster ds; + convert buffer := ""; + convert buffer length := 0. + +END PROC init cluster handle; + +PROC cat cluster text (REAL CONST cluster no, TEXT VAR destination, INT CONST to): + read disk cluster (cluster ds, 2, cluster no); + init convert buffer; + INT VAR i; + FOR i FROM 1 UPTO sectors per cluster * reals per sector REP + replace (convert buffer, i, cluster.cluster row [i]) + PER; + destination CAT subtext (convert buffer, 1, to). + +init convert buffer: + IF convert buffer length < cluster size + THEN convert buffer CAT (cluster size - convert buffer length) * "*"; + convert buffer length := cluster size + FI. + +END PROC cat cluster text; + +PROC write text to cluster (REAL CONST cluster no, TEXT CONST string): + IF LENGTH string < cluster size + THEN execute write text (text (string, cluster size)) + ELSE execute write text (string) + FI; + write disk cluster (cluster ds, 2, cluster no). + +END PROC write text to cluster; + +PROC execute write text (TEXT CONST string): + INT VAR i; + FOR i FROM 1 UPTO sectors per cluster * reals per sector REP + cluster.cluster row [i] := string RSUB i + PER. + +END PROC execute write text; + +(*-------------------------------------------------------------------------*) + +BOOL VAR disk open := FALSE; +TEXT VAR act path; + +REAL VAR last access time; + +PROC open dos disk (TEXT CONST path): + IF log flag THEN dump ("open dos disk", path) FI; + enable stop; + close work; + init cluster handle; + act path := path; + disk open := TRUE + +END PROC open dos disk; + +PROC close dos disk: + IF log flag THEN dump ("close dos disk", "") FI; + enable stop; + disk open := FALSE; + close work; + init cluster handle; (* Datenraumespeicher freigeben *) + clear fat ds; + init dir ds. + +END PROC close dos disk; + +PROC access dos disk: + enable stop; + IF NOT disk open + THEN error stop ("DOS-Arbeit nicht eröffnet") + FI; + IF work closed COR (last access more than 5 seconds ago CAND disk changed) + THEN open eu disk; (* hier wird der RERUN Check initialisiert *) + open dos disk; + read fat; + open dir (act path); + last access time := clock (1); + open work + FI. + +last access more than 5 seconds ago: + abs (clock (1) - last access time) > 5.0. + +disk changed: + IF hd version + THEN FALSE + ELSE last access time := clock (1); + NOT first fat block ok + FI. + +END PROC access dos disk; + +(*-------------------------------------------------------------------------*) + +REAL VAR next fetch cluster, + fetch rest; (* in Bytes *) + +PROC open fetch dos file (TEXT CONST file name): + IF log flag THEN dump ("open fetch dos file", file name) FI; + enable stop; + access dos disk; + file info (file name, next fetch cluster, fetch rest). + +END PROC open fetch dos file; + +BOOL PROC was last fetch cluster: + IF log flag THEN dump ("was last fetch cluster", "") FI; + is last fat chain entry (next fetch cluster) OR fetch rest <= 0.0. + +END PROC was last fetch cluster; + +PROC cat next fetch dos cluster (TEXT VAR buffer): + IF log flag THEN dump ("cat next fetch dos cluster", "") FI; + enable stop; + IF was last fetch cluster + THEN error stop ("fetch nach Dateiende") + FI; + IF fetch rest < real (cluster size) + THEN cat cluster text (next fetch cluster, buffer, int (fetch rest)); + fetch rest := 0.0 + ELSE cat cluster text (next fetch cluster, buffer, cluster size); + fetch rest DECR real (cluster size) + FI; + last access time := clock (1); + next fetch cluster := fat entry (next fetch cluster). + +END PROC cat next fetch dos cluster; + +PROC read next fetch dos cluster (DATASPACE VAR read ds, INT VAR start page): + IF log flag THEN dump ("read next fetch dos cluster", start page) FI; + enable stop; + IF was last fetch cluster + THEN error stop ("fetch nach Dateiende") + FI; + read disk cluster (read ds, start page, next fetch cluster); + last access time := clock (1); + start page INCR sectors per cluster; + next fetch cluster := fat entry (next fetch cluster); + IF fetch rest < real (cluster size) + THEN fetch rest := 0.0 + ELSE fetch rest DECR real (cluster size) + FI. + +END PROC read next fetch dos cluster; + +PROC close fetch dos file: + IF log flag THEN dump ("close fetch dos file", "") FI; + +END PROC close fetch dos file; + +(*-------------------------------------------------------------------------*) + +TEXT VAR save name; +REAL VAR first save cluster, + last save cluster, + save size; + +PROC open save dos file (TEXT CONST file name): + IF log flag THEN dump ("open save dos file", file name) FI; + enable stop; + access dos disk; + IF file exists (file name) OR subdir exists (file name) + THEN error stop ("die Datei """ + file name + """ gibt es schon") + FI; + save name := file name; + first save cluster := -1.0; + save size := 0.0. + +END PROC open save dos file; + +PROC write next save dos cluster (TEXT CONST buffer): + IF log flag THEN dump ("write next save dos cluster", "") FI; + enable stop; + REAL CONST save cluster := available fat entry; + write text to cluster (save cluster, buffer); + last access time := clock (1); + save size INCR real (LENGTH buffer); + IF first save cluster < 2.0 + THEN first save cluster := save cluster + ELSE fat entry (last save cluster, save cluster) + FI; + fat entry (save cluster, last fat chain entry); + last save cluster := save cluster. + +END PROC write next save dos cluster; + +PROC write next save dos cluster (DATASPACE CONST save ds, INT VAR start page): + IF log flag THEN dump ("write next save dos cluster", start page) FI; + enable stop; + REAL CONST save cluster := available fat entry; + write disk cluster (save ds, start page, save cluster); + last access time := clock (1); + start page INCR sectors per cluster; + save size INCR real (cluster size); + IF first save cluster < 2.0 + THEN first save cluster := save cluster + ELSE fat entry (last save cluster, save cluster) + FI; + fat entry (save cluster, last fat chain entry); + last save cluster := save cluster. + +END PROC write next save dos cluster; + +PROC close save dos file: + IF log flag THEN dump ("close save dos file", "") FI; + enable stop; + IF first save cluster < 2.0 + THEN LEAVE close save dos file + FI; + fat entry (last save cluster, last fat chain entry); + write fat; + insert dir entry (save name, first save cluster, save size); + last access time := clock (1). + +END PROC close save dos file; + +(*-------------------------------------------------------------------------*) + +PROC erase dos file (TEXT CONST file name): + IF log flag THEN dump ("erase dos file", file name) FI; + enable stop; + access dos disk; + REAL VAR first cluster, size; + file info (file name, first cluster, size); + delete dir entry (file name); + erase fat chain (first cluster); + write fat; + last access time := clock (1). + +END PROC erase dos file; + +(*-------------------------------------------------------------------------*) + +THESAURUS PROC all dosfiles: + IF log flag THEN dump ("all dosfile", "") FI; + enable stop; + access dos disk; + all files. + +END PROC all dosfiles; + +THESAURUS PROC all dossubdirs: + IF log flag THEN dump ("all subdirs", "") FI; + enable stop; + access dos disk; + all subdirs. + +END PROC all dossubdirs; + +BOOL PROC dos file exists (TEXT CONST file name): + IF log flag THEN dump ("dos file exists", file name) FI; + enable stop; + access dos disk; + file exists (file name). + +END PROC dos file exists; + +PROC dos list (DATASPACE VAR list ds): + IF log flag THEN dump ("dos list", "") FI; + enable stop; + access dos disk; + dir list (list ds). + +END PROC dos list; + +(*-------------------------------------------------------------------------*) + +PROC clear dos disk: + IF log flag THEN dump ("clear dos disk", "") FI; + enable stop; + IF hd version + THEN error stop ("nicht implementiert") + ELSE access dos disk; + format dir; + format fat; + last access time := clock (1) + FI. + +END PROC clear dos disk; + +PROC format dos disk (INT CONST format code): + + IF log flag THEN dump ("format dos disk (" + text (format code) + ")", "") FI; + enable stop; + IF NOT disk open + THEN error stop ("DOS-Arbeit nicht eröffnet") + FI; + IF hd version + THEN error stop ("nicht implementiert") + ELSE do format + FI. + +do format: + IF bpb exists (format code) + THEN close work; + format archive (format code); + open eu disk; + write bpb (format code); + open dos disk; + format dir; (* enthält 'open dir' *) + format fat; (* enthält 'read fat' *) + open work + ELSE error stop ("Format unzulässig") + FI; + last access time := clock (1). + +END PROC format dos disk; + +END PACKET dos get put; + diff --git a/system/dos/1.8.7/src/insert.dos b/system/dos/1.8.7/src/insert.dos new file mode 100644 index 0000000..14f98cd --- /dev/null +++ b/system/dos/1.8.7/src/insert.dos @@ -0,0 +1,14 @@ +dump +konvert +open +eu disk descriptor +disk descriptor.dos +block i/o +name conversion.dos +fat.dos +dir.dos +get put interface.dos +fetch save interface +fetch +save + diff --git a/system/dos/1.8.7/src/konvert b/system/dos/1.8.7/src/konvert new file mode 100644 index 0000000..c5c4c43 --- /dev/null +++ b/system/dos/1.8.7/src/konvert @@ -0,0 +1,75 @@ +PACKET konvert DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 28.10.86 *) + high byte, + low byte, + word, + change low byte, + change high byte, + dint, + high word, + low word: + +INT PROC high byte (INT CONST value): + TEXT VAR x := " "; + replace (x, 1, value); + code (x SUB 2) + +END PROC high byte; + +INT PROC low byte (INT CONST value): + TEXT VAR x := " "; + replace (x, 1, value); + code (x SUB 1) + +END PROC low byte; + +INT PROC word (INT CONST low byte, high byte): + TEXT CONST x :: code (low byte) + code (high byte); + x ISUB 1 + +END PROC word; + +PROC change low byte (INT VAR word, INT CONST low byte): + TEXT VAR x := " "; + replace (x, 1, word); + replace (x, 1, code (low byte)); + word := x ISUB 1 + +END PROC change low byte; + +PROC change high byte (INT VAR word, INT CONST high byte): + TEXT VAR x := " "; + replace (x, 1, word); + replace (x, 2, code (high byte)); + word := x ISUB 1 + +END PROC change high byte; + +REAL PROC dint (INT CONST low word, high word): + real low word + 65536.0 * real high word. + +real low word: + real (low byte (low word)) + 256.0 * real (high byte (low word)). + +real high word: + real (low byte (high word)) + 256.0 * real (high byte (high word)). + +END PROC dint; + +INT PROC high word (REAL CONST double precission int): + int (double precission int / 65536.0) + +END PROC high word; + +INT PROC low word (REAL CONST double precission int): + string of low bytes ISUB 1. + +string of low bytes: + code (int (double precission int MOD 256.0)) + + code (int ((double precission int MOD 65536.0) / 256.0)). + +END PROC low word; + +END PACKET konvert; + diff --git a/system/dos/1.8.7/src/manager-M.dos b/system/dos/1.8.7/src/manager-M.dos new file mode 100644 index 0000000..e27c513 --- /dev/null +++ b/system/dos/1.8.7/src/manager-M.dos @@ -0,0 +1,211 @@ +PACKET dos manager multi DEFINES (* Copyright (C) 1985, 86, 87 *) + (* Frank Klapper *) + provide channel, (* 16.10.87 *) + dos manager: + +LET std archive channel = 31, + + ack = 0, + 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, + + log code = 78, + + quote = """"; + +BOUND STRUCT (TEXT name, pass) VAR msg; + +TASK VAR order task; + +INT VAR dos channel; + +INT VAR fetch save modus; + +REAL VAR last access time := 0.0; + +TASK VAR disk owner := niltask; + +TEXT VAR save file name; + +PROC provide channel (INT CONST channel): + dos channel := channel + +END PROC provide channel; + +IF hd version + THEN provide channel (29) + ELSE provide channel (std archive channel) +FI; + +PROC dos manager: + dos manager (dos channel) + +END PROC dos manager; + +PROC dos manager (INT CONST channel): + dos channel := channel; + task password ("-"); + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) dos manager) + +END PROC dos manager; + +PROC dos manager (DATASPACE VAR ds, INT CONST order code, phase, + TASK CONST from task): + enable stop; + order task := from task; + msg := ds; + IF NOT (order task = disk owner) AND + order code <> free code AND order code <> reserve code + THEN errorstop ("DOS nicht angemeldet") + FI; + IF order task = disk owner + THEN last access time := clock (1) + FI; + SELECT order code OF + CASE fetch code : fetch file + CASE save code : save file + CASE erase code : erase file + CASE clear code : clear disk + CASE exists code : exists file + CASE list code : list disk + CASE all code : deliver directory + CASE reserve code : reserve + CASE free code : free + CASE check read code: check + CASE format code : format + CASE log code : send log + OTHERWISE errorstop ("unbekannter Auftrag für Task: " + name (myself)) + END SELECT. + +fetch file: + fetch (dos name (msg.name, read modus), ds, fetch save modus); + manager ok (ds). + +check: + check file (dos name (msg.name, read modus)); + manager message (expanded name (msg.name, read modus) + " ohne Fehler gelesen"). + +format: + IF phase = 1 + THEN manager question ("Diskette formatieren") + ELSE format dos disk (int (msg.name)); + manager ok (ds) + FI. + +save file: + IF phase = 1 + THEN save first phase + ELSE save second phase + FI. + +save first phase: + save file name := dos name (msg.name, write modus); + IF dos file exists (save file name) + THEN manager question (expanded name (msg.name, write modus) + " auf der MS-DOS Disk ueberschreiben") + ELSE send (order task, second phase ack, ds) + FI. + +save second phase: + IF dos file exists (save file name) + THEN erase dos file (save file name) + FI; + save (save file name, ds, fetch save modus); + forget (ds) ; + ds := nilspace ; + manager ok (ds). + +clear disk: + IF phase = 1 + THEN manager question ("Diskette loeschen") + ELSE clear dos disk; + manager ok (ds) + FI. + +erase file: + IF dos file exists (dos name (msg.name, read modus)) + THEN IF phase = 1 + THEN manager question (expanded name (msg.name, TRUE) + " auf der MS-DOS Disk loeschen") + ELSE erase dos file (dos name (msg.name, read modus)); + manager ok (ds) + FI + ELSE manager message ("die Datei " + expanded name (msg.name, TRUE) + " gibt es nicht auf der MS-DOS Disk") + FI. + +exists file: + IF dos file exists (dos name (msg.name, read modus)) + THEN manager ok (ds) + ELSE send (order task, false code, ds) + FI. + +list disk: + dos list (ds); + manager ok (ds). + +send log: + forget (ds); + ds := old ("logbuch"); + manager ok (ds). + +deliver directory: + forget (ds); + ds := nilspace; + BOUND THESAURUS VAR all names := ds; + all names := all dos files; + manager ok (ds). + +reserve: + IF reserve or free permitted + THEN continue channel (dos channel); + disk owner := from task; + fetch save modus := save fetch mode (msg.name); + open dos disk (path (msg.name)); + forget ("logbuch", quiet); + manager ok (ds) + ELSE errorstop ("Archivlaufwerk wird von Task """+ name (disk owner) + """ benutzt") + FI. + +reserve or free permitted : + from task = disk owner OR last access more than five minutes ago + OR disk owner = niltask OR NOT + (exists (disk owner) OR station(disk owner) <> station (myself)). + +last access more than five minutes ago : + abs (last access time - clock (1)) > 300.0. + +free: + IF reserve or free permitted + THEN close dos disk; + disk owner := niltask; + break (quiet); + manager ok (ds) + ELSE manager message ("DOS nicht angemeldet") + FI. + +END PROC dos manager; + +PROC manager ok (DATASPACE VAR ds): + send (order task, ack, ds); + last access time := clock (1). + +END PROC manager ok; + +TEXT PROC expanded name (TEXT CONST name, BOOL CONST status): + text (quote + dos name (name, status) + quote, 14) + +END PROC expanded name; + +END PACKET dos manager multi; + diff --git a/system/dos/1.8.7/src/manager-S.dos b/system/dos/1.8.7/src/manager-S.dos new file mode 100644 index 0000000..23885e6 --- /dev/null +++ b/system/dos/1.8.7/src/manager-S.dos @@ -0,0 +1,268 @@ +PACKET dos single DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + (* 11.09.87 *) + /, + dos, + provide dos channel, + archive, + reserve, + release, + save, + fetch, + erase, + check, + exists, + ALL, + SOME, + clear, + list, + format: + +LET std archive channel = 31, + main channel = 1; + +INT VAR dos channel := std archive channel; +INT VAR fetch save modus; + +TYPE DOSTASK = TEXT; + +DOSTASK CONST dos := "DOS"; + +OP := (DOSTASK VAR d, TEXT CONST t): + CONCR (d) := t + +END OP :=; + +DOSTASK OP / (TEXT CONST text): + DOSTASK VAR d; + CONCR (d) := text; + d + +END OP /; + +BOOL PROC is dostask (DOSTASK CONST d): + CONCR (d) = "DOS" + +END PROC is dos task; + +PROC provide dos channel (INT CONST channel no): + dos channel := channel no + +END PROC provide dos channel; + +DATASPACE VAR space := nilspace; +forget (space); + +PROC reserve (TEXT CONST string, DOSTASK CONST task): + IF is dostask (task) + THEN fetch save modus := save fetch mode (string); + open dos disk (path (string)) + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +END PROC reserve; + +PROC archive (TEXT CONST string, DOSTASK CONST task): + reserve (string, task) + +END PROC archive; + +PROC release (DOSTASK CONST task): + IF is dos task (task) + THEN close dos disk + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +END PROC release; + +PROC fetch (TEXT CONST name, DOSTASK CONST from): + IF is dostask (from) + THEN fetch from dos disk + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +fetch from dos disk: + IF NOT exists (name) COR overwrite permitted + THEN do fetch + FI. + +overwrite permitted: + say ("eigene Datei """) ; + say (name) ; + yes (""" auf der Diskette ueberschreiben"). + +do fetch: + last param (name); + disable stop; + continue (dos channel); + fetch (dos name (name, read modus), space, fetch save modus); + continue (main channel); + IF NOT is error + THEN forget (name, quiet); + copy (space, name) + FI; + forget (space). + +END PROC fetch; + +PROC erase (TEXT CONST name, DOSTASK CONST task): + IF is dos task (task) + THEN do erase dos file + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +do erase dos file: + IF NOT exists (name, /"DOS") + THEN error stop ("die Datei """ + name + """ gibt es nicht") + ELIF yes ("""" + dos name (name, read modus)+ """ auf Der Diskette loeschen") + THEN disable stop; + continue (dos channel); + erase dos file (dos name (name, read modus)); + continue (main channel) + FI. + +END PROC erase; + +PROC save (TEXT CONST name, DOSTASK CONST task): + IF is dos task (task) + THEN save to dos disk + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +save to dos disk: + TEXT CONST save file name :: dos name (name, write modus); + disable stop; + continue (dos channel); + IF NOT dos file exists (save file name) COR overwrite permitted + THEN IF dos file exists (save file name) + THEN erase dos file (save file name) + FI; + save (save file name, old (name), fetch save modus); + FI; + continue (main channel). + +overwrite permitted: + continue (main channel); + BOOL CONST result :: yes ("""" + save file name + """ auf der Diskette ueberschreiben"); + continue (dos channel); + result. + +END PROC save; + +PROC check (TEXT CONST name, DOSTASK CONST from): + IF is dostask (from) + THEN disable stop; + continue (dos channel); + check file (dos name (name, read modus)); + continue (main channel) + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +END PROC check; + +BOOL PROC exists (TEXT CONST name, DOSTASK CONST task): + IF is dos task (task) + THEN disable stop; + continue (dos channel); + BOOL VAR dummy := dos file exists (dos name (name, read modus)); + continue (main channel); + enable stop; + dummy + ELSE error stop ("die angesprochene Task existiert nicht"); FALSE + FI. + +END PROC exists; + +PROC list (DOSTASK CONST from): + forget (space); + space := nilspace; + FILE VAR list file := sequential file (output, space); + list (list file, from); + modify (list file); + show (list file); + forget (space). + +ENDPROC list; + +PROC list (FILE VAR list file, DOSTASK CONST from): + IF is dos task (from) + THEN list dos disk + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +list dos disk: + disable stop; + continue (dos channel); + dos list (space); + continue (main channel); + enable stop; + output (list file); + FILE VAR list source := sequential file (output, space); + TEXT VAR line; + WHILE NOT eof (list source) REP + getline (list source, line); + putline (list file, line) + PER. + +END PROC list; + +THESAURUS OP ALL (DOSTASK CONST task): + IF is dos task (task) + THEN disable stop; + continue (dos channel); + THESAURUS VAR dummy := all dos files; + continue (main channel); + enable stop; + dummy + ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus + FI. + +END OP ALL; + +THESAURUS OP SOME (DOSTASK CONST task): + IF is dos task (task) + THEN disable stop; + continue (dos channel); + THESAURUS VAR dummy := all dos files; + continue (main channel); + enable stop; + SOME dummy + ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus + FI. + +END OP SOME; + +PROC clear (DOSTASK CONST task): + IF is dos task (task) + THEN clear disk + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +clear disk: + disable stop; + IF yes ("Diskette loeschen") + THEN continue (dos channel); + clear dos disk; + continue (main channel) + FI. + +END PROC clear; + +PROC format (INT CONST format code, DOSTASK CONST task): + IF is dos task (task) + THEN format disk + ELSE error stop ("die angesprochene Task existiert nicht") + FI. + +format disk: + disable stop; + IF yes ("Diskette formatieren") + THEN continue (dos channel); + format dos disk (format code); + continue (main channel) + FI. + +END PROC format; + +END PACKET dos single; + diff --git a/system/dos/1.8.7/src/name conversion.dos b/system/dos/1.8.7/src/name conversion.dos new file mode 100644 index 0000000..e72d838 --- /dev/null +++ b/system/dos/1.8.7/src/name conversion.dos @@ -0,0 +1,77 @@ +PACKET name conversion DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + dos name, (* 31.12.86 *) + + read modus, + write modus: + +BOOL CONST read modus :: TRUE, + write modus :: NOT read modus; + +LET upper case chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$#&§!()-{}`_", + lower case chars = "abcdefghijklmnopqrstuvwxyz"; + +TEXT PROC dos name (TEXT CONST eu name, BOOL CONST read write modus): + enable stop; + INT CONST point pos :: pos (eu name, "."); + IF name extension exists + THEN changed name with extension + ELSE changed name without extension + FI. + +name extension exists: + point pos > 0. + +changed name with extension: + TEXT CONST name pre :: compress (subtext (eu name, 1, point pos - 1)), + name post :: compress (subtext (eu name, point pos + 1)); + IF LENGTH name pre = 0 OR LENGTH name pre > 8 OR LENGTH name post > 3 + THEN error + FI; + IF LENGTH name post = 0 + THEN new name (name pre, read write modus) + ELSE new name (name pre, read write modus) + "." + + new name (name post, read write modus) + FI. + +changed name without extension: + IF LENGTH eu name > 8 OR LENGTH euname < 1 + THEN error + FI; + new name (eu name, read write modus). + +error: + error stop ("Unzulässiger Name"). + +END PROC dos name; + +TEXT PROC new name (TEXT CONST old name, BOOL CONST read write modus): + TEXT VAR new := ""; + INT VAR count; + FOR count FROM 1 UPTO LENGTH old name REP + convert char + PER; + new. + +convert char: + TEXT CONST char :: old name SUB count; + IF is lower case char + THEN new CAT (upper case chars SUB string pos) + ELIF is upper case char OR read write modus + THEN new CAT char + ELSE error stop ("Unzulässiger Name") + FI. + +is lower case char: + pos (lower case chars, char) > 0. + +is upper case char: + pos (upper case chars, char) > 0. + +string pos: + pos (lower case chars, char). + +END PROC new name; + +END PACKET name conversion; + diff --git a/system/dos/1.8.7/src/open b/system/dos/1.8.7/src/open new file mode 100644 index 0000000..518c4b8 --- /dev/null +++ b/system/dos/1.8.7/src/open @@ -0,0 +1,66 @@ +PACKET open DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + open work, (* 05.01.87 *) + close work, + work opened, + work closed, + init check rerun, + check rerun, + + hd version: + +BOOL VAR open; +INT VAR old session; + +BOOL VAR hd flag := FALSE; + +INITFLAG VAR packet := FALSE; + +PROC open work: + open := TRUE + +END PROC open work; + +PROC close work: + open := FALSE + +END PROC close work; + +BOOL PROC work opened: + IF NOT initialized (packet) + THEN close work + FI; + open + +END PROC work opened; + +BOOL PROC work closed: + NOT work opened + +END PROC work closed; + +PROC init check rerun: + old session := session + +END PROC init check rerun; + +PROC check rerun: + IF session <> old session + THEN close work; + error stop ("Diskettenzugriff im RERUN") + FI. + +END PROC check rerun; + +PROC hd version (BOOL CONST status): + hd flag := status + +END PROC hd version; + +BOOL PROC hd version: + hd flag + +END PROC hd version; + +END PACKET open; + diff --git a/system/dos/1.8.7/src/save b/system/dos/1.8.7/src/save new file mode 100644 index 0000000..7e67e91 --- /dev/null +++ b/system/dos/1.8.7/src/save @@ -0,0 +1,233 @@ +PACKET save DEFINES (* Copyright (C) 1985, 86, 87 *) + (* Frank Klapper *) + (* 27.04.87 *) + save: + +LET ascii = 1, + ascii german = 2, + transparent = 3, + row text = 5, + ds = 6, + atari st = 10, + ibm = 11, + + ff = ""12"", + ctrl z = ""26"", + cr lf = ""13""10"", + + row text mode length = 4000; + +TEXT VAR buffer; + +BOUND STRUCT (INT size, + ROW row text mode length TEXT cluster row) VAR cluster struct; + +PROC save (TEXT CONST file name, DATASPACE CONST file ds, INT CONST mode): + + SELECT mode OF + CASE ascii, ascii german, atari st, ibm, transparent: + save filemode (file ds, filename, mode) + CASE row text : save row textmode (file ds, filename) + CASE ds : save dsmode (file ds, filename) + OTHERWISE error stop ("Unzulässige Betriebsart") + END SELECT. + +END PROC save; + +PROC save filemode (DATASPACE CONST file space, TEXT CONST name, INT CONST code type): + + enable stop; + open save dos file (name); + FILE VAR file := sequential file (modify, file space); + buffer := ""; + INT VAR line no; + FOR line no FROM 1 UPTO lines (file) REP + to line (file, line no); + buffer cat file line; + WHILE length (buffer) >= cluster size REP + write next save dos cluster (subtext (buffer, 1, cluster size)); + buffer := subtext (buffer, cluster size + 1) + PER + PER; + IF ascii code + THEN buffer CAT ctrl z + FI; + write rest; + close save dos file; + buffer := "". + +buffer cat file line: + exec (PROC (TEXT CONST, INT CONST) cat adapted line, file, code type). + +ascii code: + (code type = ascii) OR (code type = ascii german). + +write rest: + WHILE buffer <> "" + REP write next save dos cluster (subtext (buffer, 1, cluster size)); + buffer := subtext (buffer, cluster size + 1) + PER. + +END PROC save filemode; + +PROC cat adapted line (TEXT VAR line, INT CONST code type): + + IF code type = transparent + THEN buffer CAT line + ELSE change esc sequences; + change eumel print chars; + SELECT code type OF + CASE ascii : ascii change + CASE ascii german: ascii german change + CASE atari st : atari st change + CASE ibm : ibm change + END SELECT; + buffer CAT line; + IF (line SUB length (line)) <> ff + THEN buffer CAT cr lf + FI + FI. + +change esc sequences: + change all (line, "#page#", ff); + INT VAR p := pos (line, "#"); + WHILE p > 0 REP + IF is esc sequence + THEN change (line, p, p+4, coded char) + FI; + p := pos (line, "#", p+1) + PER. + +is esc sequence: + LET digits = "0123456789"; + (line SUB (p+4)) = "#" CAND pos (digits, line SUB p+1) > 0 CAND + pos (digits, line SUB p+2) > 0 CAND pos (digits, line SUB p+3) > 0. + +coded char: + code (int (subtext (line, p+1, p+3))). + +change eumel print chars: + p := pos (line, ""220"", ""223"", 1); + WHILE p > 0 REP + replace (line, p, std char); + p := pos (line, ""220"", ""223"", p + 1) + PER. + +std char: + "k-# " SUB (code (line SUB p) - 219). + +ascii change: + change all (line, "ß", "#251#"); + p := pos (line, "Ä", "ü", 1); + WHILE p > 0 REP + change (line, p, p, ersatzdarstellung (line SUB p)); + p := pos (line, "Ä", "ü", p + 1) + PER. + +ascii german change: + change all (line, "[", "#091#"); + change all (line, "\", "#092#"); + change all (line, "]", "#093#"); + change all (line, "{", "#123#"); + change all (line, "|", "#124#"); + change all (line, "}", "#125#"); + change all (line, "~", "#126#"); + change all (line, "ß", ""126""); + p := pos (line, "Ä", "ü", 1); + WHILE p > 0 REP + replace (line, p, umlaut in ascii german); + p := pos (line, "Ä", "ü", p + 1) + PER. + +umlaut in ascii german: + "[\]{|}" SUB (code (line SUB p) - 213). + +ibm change: + change all (line, "ß", ""225""); + p := pos (line, "Ä", "ü", 1); + WHILE p > 0 REP + replace (line, p, umlaut in ibm); + p := pos (line, "Ä", "ü", p + 1) + PER. + +atari st change: + change all (line, "ß", ""158""); + p := pos (line, "Ä", "ü", 1); + WHILE p > 0 REP + replace (line, p, umlaut in ibm); + p := pos (line, "Ä", "ü", p + 1) + PER. + +umlaut in ibm: + ""142""153""154""132""148""129"" SUB (code (line SUB p) - 213). + +END PROC cat adapted line; + +TEXT PROC ersatzdarstellung (TEXT CONST char): + + TEXT CONST t :: text (code (char SUB 1)); + "#" + (3 - length (t)) * "0" + t + "#" + +END PROC ersatzdarstellung; + +PROC save rowtextmode (DATASPACE CONST space, TEXT CONST name): + + enable stop; + open save dos file (name); + init save row textmode; + WHILE line no < cluster struct.size REP + fill buffer; + write next save dos cluster (subtext (buffer, 1, cluster size)); + remember rest + PER; + write rest; + close save dos file; + buffer := "". + +init save rowtextmode: + cluster struct := space; + buffer := ""; + INT VAR line no := 0. + +fill buffer: + WHILE line no < cluster struct.size AND NOT buffer full REP + line no INCR 1; + buffer CAT cluster struct.cluster row [line no] + PER. + +buffer full: + LENGTH buffer >= cluster size. + +remember rest: + buffer := subtext (buffer, cluster size + 1). + +write rest: + WHILE buffer <> "" + REP write next save dos cluster (subtext (buffer, 1, cluster size)); + remember rest + PER. + +END PROC save rowtextmode; + +PROC save ds mode (DATASPACE CONST out ds, TEXT CONST name): + + enable stop; + open save dos file (name); + INT VAR page no := first non dummy ds page; + get last allocated ds page; + WHILE page no <= last allocated ds page REP + write next save dos cluster (out ds, page no); + PER; + close save dos file. + +get last allocated ds page: + INT VAR last allocated ds page := -1, + i; + FOR i FROM 1 UPTO ds pages (out ds) REP + last allocated ds page := next ds page (out ds, last allocated ds page) + PER. + +END PROC save ds mode; + +END PACKET save; + diff --git a/system/dos/1.8.7/src/shard interface b/system/dos/1.8.7/src/shard interface new file mode 100644 index 0000000..20d9b76 --- /dev/null +++ b/system/dos/1.8.7/src/shard interface @@ -0,0 +1,20 @@ +; ';' in Spalte 1 kennzeichnet eine Kommentarzeile +; alle Werte müssen durch Blanks getrennt werden +; +;heads: Anzahl der Köpfe, positiv für cylinderorientiertes Lesen +; negativ für seitenorientiertes Lesen +; +;size heads tracks first sectors last sector +;===================================================== +320 1 40 1 8 +360 1 40 1 9 +640 -2 40 1 8 +720 -2 40 1 9 +800 2 40 1 10 +1440 -2 80 1 9 +1600 2 80 1 10 +2400 -2 80 1 15 +1232 1 77 0 15 +2464 -2 77 0 15 +; END OF FILE + diff --git a/system/eumel-coder/1.8.0/src/eumel coder 1.8.0 b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0 new file mode 100644 index 0000000..d9f489f --- /dev/null +++ b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0 @@ -0,0 +1,2594 @@ +PACKET eumel coder (* Autor: U. Bartling *)
+ DEFINES coder on, coder off,
+ declare, define, apply, identify,
+ :=, =,
+ dump,
+
+ LABEL,
+ gosub, goret,
+ complement condition code,
+
+ ADDRESS ,
+ GLOB, LOC, REF, DEREF,
+ ref length,
+ +,
+ adjust,
+ is global, is local, is ref,
+
+ DTYPE,
+ type class, type name,
+ void type, int type, real type, text type, bool type,
+ dataspace type, undefined type,
+ row type, struct type, proc type, end type,
+
+ OPN,
+ set length of local storage,
+ begin module, end module,
+ is proc, is eumel 0 instruction,
+ address, operation,
+ nop,
+ init op codes,
+ mnemonic,
+
+ parameter,
+ next param,
+ NEXTPARAM,
+ access ,
+ dtype ,
+ param address,
+ same type ,
+
+ reserve storage,
+ allocate denoter ,
+ allocate variable,
+ data allocation by coder ,
+ data allocation by user,
+
+ run, run again,
+ insert,
+ prot, prot off,
+ check, check on, check off,
+
+ help, bulletin, packets :
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 13.02.1986 *)
+(* Stand der Implementation : 21.03.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR memory management mode, global address offset, hash table pointer,
+ nt link, permanent pointer, param link, index, mode, field pointer,
+ word, number of errors := 0 ;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 12.03.1986 *)
+(* 1.7.5.4 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+ four word length = 4 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+ offset to row size = 12785 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ undefined = 9 ,
+ row = 10 ,
+ struct = 11 ,
+ end = 0 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+ bold = 2 ,
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ prep coder mode = 5 ,
+
+ warning message = 2 ,
+ error message = 4 ,
+
+ point line = "..............." ;
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+BOOL VAR coder active := FALSE ;
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+LET invalid coder off = "CODER not active" ;
+
+PROC coder on (INT CONST data allocation mode) :
+ mark coder on ;
+ init memory management ;
+ init opn section ;
+ init compiler .
+
+mark coder on :
+ coder active := TRUE .
+
+init memory management :
+ memory management mode := data allocation mode ;
+ prep pbase (global address offset) .
+
+init compiler :
+ no do again ;
+ elan (prep coder mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+
+ENDPROC coder on;
+
+PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) :
+ IF coder active
+ THEN mark coder off ;
+ end coder (insert, sermon, start mod nr if no insert)
+ ELSE errorstop (invalid coder off)
+ FI .
+
+start mod nr if no insert :
+ IF insert THEN run again mod nr := 0
+ ELSE run again mod nr := start proc.mod nr
+ FI ;
+ run again mod nr .
+
+mark coder off :
+ reset memory management mode ;
+ init opn section ;
+ coder active := FALSE
+ENDPROC coder off ;
+
+PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) :
+ EXTERNAL 10021
+ENDPROC end coder ;
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 2. Spruenge und Marken 07.03.1986 *)
+(* *)
+(* Definition des Datentyps LABEL *)
+(* *)
+(* Deklaration, Definition und Applikation von Marken *)
+(* *)
+(**************************************************************************)
+
+
+TYPE LABEL = INT ;
+
+BOOL VAR invers :: FALSE ;
+
+PROC declare (LABEL VAR label) :
+ CONCR (label) := 0
+ENDPROC declare ;
+
+PROC define (LABEL VAR label) :
+ EXTERNAL 10084
+ENDPROC define ;
+
+PROC complement condition code :
+ invers := TRUE
+ENDPROC complement condition code ;
+
+PROC apply (LABEL VAR label) :
+ EXTERNAL 10149
+ENDPROC apply ;
+
+PROC apply (LABEL VAR label, BOOL CONST condition) :
+ IF condition xor invers THEN branch true (label)
+ ELSE branch false (label)
+ FI ;
+ invers := FALSE .
+
+condition xor invers :
+ IF condition THEN NOT invers
+ ELSE invers
+ FI
+ENDPROC apply ;
+
+OP := (LABEL VAR global label, local label) : (* EQUATE ! *)
+ EXTERNAL 10014
+ENDOP := ;
+
+TEXT PROC dump (LABEL CONST label) :
+ "LAB " + text (CONCR (label))
+ENDPROC dump ;
+
+PROC gosub (LABEL VAR label) :
+ EXTERNAL 10015
+ENDPROC gosub ;
+
+PROC goret :
+ s0 (q goret code)
+ENDPROC goret ;
+
+PROC branch true (LABEL VAR label) :
+ EXTERNAL 10028
+ENDPROC branch true ;
+
+PROC branch false (LABEL VAR label) :
+ EXTERNAL 10029
+ENDPROC branch false ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 3. Datenaddressen 21.03.1986 *)
+(* *)
+(* Definition des Datentyps ADDRESS *)
+(* *)
+(* Aufbau von Datenaddressen (Vercodung) *)
+(* Fortschalten und Ausrichten von Adressen *)
+(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE ADDRESS = STRUCT (INT kind, value) ;
+
+LET global = 0 ,
+ local = 1 ,
+ ref mask = 2 ,
+ global ref = 2 ,
+ local ref = 3 ,
+ module nr = 4 ,
+ immediate value = 5 ,
+
+ eumel0 stack offset = 4 ,
+ local address limit = 16 384 ,
+
+ illegal ref operation = "REF not allowed" ,
+ deref on non ref = "DEREF on non-ref address" ,
+ global ref not allowed = "GLOBAL REF not allowed" ,
+ unknown kind = "Unknown address kind" ,
+ address overflow = "Address Overflow" ,
+ illegal plus operation = "+ not allowed" ;
+
+ADDRESS VAR result addr;
+
+INT CONST ref length :: 2 ;
+
+OP := (ADDRESS VAR l, ADDRESS CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+ADDRESS OP GLOB (INT CONST address level) :
+ result addr.kind := global ;
+ result addr.value := address level ;
+ IF memory management mode = data allocation by user
+ THEN result addr.value INCR global address offset
+ FI ;
+ result addr
+ENDOP GLOB ;
+
+ADDRESS OP LOC (INT CONST address level) :
+ result addr.kind := local ;
+ result addr.value := address level + eumel0 stack offset ;
+ result addr
+ENDOP LOC ;
+
+ADDRESS OP REF (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ IF result addr.kind = local THEN result addr.kind INCR ref mask
+ ELIF result addr.kind = global THEN errorstop (global ref not allowed)
+ ELSE errorstop (illegal ref operation)
+ FI ;
+ result addr
+ENDOP REF ;
+
+ADDRESS OP DEREF (ADDRESS CONST ref address) :
+ CONCR (result addr) := CONCR (ref address) ;
+ IF is not local ref THEN errorstop (deref on non ref) FI ;
+ result addr.kind DECR ref mask ;
+ result addr .
+
+is not local ref :
+ result addr.kind <> local ref
+ENDOP DEREF ;
+
+INT OP REPR (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global :
+ CASE local : set bit (result addr.value, 15)
+ CASE global ref : errorstop (global ref not allowed)
+ CASE local ref : prep local ref
+ OTHERWISE errorstop (unknown kind)
+ ENDSELECT ;
+ result addr.value .
+
+prep local ref :
+ IF address limit exceeded THEN errorstop (address overflow) FI ;
+ set bit (result addr.value, 14) ;
+ set bit (result addr.value, 15) .
+
+address limit exceeded :
+ result addr.value < eumel0 stack offset OR
+ result addr.value > local address limit
+ENDOP REPR ;
+
+BOOL PROC is ref (ADDRESS CONST addr) :
+ addr.kind = local ref
+ENDPROC is ref ;
+
+BOOL PROC is global (ADDRESS CONST addr) :
+ addr.kind = global
+ENDPROC is global ;
+
+BOOL PROC is local (ADDRESS CONST addr) :
+ addr.kind = local
+ENDPROC is local ;
+
+ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global : inc global
+ CASE local : inc local
+ OTHERWISE errorstop (illegal plus operation)
+ ENDSELECT ;
+ result addr .
+
+inc global :
+ result addr.value INCR offset ;
+ IF result addr.value < 0 THEN errorstop (address overflow) FI .
+
+inc local :
+ result addr.value INCR offset ;
+ IF result addr.value < eumel 0 stack offset OR
+ result addr.value > local address limit
+ THEN errorstop (address overflow)
+ FI
+ENDOP + ;
+
+PROC adjust (ADDRESS VAR addr, INT CONST adjust length) :
+ IF is local or global THEN adjust to length FI .
+
+is local or global :
+ addr.kind <= local .
+
+adjust to length :
+ mode := addr.value MOD adjust length ;
+ IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI
+ENDPROC adjust ;
+
+TEXT PROC dump (ADDRESS CONST addr) :
+ kind + text (addr.value) .
+
+kind :
+ SELECT addr.kind OF
+ CASE global : "GLOBAL "
+ CASE local : "LOCAL "
+ CASE immediate value : "IMMEDIATE "
+ CASE module nr : "PARAM PROC "
+ CASE global ref : "GLOBAL REF "
+ CASE local ref : "LOCAL REF "
+ OTHERWISE "undef. Addr:"
+ ENDSELECT
+ENDPROC dump;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 4. Datentypen Teil I 03.12.1985 *)
+(* *)
+(* Definition des Datentyps DTYPE *)
+(* *)
+(* Interne Repraesentation der primitiven Datentypen *)
+(* Identifikation von DTYPEs *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE DTYPE = INT ;
+
+OP := (DTYPE VAR l, DTYPE CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+BOOL OP = (DTYPE CONST l, r) :
+ CONCR (l) = CONCR (r)
+ENDOP = ;
+
+DTYPE PROC void type : DTYPE :(void) ENDPROC void type ;
+
+DTYPE PROC int type : DTYPE :(int ) ENDPROC int type ;
+
+DTYPE PROC real type : DTYPE :(real) ENDPROC real type ;
+
+DTYPE PROC text type : DTYPE :(string) ENDPROC text type ;
+
+DTYPE PROC bool type : DTYPE :(bool) ENDPROC bool type ;
+
+DTYPE PROC dataspace type : DTYPE :(dataspace) ENDPROC dataspace type ;
+
+DTYPE PROC undefined type : DTYPE :(undefined) ENDPROC undefined type ;
+
+DTYPE PROC row type : DTYPE :(row) ENDPROC row type ;
+
+DTYPE PROC struct type : DTYPE :(struct) ENDPROC struct type ;
+
+DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ;
+
+DTYPE PROC end type : DTYPE :(end) ENDPROC end type ;
+
+INT PROC type class (DTYPE CONST type) :
+ SELECT type id OF
+ CASE int, real, bool, string, dataspace, undefined : 1
+ CASE void : 0
+ CASE row : 3
+ CASE struct : 4
+ CASE permanent param proc : 5
+ OTHERWISE pt type
+ ENDSELECT .
+
+pt type :
+ IF type id > ptt limit THEN permanent row or struct
+ ELSE abstract type
+ FI .
+
+abstract type : 2 .
+
+permanent row or struct :
+ mode := cdbint (type link into pt) MOD ptt limit ;
+ IF mode = struct THEN 4
+ ELIF mode = row THEN 3
+ ELSE 2
+ FI .
+
+type link into pt :
+ type id + begin of pt minus ptt limit .
+
+type id : CONCR (type)
+ENDPROC type class ;
+
+PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) :
+ SELECT type pos OF
+ CASE 1 : size := 0; align := 0; type id := void
+ CASE 6 : size := 1; align := 1; type id := int
+ CASE 10 : size := 4; align := 4; type id := real
+ CASE 15 : size := 8; align := 4; type id := string
+ CASE 20 : size := 1; align := 1; type id := bool
+ CASE 25 : size := 1; align := 1; type id := dataspace
+ OTHERWISE search for type in permanent table
+ ENDSELECT .
+
+type pos :
+ enclose in delimiters ;
+ pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) .
+
+enclose in delimiters :
+ object name := "." ;
+ object name CAT name ;
+ object name CAT "." .
+
+search for type in permanent table :
+ to object (name) ;
+ IF NOT found THEN size := 0; align := 0; type id := undefined
+ ELSE size := cdbint (permanent pointer + two wordlength) ;
+ type id := permanent pointer - begin of permanent table ;
+ IF size < two wordlength THEN align := 1
+ ELIF size < four wordlength THEN align := 2
+ ELSE align := 4
+ FI
+ FI .
+
+type id : CONCR (type)
+ENDPROC identify ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 5. Operationen Teil I 21.03.1986 *)
+(* *)
+(* Definition des Datentyps OPN *)
+(* Primitive Operationen (:= etc.) *)
+(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ;
+
+LET proc op = 0 ,
+ param proc = 1 ,
+ eumel 0 = 2 ,
+ nil = 3 ,
+
+ param proc at non ref = "PARAM PROC at non-ref address" ,
+ proc op expected = "PROC expected" ;
+
+OPN VAR eumel0 opn;
+eumel0 opn.kind := eumel0 ;
+eumel0 opn.top of stack := 0 ;
+
+eumel0 opn.mod nr := q pp ;
+OPN CONST pp :: eumel0 opn ,
+ nop code :: OPN :(nil, 0, 0) ;
+
+THESAURUS VAR eumel 0 opcodes :: empty thesaurus ;
+
+PROC init op codes (FILE VAR eumelcodes) :
+ eumel 0 opcodes := empty thesaurus ;
+ WHILE NOT eof (eumelcodes) REP
+ getline (eumelcodes, object name) ;
+ delete trailing blanks ;
+ IF object name <> "" CAND NOT (eumel 0 opcodes CONTAINS object name)
+ THEN insert (eumel 0 opcodes, object name)
+ FI
+ PER .
+
+delete trailing blanks :
+ WHILE (object name SUB LENGTH object name) = " " REP
+ object name := subtext (object name, 1, LENGTH object name - 1)
+ PER
+ENDPROC init op codes ;
+
+ADDRESS PROC address (OPN CONST opn) :
+ IF opn.kind <> proc op THEN errorstop (proc op expected) FI ;
+ result addr.kind := module nr ;
+ result addr.value := opn.mod nr ;
+ result addr
+ENDPROC address ;
+
+OPN PROC operation (ADDRESS CONST addr) :
+ IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ;
+ OPN VAR opn ;
+ opn.kind := param proc ;
+ opn.mod nr :=addr.value ;
+ opn.top of stack := 0 ;
+ opn
+ENDPROC operation ;
+
+TEXT PROC mnemonic (OPN CONST op code) :
+ name (eumel 0 opcodes, op code.mod nr)
+ENDPROC mnemonic ;
+
+OPN PROC nop :
+ nop code
+ENDPROC nop ;
+
+OP := (OPN VAR r, OPN CONST l) :
+ CONCR (r) := CONCR (l)
+ENDOP := ;
+
+BOOL PROC is proc (OPN CONST operation) :
+ operation.kind = proc op
+ENDPROC is proc ;
+
+BOOL PROC is eumel 0 instruction (TEXT CONST op code name) :
+ link (eumel 0 opcodes, op code name) <> 0
+ENDPROC is eumel 0 instruction ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 6. Parameterfeld 10.01.1986 *)
+(* *)
+(* Bereitstellen des Parameterfeldes *)
+(* Schreiben und Lesen von Eintraegen im Parameterfeld *)
+(* Fortschalten von Zeigern in das Parameterfeld *)
+(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access,
+ ADDRESS addr, OPN push opn) ,
+
+ size of param field = 100 ,
+ param field exceeded = "Param Field Overflow",
+ param nr out of range = "Illegal Param Number" ;
+
+ROW size of param field PARAMDESCRIPTOR VAR param field ;
+
+
+ (***** Schreiben *****)
+
+PROC test param pos (INT CONST param nr) :
+ IF param nr < 1 OR param nr > size of param field
+ THEN errorstop (param nr out of range)
+ FI
+ENDPROC test param pos ;
+
+PROC declare (INT CONST param nr, DTYPE CONST type) :
+ test param pos (param nr) ;
+ enter type .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type)
+ENDPROC declare ;
+
+PROC declare (INT CONST param nr, access) :
+ test param pos (param nr) ;
+ enter access .
+
+enter access :
+ param field [param nr].access := access
+ENDPROC declare ;
+
+PROC define (INT CONST param nr, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter address .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr)
+ENDPROC define ;
+
+PROC define (INT CONST param nr, value) :
+ result addr.kind := immediate value ;
+ result addr.value := value ;
+ define (param nr, result addr)
+ENDPROC define ;
+
+PROC apply (INT CONST param nr, OPN CONST opn) :
+ test param pos (param nr) ;
+ enter push opn .
+
+enter push opn :
+ CONCR (param field [param nr].push opn) := CONCR (opn)
+ENDPROC apply ;
+
+PROC parameter (INT CONST param nr, DTYPE CONST type,
+ INT CONST access, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter type ;
+ enter access ;
+ enter address ;
+ enter pp as default .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type) .
+
+enter access :
+ param field [param nr].access := access .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr) .
+
+enter pp as default :
+ CONCR (param field [param nr].push opn) := CONCR (pp)
+ENDPROC parameter ;
+
+
+ (***** Lesen *****)
+
+ADDRESS PROC param address (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].addr
+ENDPROC param address ;
+
+DTYPE PROC dtype (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].type
+ENDPROC dtype ;
+
+INT PROC access (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].access
+ENDPROC access ;
+
+
+ (***** Fortschalten *****)
+
+OP NEXTPARAM (INT VAR param nr) :
+ test param pos (param nr) ;
+ IF long entry THEN read until end FI ;
+ param nr INCR 1 .
+
+long entry :
+ type class (param field [param nr].type) > 2 .
+
+read until end :
+ REP
+ param nr INCR 1 ;
+ NEXTPARAM param nr
+ UNTIL end marker read or end of field PER .
+
+end marker read or end of field :
+ param nr > size of param field OR
+ CONCR (param field [param nr].type) = end
+ENDOP NEXTPARAM ;
+
+INT PROC next param (INT CONST p) :
+ index := p ;
+ NEXTPARAM index ;
+ index
+ENDPROC next param ;
+
+TEXT PROC dump (INT CONST p) :
+ IF p > 0 AND p <= 100 THEN dump entry (param field (p))
+ ELSE param nr out of range
+ FI
+ENDPROC dump ;
+
+TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) :
+ object name := dump (id.type) ;
+ object name CAT text (id.access) ;
+ object name CAT dump (id.addr) ;
+ object name CAT dump (id.push opn) ;
+ object name
+ENDPROC dump entry ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 7. Datentypen Teil II 20.01.1986 *)
+(* *)
+(* Deklaration neuer Datentypen *)
+(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+
+DTYPE VAR pt type ;
+
+PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) :
+ entry into name table ;
+ put next permanent (permanent type) ;
+ put next permanent (size) ;
+ put next permanent (nt link) ;
+ mark no offsets of text elements .
+
+entry into name table :
+ declare object (name, nt link, CONCR (type)) .
+
+mark no offsets of text elements :
+ put next permanent (0)
+ENDPROC declare ;
+
+BOOL PROC same type (INT CONST param 1, param 2) :
+ INT CONST left type :: CONCR (param field [param 1].type) ;
+ IF left type = right type
+ THEN same fine structure if there is one
+ ELSE left type = undefined OR right type = undefined
+ FI .
+
+right type : CONCR (param field [param 2].type) .
+
+same fine structure if there is one :
+ IF left type = row THEN compare row
+ ELIF left type = struct THEN compare struct
+ ELSE TRUE
+ FI .
+
+compare row :
+ equal sizes AND same type (param1 + 1, param2 + 1) .
+
+equal sizes :
+ param field [param1+1].access = param field [param2+1].access .
+
+compare struct :
+ INT VAR p1 :: param1+1, p2 :: param2+1 ;
+ REP
+ IF NOT same type (p1, p2) THEN LEAVE same type WITH FALSE
+ ELIF end type found THEN LEAVE same type WITH TRUE
+ FI ;
+ NEXTPARAM p1 ;
+ NEXTPARAM p2
+ UNTIL end of field PER ;
+ FALSE .
+
+end type found :
+ CONCR (param field [p1].type) = end .
+
+end of field :
+ p1 > size of param field OR p2 > size of param field
+ENDPROC same type ;
+
+BOOL PROC same type (INT CONST param nr, DTYPE CONST type) :
+ field pointer := param nr ;
+ CONCR (pt type) := CONCR (type) ;
+ equal types
+ENDPROC same type ;
+
+BOOL PROC equal types :
+ identical types OR one type is undefined .
+
+one type is undefined :
+ type of actual field = undefined OR CONCR(pt type) = undefined .
+
+identical types :
+ SELECT type class (pt type) OF
+ CASE 0, 1, 2 : type of actual field = CONCR (pt type)
+ CASE 3 : perhaps equal rows
+ CASE 4 : perhaps equal structs
+ OTHERWISE FALSE
+ ENDSELECT .
+
+perhaps equal rows :
+ is row AND equal row sizes AND equal row types .
+
+is row :
+ type of actual field = row .
+
+perhaps equal structs :
+ is struct AND same type fields .
+
+is struct :
+ type of actual field = struct .
+
+equal row sizes :
+ pt row size = row size within param field .
+
+equal row types :
+ same type (field pointer + 1, pt row type) .
+
+pt row size :
+ cdb int (CONCR(pt type) + offset to row size) .
+
+pt row type :
+ CONCR (pt type) INCR 2 ;
+ pt type .
+
+row size within param field :
+ param field [field pointer].access .
+
+same type fields :
+ field pointer INCR 1 ;
+ CONCR (pt type) INCR 1 ;
+ REP
+ IF NOT equal types THEN LEAVE same type fields WITH FALSE FI ;
+ IF type of actual field = end
+ THEN LEAVE same type fields WITH TRUE
+ FI ;
+ NEXTPARAM field pointer
+ UNTIL end of field PER ;
+ FALSE .
+
+end of field :
+ field pointer > size of param field .
+
+type of actual field :
+ CONCR (param field [field pointer].type) .
+ENDPROC equal types ;
+
+BOOL PROC is not void bool or undefined (DTYPE CONST dtype) :
+ type <> void AND type <> bool AND type <> undefined .
+
+type : CONCR (dtype)
+ENDPROC is not void bool or undefined ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 8. Operationen Teil II 07.03.1986 *)
+(* *)
+(* Definition der Opcodes *)
+(* Deklaration, Definition, Identifikation und Applikation *)
+(* Eroeffnen und Schliessen eines Moduls *)
+(* *)
+(**************************************************************************)
+
+
+
+LET module not opened = "Module not opened" ,
+ define missing = "DEFINE missing" ,
+ wrong nr of params = "Wrong Nr. of Params:" ,
+ illegal kind = "Opcode expected" ,
+ nested module = "Nested Modules" ,
+ no mod nr = "Param Proc expected" ,
+ no immediate value = "Value expected" ,
+ type error = "Type Error" ,
+
+ q ln = 1 ,
+ q move = 2 , q move code = 2 048 ,
+ q inc1 = 3 , q inc1 code = 3 072 ,
+ q dec1 = 4 , q dec1 code = 4 096 ,
+ q inc = 5 , q inc code = 5 120 ,
+ q dec = 6 , q dec code = 6 144 ,
+ q add = 7 , q add code = 7 168 ,
+ q sub = 8 , q sub code = 8 192 ,
+ q clear = 9 , q clear code = 9 216 ,
+ q test = 10 ,
+ q equ = 11 , q equ code = 11 264 ,
+ q lsequ = 12 , q lsequ code = 12 288 ,
+ q fmove = 13 , q fmove code = 13 312 ,
+ q fadd = 14 , q fadd code = 14 336 ,
+ q fsub = 15 , q fsub code = 15 360 ,
+ q fmult = 16 , q fmult code = 16 384 ,
+ q fdiv = 17 , q fdiv code = 17 408 ,
+ q flsequ = 18 , q flsequ code = 18 432 ,
+ q tmove = 19 , q tmove code = 19 456 ,
+ q tequ = 20 , q tequ code = 20 480 ,
+ q accds = 21 , q access ds code = 22 528 ,
+ q ref = 22 , q ref code = 23 552 ,
+ q subscript = 23 , q subscript code = 24 576 ,
+ q select = 24 , q select code = 25 600 ,
+ q ppv = 25 ,
+ q pp = 26 ,
+ q make false = 27 , (* q make false code = 65 513 *)
+ q movex = 28 ,
+(* q longa subs q longa subs code = 65 376 *)
+ q return = 29 , q return code = 32 512 ,
+ q true return = 30 , q true return code = 32 513 ,
+ q false return = 31 , q false return code = 32 514 ,
+ q goret code = 32 519 ,
+ q esc mult = 32 , q esc mult code = 32 553 ,
+ q esc div = 33 , q esc div code = 32 554 ,
+ q esc mod = 34 , q esc mod code = 32 555 ,
+ q pproc = 35 ,
+ q compl int = 36 , q compl int code = 32 551 ,
+ q compl real = 37 , q compl real code = 32 550 ,
+(* q alias ds = 38 , *)
+ q movim = 39 , q esc movim code = 32 547 ,
+ q fequ = 40 , q fequ code = 32 548 ,
+ q tlsequ = 41 , q tlsequ code = 32 549 ,
+(* q case = 42 , *)
+ q plus = 43 ,
+ q minus = 44 ,
+ q mult = 45 ,
+ q int div = 46 ,
+ q real div = 47 ,
+ q equal = 48 ,
+ q lessequal = 49 ;
+
+INT CONST q make false code :: - 1 022 ,
+ q longa subs code :: - 159 ;
+
+
+ (***** Deklaration *****)
+
+PROC declare (OPN VAR operation) :
+ operation.kind := proc op ;
+ get module nr (operation.mod nr) ;
+ operation.top of stack := 0
+ENDPROC declare ;
+
+PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) :
+ declare (operation) ;
+ entry into name and pt table if necessary ;
+ enter params ;
+ enter result ;
+ enter module number .
+
+entry into name and pt table if necessary :
+ declare object (name, nt link, permanent pointer) .
+
+enter params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO params REP
+ enter param (param field [field pointer]) ;
+ NEXTPARAM field pointer
+ PER .
+
+enter result :
+ enter param (param field[field pointer].type, permanent proc op) .
+
+enter module number :
+ put next permanent (operation.mod nr)
+ENDPROC declare ;
+
+PROC enter param (PARAMDESCRIPTOR CONST param) :
+ IF param.access = const
+ THEN enter param (param.type, permanent param const)
+ ELIF param.access = var
+ THEN enter param (param.type, permanent param var)
+ ELSE errorstop ("Unknown Access")
+ FI
+ENDPROC enter param ;
+
+PROC enter param (DTYPE CONST type, INT CONST permanent mode) :
+ SELECT type class (type) OF
+ CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode)
+ OTHERWISE errorstop ("Illegal Type")
+ ENDSELECT
+ENDPROC enter param ;
+
+
+ (***** Definition *****)
+
+PROC define (OPN VAR opn) :
+ IF NOT module open THEN errorstop (module not opened)
+ ELSE proc head (opn.mod nr, opn.top of stack)
+ FI
+ENDPROC define ;
+
+PROC set length of local storage (OPN VAR opn, INT CONST size) :
+ IF size < 0 OR size > local address limit
+ THEN errorstop (address overflow)
+ ELIF opn.top of stack = 0
+ THEN errorstop (define missing)
+ ELIF opn.kind <> proc op
+ THEN errorstop (proc op expected)
+ FI ;
+ set length (opn.top of stack, size + eumel0 stack offset)
+ENDPROC set length of local storage ;
+
+PROC define (OPN VAR operation, INT CONST size) :
+ define (operation) ;
+ set length of local storage (operation, size)
+ENDPROC define ;
+
+
+ (***** Identifikation *****)
+
+INT VAR counter, result index, result type repr;
+
+PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation,
+ BOOL VAR object exists) :
+ find result entry ;
+ to object (name) ;
+ IF found THEN first fit and leave if found FI ;
+ IF eumel0 THEN identify eumel0 instruction
+ ELSE yield undefined operation
+ FI .
+
+find result entry :
+ result index := first;
+ counter := 0 ;
+ WHILE counter < params REP
+ NEXTPARAM result index ;
+ counter INCR 1
+ PER ;
+ check on param field exceeded .
+
+check on param field exceeded :
+ IF result index > size of param field
+ THEN errorstop (param field exceeded)
+ FI .
+
+yield undefined operation :
+ declare (result index, undefined type) ;
+ apply (result index, nop) ;
+ object exists := FALSE .
+
+first fit and leave if found :
+ WHILE yet another procedure exists REP
+ check one procedure and leave if match ;
+ next procedure
+ PER .
+
+yet another procedure exists :
+ permanent pointer <> 0 .
+
+check one procedure and leave if match:
+ param link := permanent pointer + wordlength ;
+ set end marker if end of list ;
+ counter := params ;
+ field pointer := 1 ;
+ REP
+ IF end of params AND counter = 0
+ THEN procedure found
+ ELIF end of params OR counter = 0
+ THEN LEAVE check one procedure and leave if match
+ ELSE check next param
+ FI
+ PER .
+
+check next param :
+ get type and mode (CONCR(pt type)) ;
+ IF same types THEN set param mode ;
+ counter DECR 1 ;
+ field pointer INCR 1 ;
+ next pt param
+ ELSE LEAVE check one procedure and leave if match
+ FI .
+
+same types : (* inline version ! *)
+ equal types .
+
+set param mode :
+ param field [field pointer].access := mode .
+
+procedure found :
+ get result ;
+ operation.kind := proc op ;
+ operation.mod nr := module number ;
+ operation.top of stack := 0 ;
+ object exists := TRUE ;
+ LEAVE identify .
+
+get result :
+ get type and mode (result type) ;
+ declare (result index, mode) .
+
+module number :
+ cdbint (param link + 1) .
+
+result type :
+ CONCR (param field [result index].type) .
+
+eumel0 :
+ eumel0 opn.mod nr := link (eumel 0 opcodes, name) ;
+ eumel0 opn.mod nr <> 0 .
+
+identify eumel 0 instruction :
+ init result type with void ;
+ CONCR (operation) := CONCR (eumel0 opn) ;
+ object exists := check params and set result ;
+ declare (result index, DTYPE:(result type repr)) ;
+ declare (result index, const) .
+
+init result type with void :
+ result type repr := void .
+
+check params and set result :
+ SELECT operation.mod nr OF
+ CASE q return, q false return, q true return : no params
+ CASE q inc1, q dec1 : one int param yielding void
+ CASE q pproc, q pp, q ln : one param yielding void
+ CASE q test : one param yielding bool
+ CASE q clear, q ppv : one int or bool param yielding void
+ CASE q make false : one bool param yielding void
+ CASE q move : two int or bool params yielding void
+ CASE q compl int, q inc, q dec : two int params yielding void
+ CASE q compl real, q fmove : two real params yielding void
+ CASE q equ, q lsequ : two int params yielding bool
+ CASE q fequ, q flsequ : two real params yielding bool
+ CASE q tequ, q tlsequ : two text params yielding bool
+ CASE q tmove : two text params yielding void
+ CASE q accds, q ref : two params yielding void
+ CASE q add, q sub, q esc mult,
+ q esc div, q esc mod : three int params yielding void
+ CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void
+ CASE q select, q movex : three params
+ CASE q subscript : five params
+ CASE q plus, q minus, q mult : two intreals yielding intreal
+ CASE q int div : two int params yielding int
+ CASE q real div : two real params yielding real
+ CASE q equal, q lessequal : two intrealtexts yielding bool
+ OTHERWISE FALSE
+ ENDSELECT .
+
+no params :
+ params = 0 .
+
+one int param yielding void :
+ p1 void (int type, first, params) .
+
+one param yielding void :
+ params = 1 .
+
+one param yielding bool :
+ IF params = 1 THEN result type repr := bool ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+one int or bool param yielding void :
+ p1 void (int type, first, params) OR p1 void (bool type, first, params) .
+
+one bool param yielding void :
+ p1 void (bool type, first, params) .
+
+two int or bool params yielding void :
+ p2 (int type, first, params, void) OR
+ p2 (bool type, first, params, void) .
+
+two int params yielding void :
+ p2 (int type, first, params, void) .
+
+two real params yielding void :
+ p2 (real type, first, params, void) .
+
+two text params yielding void :
+ p2 (text type, first, params, void) .
+
+two int params yielding bool :
+ p2 (int type, first, params, bool) .
+
+two real params yielding bool :
+ p2 (real type, first, params, bool) .
+
+two text params yielding bool :
+ p2 (text type, first, params, bool) .
+
+two params yielding void :
+ params = 2 .
+
+three int params yielding void :
+ p3 void (int type, first, params) .
+
+three real params yielding void :
+ p3 void (real type, first, params) .
+
+three params :
+ params = 3 .
+
+five params :
+ params = 5 .
+
+two intreals yielding intreal :
+ two int params yielding int OR two real params yielding real .
+
+two intrealtexts yielding bool :
+ two int params yielding bool OR two real params yielding bool OR
+ two text params yielding bool .
+
+two int params yielding int :
+ p2 (int type, first, params, int) .
+
+two real params yielding real :
+ p2 (real type, first, params, real)
+ENDPROC identify ;
+
+BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 1 AND param type is requested plain type .
+
+param type is requested plain type :
+ CONCR (param field [first].type) = CONCR (requested type)
+
+ENDPROC p1 void ;
+
+BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr,
+ INT CONST result type) :
+ IF param nr = 2 AND param types equal requested plain type
+ THEN result type repr := result type ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+param types equal requested plain type :
+ CONCR (param field [first] .type) = CONCR (requested type) AND
+ CONCR (param field [first+1].type) = CONCR (requested type)
+
+ENDPROC p2 ;
+
+BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 3 AND param types ok .
+
+param types ok :
+ FOR index FROM first UPTO first+2 REP
+ IF different param types THEN LEAVE p3 void WITH FALSE FI
+ PER ;
+ TRUE .
+
+different param types :
+ CONCR (param field [index].type) <> CONCR (requested type)
+ENDPROC p3 void;
+
+
+ (***** Applikation *****)
+
+INT VAR address representation, left repr, right repr, result repr;
+
+PROC apply (INT CONST first, nr of params, OPN CONST opn) :
+ IF NOT module open THEN errorstop (module not opened) FI ;
+ SELECT opn.kind OF
+ CASE eumel 0 : generate eumel0 instruction
+ CASE proc op : call operation
+ CASE param proc : call param proc
+ CASE nil :
+ OTHERWISE errorstop (illegal kind)
+ ENDSELECT .
+
+call operation :
+ push params if necessary (first, nr of params, opn.mod nr) ;
+ call (opn.mod nr) .
+
+call param proc :
+ result addr.kind := local ref ;
+ result addr.value := opn.mod nr ;
+ address representation := REPR result addr ;
+ push params if necessary (first, nr of params, address representation) ;
+ call param (address representation) .
+
+generate eumel0 instruction :
+ SELECT real nr of params OF
+ CASE 0 : p0 instruction
+ CASE 1 : apply p1 (opn, first addr)
+ CASE 2 : apply p2 (opn, first addr, second addr)
+ CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr)
+ CASE 5 : subscript operation
+ OTHERWISE errorstop (wrong nr of params + text (nr of params))
+ ENDSELECT .
+
+real nr of params :
+ IF operator denotation THEN nr of params + 1
+ ELSE nr of params
+ FI .
+
+operator denotation :
+ opn.mod nr >= q plus .
+
+p0 instruction :
+ IF opn.mod nr = q return THEN s0 (q return code)
+ ELIF opn.mod nr = q true return THEN s0 (q true return code)
+ ELIF opn.mod nr = q false return THEN s0 (q false return code)
+ ELSE errorstop (wrong nr of params +
+ mnemonic (opn))
+ FI .
+
+subscript operation :
+ IF opn.mod nr = q subscript
+ THEN subscription
+ ELSE errorstop (wrong nr of params + text (nr of params))
+ FI .
+
+subscription :
+ ADDRESS CONST element length :: param field [first+2].addr ,
+ limit :: param field [first+3].addr ;
+ check on immediates ;
+ IF element length.value < 1024
+ THEN s0 (q subscript code + element length.value)
+ ELSE s0 (q longa subs code) ;
+ s0 (element length.value)
+ FI ;
+ s3 (limit.value - 1, subs index, base addr, subs result) .
+
+check on immediates :
+ IF element length.kind <> immediate value OR
+ limit.kind <> immediate value
+ THEN errorstop (no immediate value)
+ FI .
+
+subs index : REPR param field [first+1].addr .
+
+base addr : REPR param field [first].addr .
+
+subs result : REPR param field [first+4].addr .
+
+first addr :
+ param field [first].addr .
+
+left type :
+ param field [first].type .
+
+second addr :
+ param field [nextparam (first)].addr .
+
+third addr :
+ param field [nextparam(nextparam(first))].addr
+ENDPROC apply ;
+
+PROC push params if necessary (INT CONST first, nr of params, mod nr) :
+ init param push (mod nr) ;
+ IF nr of params > 0 THEN push params ;
+ push result if there is one
+ FI .
+
+push params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO nr of params REP
+ apply p1 (push code, param addr) ;
+ NEXTPARAM field pointer
+ PER .
+
+push code :
+ param field [field pointer].push opn .
+
+param addr :
+ param field [field pointer].addr .
+
+push result if there is one :
+ IF push result necessary
+ THEN push result address (REPR param field [field pointer].addr)
+ FI .
+
+push result necessary :
+ param field [field pointer].push opn.kind <> nil AND
+ is not void bool or undefined (param field [field pointer].type)
+ENDPROC push params if necessary ;
+
+PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) :
+ IF opn.mod nr = q ln THEN generate line number
+ ELIF opn.mod nr = q pproc THEN push module nr
+ ELSE gen p1 instruction
+ FI .
+
+gen p1 instruction :
+ address representation := REPR addr ;
+ SELECT opn.mod nr OF
+ CASE q inc1 : t1 (q inc1 code, address representation)
+ CASE q dec1 : t1 (q dec1 code, address representation)
+ CASE q clear : t1 (q clear code,address representation)
+ CASE q test : test bool object (address representation)
+ CASE q pp : push param (address representation)
+ CASE q make false : s1 (q make false code, address representation)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+generate line number :
+ IF addr.kind = immediate value THEN mark line (addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+push module nr :
+ IF addr.kind = module nr THEN push param proc (addr.value)
+ ELSE errorstop (no mod nr)
+ FI
+ENDPROC apply p1;
+
+PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr):
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movim THEN move immediate
+ ELSE gen p2 instruction
+ FI .
+
+gen p2 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q move : t2 (q move code, right repr, left repr)
+ CASE q inc : t2 (q inc code, right repr, left repr)
+ CASE q dec : t2 (q dec code, right repr, left repr)
+ CASE q equ : compare (q equ code, left repr, right repr)
+ CASE q lsequ : compare (q lsequ code, left repr, right repr)
+ CASE q fmove : t2 (q fmove code, right repr, left repr)
+ CASE q flsequ : compare (q flsequ code, left repr, right repr)
+ CASE q tmove : t2 (q tmove code, right repr, left repr)
+ CASE q tequ : compare (q tequ code, left repr, right repr)
+ CASE q compl int : s2 (q compl int code, left repr, right repr)
+ CASE q compl real : s2 (q compl real code, left repr, right repr)
+ CASE q fequ : compare (q fequ code, left repr, right repr)
+ CASE q tlsequ : compare (q tlsequ code, left repr, right repr)
+ CASE q accds : t2 (q access ds code, left repr, right repr)
+ CASE q ref : t2 (q ref code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+move immediate :
+ IF right addr.kind = immediate value
+ THEN s0 (q esc movim code) ;
+ s1 (left repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI
+ENDPROC apply p2;
+
+PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype,
+ ADDRESS CONST left addr, right addr, result addr ):
+ left repr := REPR left addr ;
+ result repr := REPR result addr ;
+ IF opn.mod nr = q select THEN gen select instruction
+ ELIF opn.mod nr = q movex THEN gen long move
+ ELSE gen p3 instruction
+ FI .
+
+gen p3 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q add : int add
+ CASE q sub : int sub
+ CASE q fadd : real add
+ CASE q fsub : real sub
+ CASE q fmult : real mult
+ CASE q fdiv, q real div : real div
+ CASE q esc mult : int mult
+ CASE q esc div, q int div : int div
+ CASE q esc mod : int mod
+ CASE q plus : int real add
+ CASE q minus : int real sub
+ CASE q mult : int real mult
+ CASE q equal, q lessequal : compare (comp code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+gen select instruction :
+ IF right addr.kind = immediate value
+ THEN t1 (q select code, left repr) ;
+ s1 (right addr.value, result repr)
+ ELSE errorstop (no immediate value)
+ FI .
+
+gen long move :
+ IF right addr.kind = immediate value
+ THEN long move (left repr, result repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+int add : compute (q add code, left repr, right repr, result repr) .
+
+int sub : compute (q sub code, left repr, right repr, result repr) .
+
+real add : compute (q fadd code, left repr, right repr, result repr) .
+
+real sub : compute (q fsub code, left repr, right repr, result repr) .
+
+real mult : compute (q fmult code, left repr, right repr, result repr) .
+
+real div : compute (q fdiv code, left repr, right repr, result repr) .
+
+int mult : s3 (q esc mult code, left repr, right repr, result repr) .
+
+int div : s3 (q esc div code, left repr, right repr, result repr) .
+
+int mod : s3 (q esc mod code, left repr, right repr, result repr) .
+
+int real add :
+ IF left type = int THEN int add
+ ELSE real add
+ FI .
+
+int real sub :
+ IF left type = int THEN int sub
+ ELSE real sub
+ FI .
+
+int real mult :
+ IF left type = int THEN int mult
+ ELSE real mult
+ FI .
+
+comp code :
+ SELECT left type OF
+ CASE int : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI
+ CASE real : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI
+ CASE string : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI
+ OTHERWISE errorstop (type error); q equ
+ ENDSELECT .
+
+left type : CONCR (left dtype)
+
+ENDPROC apply p3;
+
+
+ (***** Modul *****)
+
+BOOL VAR module open ;
+
+.init opn section :
+ module open := FALSE .;
+
+PROC begin module :
+ IF module open THEN errorstop (nested module)
+ ELSE begin modul ;
+ module open := TRUE
+ FI
+ENDPROC begin module ;
+
+PROC end module :
+ IF NOT module open
+ THEN errorstop (module not opened)
+ ELSE end modul ;
+ module open := FALSE
+ FI
+ENDPROC end module ;
+
+TEXT PROC dump (OPN CONST operation) :
+ IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5)
+ ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation)
+ ELSE " undef. Opn"
+ FI
+ENDPROC dump ;
+
+PROC begin modul :
+ EXTERNAL 10072
+ENDPROC begin modul ;
+
+PROC end modul :
+ EXTERNAL 10011
+ENDPROC end modul ;
+
+PROC proc head (INT VAR mod nr, top of stack) :
+ EXTERNAL 10012
+ENDPROC proc head ;
+
+PROC set length (INT CONST top of stack, size) :
+ EXTERNAL 10013
+ENDPROC set length ;
+
+PROC get module nr (INT VAR module nr) :
+ EXTERNAL 10016
+ENDPROC get module nr ;
+
+PROC compute (INT CONST op code, l addr, r addr, result address) :
+ EXTERNAL 10017
+ENDPROC compute ;
+
+PROC compare (INT CONST op code, l addr, r addr) :
+ EXTERNAL 10018
+ENDPROC compare ;
+
+PROC long move (INT CONST to, from, length) :
+ EXTERNAL 10019
+ENDPROC long move ;
+
+PROC put next permanent (INT CONST permanent value) :
+ EXTERNAL 10020
+ENDPROC put next permanent ;
+
+PROC call (INT CONST mod nr) :
+ EXTERNAL 10022
+ENDPROC call ;
+
+PROC call param (INT CONST mod nr) :
+ EXTERNAL 10023
+ENDPROC call param ;
+
+PROC push param (INT CONST addr) :
+ EXTERNAL 10024
+ENDPROC push param ;
+
+PROC push param proc (INT CONST mod nr) :
+ EXTERNAL 10025
+ENDPROC push param proc ;
+
+PROC init param push (INT CONST mod nr) :
+ EXTERNAL 10026
+ENDPROC init param push ;
+
+PROC push result address (INT CONST addr) :
+ EXTERNAL 10027
+ENDPROC push result address ;
+
+PROC test bool object (INT CONST addr) :
+ EXTERNAL 10187
+ENDPROC test bool object ;
+
+PROC mark line (INT CONST line number) :
+ EXTERNAL 10030
+ENDPROC mark line ;
+
+PROC s0 (INT CONST op code) :
+ EXTERNAL 10038
+ENDPROC s0 ;
+
+PROC s1 (INT CONST op code, addr) :
+ EXTERNAL 10039
+ENDPROC s1 ;
+
+PROC s2 (INT CONST op code , addr1, addr2) :
+ EXTERNAL 10040
+ENDPROC s2 ;
+
+PROC s3 (INT CONST op code, addr1, addr2, addr3) :
+ EXTERNAL 10041
+ENDPROC s3 ;
+
+PROC t1 (INT CONST op code, addr) :
+ EXTERNAL 10042
+ENDPROC t1 ;
+
+PROC t2 (INT CONST op code, addr1, addr2) :
+ EXTERNAL 10043
+ENDPROC t2 ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 9. Speicherverwaltung 21.03.1986 *)
+(* *)
+(* Ablage der Paketdaten *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR address value;
+
+INT CONST data allocation by coder := 1 ,
+ data allocation by user := 2 ;
+
+LET not initialized = 0 ,
+ wrong mm mode = "Wrong MM Mode" ,
+ define on non global = "Define for GLOB only" ,
+ text too long = "TEXT too long" ;
+
+TEXT VAR const buffer :: point line ;
+
+.reset memory management mode :
+ memory management mode := not initialized . ;
+
+PROC reserve storage (INT CONST size) :
+ IF memory management mode <> data allocation by user
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (address value, size) ;
+ memory management mode := not initialized
+ENDPROC reserve storage ;
+
+PROC allocate variable (ADDRESS VAR addr, INT CONST size) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (addr.value, size) ;
+ addr.kind := global
+ENDPROC allocate variable ;
+
+PROC allocate denoter (ADDRESS VAR addr, INT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate int denoter (addr.value) ;
+ put data word (value, addr.value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate real denoter (addr.value) ;
+ addr.kind := global ;
+ define (addr, value)
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ;
+ addr.kind := global ;
+ skip heaplink;
+ define (addr, value) ;
+ reset heaplink .
+
+skip heaplink :
+ addr.value INCR 1 .
+
+reset heaplink :
+ addr.value DECR 1
+ENDPROC allocate denoter ;
+
+PROC define (ADDRESS CONST addr, INT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value, addr.value)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, REAL CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ replace (const buffer, 1, value) ;
+ address value := addr.value ;
+ FOR index FROM 1 UPTO 4 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, TEXT CONST value) :
+ IF addr.kind <> global THEN errorstop (define on non global)
+ ELIF LENGTH value > 255 THEN errorstop (text too long)
+ FI ;
+ address value := addr.value ;
+ const buffer := code (LENGTH value) ;
+ const buffer CAT value ;
+ const buffer CAT " " ;
+ FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER ;
+ const buffer := point line
+ENDPROC define ;
+
+PROC prep pbase (INT VAR offset) :
+ EXTERNAL 10032
+ENDPROC prep pbase;
+
+PROC allocate var (INT VAR addr, INT CONST length) :
+ EXTERNAL 10033
+ENDPROC allocate var ;
+
+PROC allocate int denoter (INT VAR addr) :
+ EXTERNAL 10034
+ENDPROC allocate int denoter ;
+
+PROC allocate real denoter (INT VAR addr) :
+ EXTERNAL 10035
+ENDPROC allocate real denoter ;
+
+PROC allocate text denoter (INT VAR addr, INT CONST length) :
+ EXTERNAL 10036
+ENDPROC allocate text denoter ;
+
+PROC put data word (INT CONST value, INT CONST addr) :
+ EXTERNAL 10037
+ENDPROC put data word ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 08.01.1986 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, pattern length, packet link,
+ begin of packet, last packet entry, indentation;
+
+TEXT VAR bulletin name, type and mode, pattern, buffer;
+
+DATASPACE VAR bulletin ds :: nilspace ;
+
+.packet name :
+ cdb text (cdb int(packet link + wordlength) + two word length) .
+
+.within editor :
+ aktueller editor > 0 . ;
+
+TEXT PROC type name (DTYPE CONST type) :
+ type and mode := "" ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC type name ;
+
+TEXT PROC dump (DTYPE CONST type) :
+ type and mode := "TYPE " ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC dump ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DATASPACE"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+PROC help (TEXT CONST proc name) :
+ prep bulletin ;
+ prep help ;
+ scan (object name) ;
+ next symbol (pattern) ;
+ packet link := end of permanent table ;
+ IF function = 0 THEN standard help
+ ELSE asterisk help
+ FI .
+
+prep help :
+ object name := compress (proc name) ;
+ INT VAR function :: 0 ;
+ INT CONST l :: LENGTH object name ;
+ IF l > 1 AND object name <> "**"
+ THEN IF (object name SUB l) = "*"
+ THEN function INCR 2 ;
+ delete char (object name, l)
+ FI ;
+ IF (object name SUB 1) = "*"
+ THEN function INCR 1 ;
+ delete char (object name, 1)
+ FI ;
+ IF another asterisk THEN wrong function FI
+ FI.
+
+another asterisk :
+ pos (object name, "*") <> 0 .
+
+wrong function :
+ errorstop ("unzulaessige Sternfunktion") .
+
+standard help :
+ to object (pattern) ;
+ IF found THEN display
+ ELSE error stop ("unbekannt: " + proc name)
+ FI .
+
+display :
+ WHILE permanent pointer <> 0 REP
+ put name of packet if necessary ;
+ put specifications (pattern) ;
+ next procedure
+ ENDREP ;
+ show bulletin file .
+
+put name of packet if necessary :
+ IF new packet THEN packet link := permanent pointer ;
+ find begin of packet ;
+ writeline (2) ;
+ write packet name
+ FI .
+
+find begin of packet :
+ REP
+ packet link DECR wordlength
+ UNTIL begin of packet found PER .
+
+begin of packet found :
+ cdb int (packet link) = permanent packet .
+
+new packet :
+ permanent pointer < packet link .
+
+asterisk help :
+ hash table pointer := begin of hash table ;
+ pattern length := LENGTH pattern - 1 ;
+ REP
+ list all objects in current hash table chain ;
+ next hash entry
+ UNTIL end of hash table reached ENDREP ;
+ show bulletin file .
+
+list all objects in current hash table chain :
+ nt link := hash table pointer ;
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length) ;
+ IF matching THEN into bulletin FI
+ PER .
+
+matching :
+ INT CONST p :: pos (object name, pattern) ;
+ SELECT function OF
+ CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
+ CASE 2 : p = 1
+ CASE 3 : p <> 0
+ OTHERWISE FALSE
+ ENDSELECT .
+
+into bulletin :
+ object names into bulletin (BOOL PROC not end of chain)
+ENDPROC help ;
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC write packet name :
+ indentation := 0 ;
+ write line ;
+ write bulletin line ("PACKET ") ;
+ indentation := 7 ;
+ object name := packet name ;
+ write bulletin line (object name) ;
+ write bulletin line (":") ;
+ writeline (2)
+ENDPROC write packet name ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type;
+ get type and mode (type) ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF mode = const THEN " CONST"
+ ELIF mode = var THEN " VAR"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ forget (bulletin ds) ;
+ bulletin ds := nilspace ;
+ bulletin file := sequential file (output, bulletin ds) ;
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC show bulletin file :
+ IF within editor THEN ueberschrift neu FI ;
+ DATASPACE VAR local ds :: bulletin ds ;
+ FILE VAR local file :: sequential file (modify, local ds) ;
+ edit (local file) ;
+ forget (local ds)
+ENDPROC show bulletin file ;
+
+PROC write bulletin line (TEXT CONST line) :
+ IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := indentation * " "
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet ;
+ IF found THEN list packet ;
+ show bulletin file
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+to packet :
+ last packet entry := 0 ;
+ get nametab link of packet name ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+get nametab link of packet name :
+ to object (pattern) ;
+ IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ;
+ LEAVE to packet
+ FI .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC bulletin ;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ write packet name ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is at least one object of this name in the current packet
+ THEN into bulletin FI .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (object name, mode) ;
+ IF type definition THEN put type definition
+ ELSE put object definitions
+ FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put type definition :
+ put obj name (object name) ;
+ write bulletin line ("TYPE ") ;
+ writeline (1) .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ write line (4) ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC bulletin ;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := " " ;
+ bulletin name := point line ;
+ change (bulletin name, 1, end of line or name, name) ;
+ buffer CAT bulletin name ;
+ indentation := LENGTH buffer + 1 .
+
+end of line or name :
+ min (LENGTH name, LENGTH bulletin name)
+ENDPROC put obj name ;
+
+PROC packets :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ object name := packet name ;
+ put obj name (object name) ;
+ write line ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC packets ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 11. ELAN Run-Interface 09.01.1986 *)
+(* *)
+(* Uebersetzen von ELAN-Programmen *)
+(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
+(* *)
+(**************************************************************************)
+
+
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ listing enabled := FALSE ;
+
+FILE VAR listing file ;
+
+TEXT VAR listing file name := "" ;
+
+
+PROC run (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, no ins)
+END PROC run;
+
+PROC run :
+ run (last param)
+ENDPROC run ;
+
+PROC run again :
+ IF run again mod nr <> 0
+ THEN elan (run again mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+ ELSE errorstop ("'run again' nicht moeglich")
+ FI
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, ins)
+ENDPROC insert ;
+
+PROC insert :
+ insert (last param)
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+ FILE VAR source := sequential file (modify, file name) ;
+ IF listing enabled
+ THEN open listing file
+ FI ;
+
+ disable stop ;
+ no do again ;
+ elan (compile file mode, source, "" , run again mod nr,
+ insert option, list option, check option, sermon) ;
+
+ IF anything noted AND command dialogue
+ THEN ignore halt during compiling ;
+ note edit (source) ;
+ errorstop ("")
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+open listing file :
+ listing file := sequential file (output, listing file name) ;
+ max line length (listing file, 130)
+
+ENDPROC run elan ;
+(*
+PROC out text (TEXT CONST text, INT CONST out type) :
+ INTERNAL 257 ;
+ IF online
+ THEN out (text)
+ FI ;
+ IF out type = error message
+ THEN note (text) ;
+ number of errors INCR 1
+ ELIF out type = warning message
+ THEN note (text)
+ FI ;
+ IF listing enabled
+ THEN write (listing file, text)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+ INTERNAL 258 ;
+ IF online
+ THEN out (""13""10"")
+ FI ;
+ IF out type = error message OR out type = warning message
+ THEN note line
+ ELIF listing enabled
+ THEN line (listing file)
+ FI
+ENDPROC out line ;
+*)
+PROC prot (TEXT CONST file name) :
+ list option := TRUE ;
+ listing file name := file name ;
+ listing enabled := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE ;
+ listing enabled := FALSE
+ENDPROC prot off ;
+
+BOOL PROC prot :
+ list option
+ENDPROC prot ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+BOOL PROC check :
+ check option
+ENDPROC check ;
+
+ENDPACKET eumel coder ;
diff --git a/system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod new file mode 100644 index 0000000..6914548 --- /dev/null +++ b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod @@ -0,0 +1,2043 @@ +PACKET eumel coder (* Autor: U. Bartling *)
+ DEFINES coder on, coder off, (* 1.8.0-Korr. M.St. *)
+ declare, define, apply, identify, (* 21.11.86 *)
+ :=, =, (* EXTERNAL 10...Nummern*)
+ dump, (* und coderon-flags *)
+ (* inspector/coder1 weg *)
+ LABEL,
+ gosub, goret,
+ complement condition code,
+
+ ADDRESS ,
+ GLOB, LOC, REF, DEREF,
+ ref length,
+ +,
+ adjust,
+ is global, is local, is ref,
+
+ DTYPE,
+ type class, type name,
+ void type, int type, real type, text type, bool type,
+ dataspace type, undefined type,
+ row type, struct type, proc type, end type,
+
+ OPN,
+ set length of local storage,
+ begin module, end module,
+ is proc, is eumel 0 instruction,
+ address, operation,
+ nop,
+ init op codes,
+ mnemonic,
+
+ parameter,
+ next param,
+ NEXTPARAM,
+ access ,
+ dtype ,
+ param address,
+ same type ,
+
+ reserve storage,
+ allocate denoter ,
+ allocate variable,
+ data allocation by coder ,
+ data allocation by user :
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 13.02.1986 *)
+(* Stand der Implementation : 21.03.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR memory management mode, global address offset,
+ nt link, permanent pointer, param link, index, mode, field pointer;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 12.03.1986 *)
+(* 1.7.5.4 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+(* before first pt entry = 22784 , *)
+(* first permanent entry = 22785 , *)
+(* end of permanent table = 32767 , *)
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+ four word length = 4 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+ offset to row size = 12785 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ undefined = 9 ,
+ row = 10 ,
+ struct = 11 ,
+ end = 0 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+(* bold = 2 , *)
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+(* run again mode = 0 , *)
+(* compile file mode = 1 , *)
+ prep coder mode = 5 ,
+
+(* warning message = 2 , *)
+(* error message = 4 , *)
+
+ point line = "..............." ;
+(*
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+*)
+BOOL VAR coder active := FALSE ;
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+LET invalid coder off = "CODER not active" ;
+
+PROC coder on (INT CONST data allocation mode) :
+ mark coder on ;
+ init memory management ;
+ init opn section ;
+ init compiler .
+
+mark coder on :
+ coder active := TRUE .
+
+init memory management :
+ memory management mode := data allocation mode ;
+ prep pbase (global address offset) .
+
+init compiler :
+ no do again ;
+ elan (prep coder mode, bulletin file, "", run again mod nr,
+ no ins, prot, check, no sermon) (* prot, check f.test, M.St. *)
+
+ENDPROC coder on;
+
+PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) :
+ IF coder active
+ THEN mark coder off ;
+ end coder (insert, sermon, start mod nr if no insert)
+ ELSE errorstop (invalid coder off)
+ FI .
+
+start mod nr if no insert :
+ IF insert THEN run again mod nr := 0
+ ELSE run again mod nr := start proc.mod nr
+ FI ;
+ run again mod nr .
+
+mark coder off :
+ reset memory management mode ;
+ init opn section ;
+ coder active := FALSE
+ENDPROC coder off ;
+
+PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) :
+ EXTERNAL 10021
+ENDPROC end coder ;
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ (***** Hash/Namenstabelle *****)
+
+. yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 2. Spruenge und Marken 07.03.1986 *)
+(* *)
+(* Definition des Datentyps LABEL *)
+(* *)
+(* Deklaration, Definition und Applikation von Marken *)
+(* *)
+(**************************************************************************)
+
+
+TYPE LABEL = INT ;
+
+BOOL VAR invers :: FALSE ;
+
+PROC declare (LABEL VAR label) :
+ CONCR (label) := 0
+ENDPROC declare ;
+
+PROC define (LABEL VAR label) :
+ EXTERNAL 10083
+ENDPROC define ;
+
+PROC complement condition code :
+ invers := TRUE
+ENDPROC complement condition code ;
+
+PROC apply (LABEL VAR label) :
+ EXTERNAL 10148
+ENDPROC apply ;
+
+PROC apply (LABEL VAR label, BOOL CONST condition) :
+ IF condition xor invers THEN branch true (label)
+ ELSE branch false (label)
+ FI ;
+ invers := FALSE .
+
+condition xor invers :
+ IF condition THEN NOT invers
+ ELSE invers
+ FI
+ENDPROC apply ;
+
+OP := (LABEL VAR global label, local label) : (* EQUATE ! *)
+ EXTERNAL 10014
+ENDOP := ;
+
+TEXT PROC dump (LABEL CONST label) :
+ "LAB " + text (CONCR (label))
+ENDPROC dump ;
+
+PROC gosub (LABEL VAR label) :
+ EXTERNAL 10015
+ENDPROC gosub ;
+
+PROC goret :
+ s0 (q goret code)
+ENDPROC goret ;
+
+PROC branch true (LABEL VAR label) :
+ EXTERNAL 10028
+ENDPROC branch true ;
+
+PROC branch false (LABEL VAR label) :
+ EXTERNAL 10029
+ENDPROC branch false ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 3. Datenaddressen 21.03.1986 *)
+(* *)
+(* Definition des Datentyps ADDRESS *)
+(* *)
+(* Aufbau von Datenaddressen (Vercodung) *)
+(* Fortschalten und Ausrichten von Adressen *)
+(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE ADDRESS = STRUCT (INT kind, value) ;
+
+LET global = 0 ,
+ local = 1 ,
+ ref mask = 2 ,
+ global ref = 2 ,
+ local ref = 3 ,
+ module nr = 4 ,
+ immediate value = 5 ,
+
+ eumel0 stack offset = 4 ,
+ local address limit = 16 384 ,
+
+ illegal ref operation = "REF not allowed" ,
+ deref on non ref = "DEREF on non-ref address" ,
+ global ref not allowed = "GLOBAL REF not allowed" ,
+ unknown kind = "Unknown address kind" ,
+ address overflow = "Address Overflow" ,
+ illegal plus operation = "+ not allowed" ;
+
+ADDRESS VAR result addr;
+
+INT CONST ref length :: 2 ;
+
+OP := (ADDRESS VAR l, ADDRESS CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+ADDRESS OP GLOB (INT CONST address level) :
+ result addr.kind := global ;
+ result addr.value := address level ;
+ IF memory management mode = data allocation by user
+ THEN result addr.value INCR global address offset
+ FI ;
+ result addr
+ENDOP GLOB ;
+
+ADDRESS OP LOC (INT CONST address level) :
+ result addr.kind := local ;
+ result addr.value := address level + eumel0 stack offset ;
+ result addr
+ENDOP LOC ;
+
+ADDRESS OP REF (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ IF result addr.kind = local THEN result addr.kind INCR ref mask
+ ELIF result addr.kind = global THEN errorstop (global ref not allowed)
+ ELSE errorstop (illegal ref operation)
+ FI ;
+ result addr
+ENDOP REF ;
+
+ADDRESS OP DEREF (ADDRESS CONST ref address) :
+ CONCR (result addr) := CONCR (ref address) ;
+ IF is not local ref THEN errorstop (deref on non ref) FI ;
+ result addr.kind DECR ref mask ;
+ result addr .
+
+is not local ref :
+ result addr.kind <> local ref
+ENDOP DEREF ;
+
+INT OP REPR (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global :
+ CASE local : set bit (result addr.value, 15)
+ CASE global ref : errorstop (global ref not allowed)
+ CASE local ref : prep local ref
+ OTHERWISE errorstop (unknown kind)
+ ENDSELECT ;
+ result addr.value .
+
+prep local ref :
+ IF address limit exceeded THEN errorstop (address overflow) FI ;
+ set bit (result addr.value, 14) ;
+ set bit (result addr.value, 15) .
+
+address limit exceeded :
+ result addr.value < eumel0 stack offset OR
+ result addr.value > local address limit
+ENDOP REPR ;
+
+BOOL PROC is ref (ADDRESS CONST addr) :
+ addr.kind = local ref
+ENDPROC is ref ;
+
+BOOL PROC is global (ADDRESS CONST addr) :
+ addr.kind = global
+ENDPROC is global ;
+
+BOOL PROC is local (ADDRESS CONST addr) :
+ addr.kind = local
+ENDPROC is local ;
+
+ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global : inc global
+ CASE local : inc local
+ OTHERWISE errorstop (illegal plus operation)
+ ENDSELECT ;
+ result addr .
+
+inc global :
+ result addr.value INCR offset ;
+ IF result addr.value < 0 THEN errorstop (address overflow) FI .
+
+inc local :
+ result addr.value INCR offset ;
+ IF result addr.value < eumel 0 stack offset OR
+ result addr.value > local address limit
+ THEN errorstop (address overflow)
+ FI
+ENDOP + ;
+
+PROC adjust (ADDRESS VAR addr, INT CONST adjust length) :
+ IF is local or global THEN adjust to length FI .
+
+is local or global :
+ addr.kind <= local .
+
+adjust to length :
+ mode := addr.value MOD adjust length ;
+ IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI
+ENDPROC adjust ;
+
+TEXT PROC dump (ADDRESS CONST addr) :
+ kind + text (addr.value) .
+
+kind :
+ SELECT addr.kind OF
+ CASE global : "GLOBAL "
+ CASE local : "LOCAL "
+ CASE immediate value : "IMMEDIATE "
+ CASE module nr : "PARAM PROC "
+ CASE global ref : "GLOBAL REF "
+ CASE local ref : "LOCAL REF "
+ OTHERWISE "undef. Addr:"
+ ENDSELECT
+ENDPROC dump;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 4. Datentypen Teil I 03.12.1985 *)
+(* *)
+(* Definition des Datentyps DTYPE *)
+(* *)
+(* Interne Repraesentation der primitiven Datentypen *)
+(* Identifikation von DTYPEs *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE DTYPE = INT ;
+
+OP := (DTYPE VAR l, DTYPE CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+BOOL OP = (DTYPE CONST l, r) :
+ CONCR (l) = CONCR (r)
+ENDOP = ;
+
+DTYPE PROC void type : DTYPE :(void) ENDPROC void type ;
+
+DTYPE PROC int type : DTYPE :(int ) ENDPROC int type ;
+
+DTYPE PROC real type : DTYPE :(real) ENDPROC real type ;
+
+DTYPE PROC text type : DTYPE :(string) ENDPROC text type ;
+
+DTYPE PROC bool type : DTYPE :(bool) ENDPROC bool type ;
+
+DTYPE PROC dataspace type : DTYPE :(dataspace) ENDPROC dataspace type ;
+
+DTYPE PROC undefined type : DTYPE :(undefined) ENDPROC undefined type ;
+
+DTYPE PROC row type : DTYPE :(row) ENDPROC row type ;
+
+DTYPE PROC struct type : DTYPE :(struct) ENDPROC struct type ;
+
+DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ;
+
+DTYPE PROC end type : DTYPE :(end) ENDPROC end type ;
+
+INT PROC type class (DTYPE CONST type) :
+ SELECT type id OF
+ CASE int, real, bool, string, dataspace, undefined : 1
+ CASE void : 0
+ CASE row : 3
+ CASE struct : 4
+ CASE permanent param proc : 5
+ OTHERWISE pt type
+ ENDSELECT .
+
+pt type :
+ IF type id > ptt limit THEN permanent row or struct
+ ELSE abstract type
+ FI .
+
+abstract type : 2 .
+
+permanent row or struct :
+ mode := cdbint (type link into pt) MOD ptt limit ;
+ IF mode = struct THEN 4
+ ELIF mode = row THEN 3
+ ELSE 2
+ FI .
+
+type link into pt :
+ type id + begin of pt minus ptt limit .
+
+type id : CONCR (type)
+ENDPROC type class ;
+
+PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) :
+ SELECT type pos OF
+ CASE 1 : size := 0; align := 0; type id := void
+ CASE 6 : size := 1; align := 1; type id := int
+ CASE 10 : size := 4; align := 4; type id := real
+ CASE 15 : size := 8; align := 4; type id := string
+ CASE 20 : size := 1; align := 1; type id := bool
+ CASE 25 : size := 1; align := 1; type id := dataspace
+ OTHERWISE search for type in permanent table
+ ENDSELECT .
+
+type pos :
+ enclose in delimiters ;
+ pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) .
+
+enclose in delimiters :
+ object name := "." ;
+ object name CAT name ;
+ object name CAT "." .
+
+search for type in permanent table :
+ to object (name) ;
+ IF NOT found THEN size := 0; align := 0; type id := undefined
+ ELSE size := cdbint (permanent pointer + two wordlength) ;
+ type id := permanent pointer - begin of permanent table ;
+ IF size < two wordlength THEN align := 1
+ ELIF size < four wordlength THEN align := 2
+ ELSE align := 4
+ FI
+ FI .
+
+type id : CONCR (type)
+ENDPROC identify ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 5. Operationen Teil I 21.03.1986 *)
+(* *)
+(* Definition des Datentyps OPN *)
+(* Primitive Operationen (:= etc.) *)
+(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ;
+
+LET proc op = 0 ,
+ param proc = 1 ,
+ eumel 0 = 2 ,
+ nil = 3 ,
+
+ param proc at non ref = "PARAM PROC at non-ref address" ,
+ proc op expected = "PROC expected" ;
+
+OPN VAR eumel0 opn;
+eumel0 opn.kind := eumel0 ;
+eumel0 opn.top of stack := 0 ;
+
+eumel0 opn.mod nr := q pp ;
+OPN CONST pp :: eumel0 opn ,
+ nop code :: OPN :(nil, 0, 0) ;
+
+THESAURUS VAR eumel 0 opcodes :: empty thesaurus ;
+
+PROC init op codes (FILE VAR eumelcodes) :
+ eumel 0 opcodes := empty thesaurus ;
+ WHILE NOT eof (eumelcodes) REP
+ getline (eumelcodes, object name) ;
+ delete trailing blanks ;
+ IF object name <> "" CAND NOT (eumel 0 opcodes CONTAINS object name)
+ THEN insert (eumel 0 opcodes, object name)
+ FI
+ PER .
+
+delete trailing blanks :
+ WHILE (object name SUB LENGTH object name) = " " REP
+ object name := subtext (object name, 1, LENGTH object name - 1)
+ PER
+ENDPROC init op codes ;
+
+ADDRESS PROC address (OPN CONST opn) :
+ IF opn.kind <> proc op THEN errorstop (proc op expected) FI ;
+ result addr.kind := module nr ;
+ result addr.value := opn.mod nr ;
+ result addr
+ENDPROC address ;
+
+OPN PROC operation (ADDRESS CONST addr) :
+ IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ;
+ OPN VAR opn ;
+ opn.kind := param proc ;
+ opn.mod nr :=addr.value ;
+ opn.top of stack := 0 ;
+ opn
+ENDPROC operation ;
+
+TEXT PROC mnemonic (OPN CONST op code) :
+ name (eumel 0 opcodes, op code.mod nr)
+ENDPROC mnemonic ;
+
+OPN PROC nop :
+ nop code
+ENDPROC nop ;
+
+OP := (OPN VAR r, OPN CONST l) :
+ CONCR (r) := CONCR (l)
+ENDOP := ;
+
+BOOL PROC is proc (OPN CONST operation) :
+ operation.kind = proc op
+ENDPROC is proc ;
+
+BOOL PROC is eumel 0 instruction (TEXT CONST op code name) :
+ link (eumel 0 opcodes, op code name) <> 0
+ENDPROC is eumel 0 instruction ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 6. Parameterfeld 10.01.1986 *)
+(* *)
+(* Bereitstellen des Parameterfeldes *)
+(* Schreiben und Lesen von Eintraegen im Parameterfeld *)
+(* Fortschalten von Zeigern in das Parameterfeld *)
+(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access,
+ ADDRESS addr, OPN push opn) ,
+
+ size of param field = 100 ,
+ param field exceeded = "Param Field Overflow",
+ param nr out of range = "Illegal Param Number" ;
+
+ROW size of param field PARAMDESCRIPTOR VAR param field ;
+
+
+ (***** Schreiben *****)
+
+PROC test param pos (INT CONST param nr) :
+ IF param nr < 1 OR param nr > size of param field
+ THEN errorstop (param nr out of range)
+ FI
+ENDPROC test param pos ;
+
+PROC declare (INT CONST param nr, DTYPE CONST type) :
+ test param pos (param nr) ;
+ enter type .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type)
+ENDPROC declare ;
+
+PROC declare (INT CONST param nr, access) :
+ test param pos (param nr) ;
+ enter access .
+
+enter access :
+ param field [param nr].access := access
+ENDPROC declare ;
+
+PROC define (INT CONST param nr, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter address .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr)
+ENDPROC define ;
+
+PROC define (INT CONST param nr, value) :
+ result addr.kind := immediate value ;
+ result addr.value := value ;
+ define (param nr, result addr)
+ENDPROC define ;
+
+PROC apply (INT CONST param nr, OPN CONST opn) :
+ test param pos (param nr) ;
+ enter push opn .
+
+enter push opn :
+ CONCR (param field [param nr].push opn) := CONCR (opn)
+ENDPROC apply ;
+
+PROC parameter (INT CONST param nr, DTYPE CONST type,
+ INT CONST access, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter type ;
+ enter access ;
+ enter address ;
+ enter pp as default .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type) .
+
+enter access :
+ param field [param nr].access := access .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr) .
+
+enter pp as default :
+ CONCR (param field [param nr].push opn) := CONCR (pp)
+ENDPROC parameter ;
+
+
+ (***** Lesen *****)
+
+ADDRESS PROC param address (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].addr
+ENDPROC param address ;
+
+DTYPE PROC dtype (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].type
+ENDPROC dtype ;
+
+INT PROC access (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].access
+ENDPROC access ;
+
+
+ (***** Fortschalten *****)
+
+OP NEXTPARAM (INT VAR param nr) :
+ test param pos (param nr) ;
+ IF long entry THEN read until end FI ;
+ param nr INCR 1 .
+
+long entry :
+ type class (param field [param nr].type) > 2 .
+
+read until end :
+ REP
+ param nr INCR 1 ;
+ NEXTPARAM param nr
+ UNTIL end marker read or end of field PER .
+
+end marker read or end of field :
+ param nr > size of param field OR
+ CONCR (param field [param nr].type) = end
+ENDOP NEXTPARAM ;
+
+INT PROC next param (INT CONST p) :
+ index := p ;
+ NEXTPARAM index ;
+ index
+ENDPROC next param ;
+
+TEXT PROC dump (INT CONST p) :
+ IF p > 0 AND p <= 100 THEN dump entry (param field (p))
+ ELSE param nr out of range
+ FI
+ENDPROC dump ;
+
+TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) :
+ object name := dump (id.type) ;
+ object name CAT text (id.access) ;
+ object name CAT dump (id.addr) ;
+ object name CAT dump (id.push opn) ;
+ object name
+ENDPROC dump entry ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 7. Datentypen Teil II 20.01.1986 *)
+(* *)
+(* Deklaration neuer Datentypen *)
+(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+
+DTYPE VAR pt type ;
+
+PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) :
+ entry into name table ;
+ put next permanent (permanent type) ;
+ put next permanent (size) ;
+ put next permanent (nt link) ;
+ mark no offsets of text elements .
+
+entry into name table :
+ declare object (name, nt link, CONCR (type)) .
+
+mark no offsets of text elements :
+ put next permanent (0)
+ENDPROC declare ;
+
+BOOL PROC same type (INT CONST param 1, param 2) :
+ INT CONST left type :: CONCR (param field [param 1].type) ;
+ IF left type = right type
+ THEN same fine structure if there is one
+ ELSE left type = undefined OR right type = undefined
+ FI .
+
+right type : CONCR (param field [param 2].type) .
+
+same fine structure if there is one :
+ IF left type = row THEN compare row
+ ELIF left type = struct THEN compare struct
+ ELSE TRUE
+ FI .
+
+compare row :
+ equal sizes AND same type (param1 + 1, param2 + 1) .
+
+equal sizes :
+ param field [param1+1].access = param field [param2+1].access .
+
+compare struct :
+ INT VAR p1 :: param1+1, p2 :: param2+1 ;
+ REP
+ IF NOT same type (p1, p2) THEN LEAVE same type WITH FALSE
+ ELIF end type found THEN LEAVE same type WITH TRUE
+ FI ;
+ NEXTPARAM p1 ;
+ NEXTPARAM p2
+ UNTIL end of field PER ;
+ FALSE .
+
+end type found :
+ CONCR (param field [p1].type) = end .
+
+end of field :
+ p1 > size of param field OR p2 > size of param field
+ENDPROC same type ;
+
+BOOL PROC same type (INT CONST param nr, DTYPE CONST type) :
+ field pointer := param nr ;
+ CONCR (pt type) := CONCR (type) ;
+ equal types
+ENDPROC same type ;
+
+BOOL PROC equal types :
+ identical types OR one type is undefined .
+
+one type is undefined :
+ type of actual field = undefined OR CONCR(pt type) = undefined .
+
+identical types :
+ SELECT type class (pt type) OF
+ CASE 0, 1, 2 : type of actual field = CONCR (pt type)
+ CASE 3 : perhaps equal rows
+ CASE 4 : perhaps equal structs
+ OTHERWISE FALSE
+ ENDSELECT .
+
+perhaps equal rows :
+ is row AND equal row sizes AND equal row types .
+
+is row :
+ type of actual field = row .
+
+perhaps equal structs :
+ is struct AND same type fields .
+
+is struct :
+ type of actual field = struct .
+
+equal row sizes :
+ pt row size = row size within param field .
+
+equal row types :
+ same type (field pointer + 1, pt row type) .
+
+pt row size :
+ cdb int (CONCR(pt type) + offset to row size) .
+
+pt row type :
+ CONCR (pt type) INCR 2 ;
+ pt type .
+
+row size within param field :
+ param field [field pointer].access .
+
+same type fields :
+ field pointer INCR 1 ;
+ CONCR (pt type) INCR 1 ;
+ REP
+ IF NOT equal types THEN LEAVE same type fields WITH FALSE FI ;
+ IF type of actual field = end
+ THEN LEAVE same type fields WITH TRUE
+ FI ;
+ NEXTPARAM field pointer
+ UNTIL end of field PER ;
+ FALSE .
+
+end of field :
+ field pointer > size of param field .
+
+type of actual field :
+ CONCR (param field [field pointer].type) .
+ENDPROC equal types ;
+
+BOOL PROC is not void bool or undefined (DTYPE CONST dtype) :
+ type <> void AND type <> bool AND type <> undefined .
+
+type : CONCR (dtype)
+ENDPROC is not void bool or undefined ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 8. Operationen Teil II 07.03.1986 *)
+(* *)
+(* Definition der Opcodes *)
+(* Deklaration, Definition, Identifikation und Applikation *)
+(* Eroeffnen und Schliessen eines Moduls *)
+(* *)
+(**************************************************************************)
+
+
+
+LET module not opened = "Module not opened" ,
+ define missing = "DEFINE missing" ,
+ wrong nr of params = "Wrong Nr. of Params:" ,
+ illegal kind = "Opcode expected" ,
+ nested module = "Nested Modules" ,
+ no mod nr = "Param Proc expected" ,
+ no immediate value = "Value expected" ,
+ type error = "Type Error" ,
+
+ q ln = 1 ,
+ q move = 2 , q move code = 2 048 ,
+ q inc1 = 3 , q inc1 code = 3 072 ,
+ q dec1 = 4 , q dec1 code = 4 096 ,
+ q inc = 5 , q inc code = 5 120 ,
+ q dec = 6 , q dec code = 6 144 ,
+ q add = 7 , q add code = 7 168 ,
+ q sub = 8 , q sub code = 8 192 ,
+ q clear = 9 , q clear code = 9 216 ,
+ q test = 10 ,
+ q equ = 11 , q equ code = 11 264 ,
+ q lsequ = 12 , q lsequ code = 12 288 ,
+ q fmove = 13 , q fmove code = 13 312 ,
+ q fadd = 14 , q fadd code = 14 336 ,
+ q fsub = 15 , q fsub code = 15 360 ,
+ q fmult = 16 , q fmult code = 16 384 ,
+ q fdiv = 17 , q fdiv code = 17 408 ,
+ q flsequ = 18 , q flsequ code = 18 432 ,
+ q tmove = 19 , q tmove code = 19 456 ,
+ q tequ = 20 , q tequ code = 20 480 ,
+ q accds = 21 , q access ds code = 22 528 ,
+ q ref = 22 , q ref code = 23 552 ,
+ q subscript = 23 , q subscript code = 24 576 ,
+ q select = 24 , q select code = 25 600 ,
+ q ppv = 25 ,
+ q pp = 26 ,
+ q make false = 27 , (* q make false code = 65 513 *)
+ q movex = 28 ,
+(* q longa subs q longa subs code = 65 376 *)
+ q return = 29 , q return code = 32 512 ,
+ q true return = 30 , q true return code = 32 513 ,
+ q false return = 31 , q false return code = 32 514 ,
+ q goret code = 32 519 ,
+ q esc mult = 32 , q esc mult code = 32 553 ,
+ q esc div = 33 , q esc div code = 32 554 ,
+ q esc mod = 34 , q esc mod code = 32 555 ,
+ q pproc = 35 ,
+ q compl int = 36 , q compl int code = 32 551 ,
+ q compl real = 37 , q compl real code = 32 550 ,
+(* q alias ds = 38 , *)
+ q movim = 39 , q esc movim code = 32 547 ,
+ q fequ = 40 , q fequ code = 32 548 ,
+ q tlsequ = 41 , q tlsequ code = 32 549 ,
+(* q case = 42 , *)
+ q plus = 43 ,
+ q minus = 44 ,
+ q mult = 45 ,
+ q int div = 46 ,
+ q real div = 47 ,
+ q equal = 48 ,
+ q lessequal = 49 ;
+
+INT CONST q make false code :: - 1 022 ,
+ q longa subs code :: - 159 ;
+
+
+ (***** Deklaration *****)
+
+PROC declare (OPN VAR operation) :
+ operation.kind := proc op ;
+ get module nr (operation.mod nr) ;
+ operation.top of stack := 0
+ENDPROC declare ;
+
+PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) :
+ declare (operation) ;
+ entry into name and pt table if necessary ;
+ enter params ;
+ enter result ;
+ enter module number .
+
+entry into name and pt table if necessary :
+ declare object (name, nt link, permanent pointer) .
+
+enter params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO params REP
+ enter param (param field [field pointer]) ;
+ NEXTPARAM field pointer
+ PER .
+
+enter result :
+ enter param (param field[field pointer].type, permanent proc op) .
+
+enter module number :
+ put next permanent (operation.mod nr)
+ENDPROC declare ;
+
+PROC enter param (PARAMDESCRIPTOR CONST param) :
+ IF param.access = const
+ THEN enter param (param.type, permanent param const)
+ ELIF param.access = var
+ THEN enter param (param.type, permanent param var)
+ ELSE errorstop ("Unknown Access")
+ FI
+ENDPROC enter param ;
+
+PROC enter param (DTYPE CONST type, INT CONST permanent mode) :
+ SELECT type class (type) OF
+ CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode)
+ OTHERWISE errorstop ("Illegal Type")
+ ENDSELECT
+ENDPROC enter param ;
+
+
+ (***** Definition *****)
+
+PROC define (OPN VAR opn) :
+ IF NOT module open THEN errorstop (module not opened)
+ ELSE proc head (opn.mod nr, opn.top of stack)
+ FI
+ENDPROC define ;
+
+PROC set length of local storage (OPN VAR opn, INT CONST size) :
+ IF size < 0 OR size > local address limit
+ THEN errorstop (address overflow)
+ ELIF opn.top of stack = 0
+ THEN errorstop (define missing)
+ ELIF opn.kind <> proc op
+ THEN errorstop (proc op expected)
+ FI ;
+ set length (opn.top of stack, size + eumel0 stack offset)
+ENDPROC set length of local storage ;
+
+PROC define (OPN VAR operation, INT CONST size) :
+ define (operation) ;
+ set length of local storage (operation, size)
+ENDPROC define ;
+
+
+ (***** Identifikation *****)
+
+INT VAR counter, result index, result type repr;
+
+PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation,
+ BOOL VAR object exists) :
+ find result entry ;
+ to object (name) ;
+ IF found THEN first fit and leave if found FI ;
+ IF eumel0 THEN identify eumel0 instruction
+ ELSE yield undefined operation
+ FI .
+
+find result entry :
+ result index := first;
+ counter := 0 ;
+ WHILE counter < params REP
+ NEXTPARAM result index ;
+ counter INCR 1
+ PER ;
+ check on param field exceeded .
+
+check on param field exceeded :
+ IF result index > size of param field
+ THEN errorstop (param field exceeded)
+ FI .
+
+yield undefined operation :
+ declare (result index, undefined type) ;
+ apply (result index, nop) ;
+ object exists := FALSE .
+
+first fit and leave if found :
+ WHILE yet another procedure exists REP
+ check one procedure and leave if match ;
+ next procedure
+ PER .
+
+yet another procedure exists :
+ permanent pointer <> 0 .
+
+check one procedure and leave if match:
+ param link := permanent pointer + wordlength ;
+ set end marker if end of list ;
+ counter := params ;
+ field pointer := 1 ;
+ REP
+ IF end of params AND counter = 0
+ THEN procedure found
+ ELIF end of params OR counter = 0
+ THEN LEAVE check one procedure and leave if match
+ ELSE check next param
+ FI
+ PER .
+
+check next param :
+ get type and mode (CONCR(pt type)) ;
+ IF same types THEN set param mode ;
+ counter DECR 1 ;
+ field pointer INCR 1 ;
+ next pt param
+ ELSE LEAVE check one procedure and leave if match
+ FI .
+
+same types : (* inline version ! *)
+ equal types .
+
+set param mode :
+ param field [field pointer].access := mode .
+
+procedure found :
+ get result ;
+ operation.kind := proc op ;
+ operation.mod nr := module number ;
+ operation.top of stack := 0 ;
+ object exists := TRUE ;
+ LEAVE identify .
+
+get result :
+ get type and mode (result type) ;
+ declare (result index, mode) .
+
+module number :
+ cdbint (param link + 1) .
+
+result type :
+ CONCR (param field [result index].type) .
+
+eumel0 :
+ eumel0 opn.mod nr := link (eumel 0 opcodes, name) ;
+ eumel0 opn.mod nr <> 0 .
+
+identify eumel 0 instruction :
+ init result type with void ;
+ CONCR (operation) := CONCR (eumel0 opn) ;
+ object exists := check params and set result ;
+ declare (result index, DTYPE:(result type repr)) ;
+ declare (result index, const) .
+
+init result type with void :
+ result type repr := void .
+
+check params and set result :
+ SELECT operation.mod nr OF
+ CASE q return, q false return, q true return : no params
+ CASE q inc1, q dec1 : one int param yielding void
+ CASE q pproc, q pp, q ln : one param yielding void
+ CASE q test : one param yielding bool
+ CASE q clear, q ppv : one int or bool param yielding void
+ CASE q make false : one bool param yielding void
+ CASE q move : two int or bool params yielding void
+ CASE q compl int, q inc, q dec : two int params yielding void
+ CASE q compl real, q fmove : two real params yielding void
+ CASE q equ, q lsequ : two int params yielding bool
+ CASE q fequ, q flsequ : two real params yielding bool
+ CASE q tequ, q tlsequ : two text params yielding bool
+ CASE q tmove : two text params yielding void
+ CASE q accds, q ref : two params yielding void
+ CASE q add, q sub, q esc mult,
+ q esc div, q esc mod : three int params yielding void
+ CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void
+ CASE q select, q movex : three params
+ CASE q subscript : five params
+ CASE q plus, q minus, q mult : two intreals yielding intreal
+ CASE q int div : two int params yielding int
+ CASE q real div : two real params yielding real
+ CASE q equal, q lessequal : two intrealtexts yielding bool
+ OTHERWISE FALSE
+ ENDSELECT .
+
+no params :
+ params = 0 .
+
+one int param yielding void :
+ p1 void (int type, first, params) .
+
+one param yielding void :
+ params = 1 .
+
+one param yielding bool :
+ IF params = 1 THEN result type repr := bool ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+one int or bool param yielding void :
+ p1 void (int type, first, params) OR p1 void (bool type, first, params) .
+
+one bool param yielding void :
+ p1 void (bool type, first, params) .
+
+two int or bool params yielding void :
+ p2 (int type, first, params, void) OR
+ p2 (bool type, first, params, void) .
+
+two int params yielding void :
+ p2 (int type, first, params, void) .
+
+two real params yielding void :
+ p2 (real type, first, params, void) .
+
+two text params yielding void :
+ p2 (text type, first, params, void) .
+
+two int params yielding bool :
+ p2 (int type, first, params, bool) .
+
+two real params yielding bool :
+ p2 (real type, first, params, bool) .
+
+two text params yielding bool :
+ p2 (text type, first, params, bool) .
+
+two params yielding void :
+ params = 2 .
+
+three int params yielding void :
+ p3 void (int type, first, params) .
+
+three real params yielding void :
+ p3 void (real type, first, params) .
+
+three params :
+ params = 3 .
+
+five params :
+ params = 5 .
+
+two intreals yielding intreal :
+ two int params yielding int OR two real params yielding real .
+
+two intrealtexts yielding bool :
+ two int params yielding bool OR two real params yielding bool OR
+ two text params yielding bool .
+
+two int params yielding int :
+ p2 (int type, first, params, int) .
+
+two real params yielding real :
+ p2 (real type, first, params, real)
+ENDPROC identify ;
+
+BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 1 AND param type is requested plain type .
+
+param type is requested plain type :
+ CONCR (param field [first].type) = CONCR (requested type)
+
+ENDPROC p1 void ;
+
+BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr,
+ INT CONST result type) :
+ IF param nr = 2 AND param types equal requested plain type
+ THEN result type repr := result type ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+param types equal requested plain type :
+ CONCR (param field [first] .type) = CONCR (requested type) AND
+ CONCR (param field [first+1].type) = CONCR (requested type)
+
+ENDPROC p2 ;
+
+BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 3 AND param types ok .
+
+param types ok :
+ FOR index FROM first UPTO first+2 REP
+ IF different param types THEN LEAVE p3 void WITH FALSE FI
+ PER ;
+ TRUE .
+
+different param types :
+ CONCR (param field [index].type) <> CONCR (requested type)
+ENDPROC p3 void;
+
+
+ (***** Applikation *****)
+
+INT VAR address representation, left repr, right repr, result repr;
+
+PROC apply (INT CONST first, nr of params, OPN CONST opn) :
+ IF NOT module open THEN errorstop (module not opened) FI ;
+ SELECT opn.kind OF
+ CASE eumel 0 : generate eumel0 instruction
+ CASE proc op : call operation
+ CASE param proc : call param proc
+ CASE nil :
+ OTHERWISE errorstop (illegal kind)
+ ENDSELECT .
+
+call operation :
+ push params if necessary (first, nr of params, opn.mod nr) ;
+ call (opn.mod nr) .
+
+call param proc :
+ result addr.kind := local ref ;
+ result addr.value := opn.mod nr ;
+ address representation := REPR result addr ;
+ push params if necessary (first, nr of params, address representation) ;
+ call param (address representation) .
+
+generate eumel0 instruction :
+ SELECT real nr of params OF
+ CASE 0 : p0 instruction
+ CASE 1 : apply p1 (opn, first addr)
+ CASE 2 : apply p2 (opn, first addr, second addr)
+ CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr)
+ CASE 5 : subscript operation
+ OTHERWISE errorstop (wrong nr of params + text (nr of params))
+ ENDSELECT .
+
+real nr of params :
+ IF operator denotation THEN nr of params + 1
+ ELSE nr of params
+ FI .
+
+operator denotation :
+ opn.mod nr >= q plus .
+
+p0 instruction :
+ IF opn.mod nr = q return THEN s0 (q return code)
+ ELIF opn.mod nr = q true return THEN s0 (q true return code)
+ ELIF opn.mod nr = q false return THEN s0 (q false return code)
+ ELSE errorstop (wrong nr of params +
+ mnemonic (opn))
+ FI .
+
+subscript operation :
+ IF opn.mod nr = q subscript
+ THEN subscription
+ ELSE errorstop (wrong nr of params + text (nr of params))
+ FI .
+
+subscription :
+ ADDRESS CONST element length :: param field [first+2].addr ,
+ limit :: param field [first+3].addr ;
+ check on immediates ;
+ IF element length.value < 1024
+ THEN s0 (q subscript code + element length.value)
+ ELSE s0 (q longa subs code) ;
+ s0 (element length.value)
+ FI ;
+ s3 (limit.value - 1, subs index, base addr, subs result) .
+
+check on immediates :
+ IF element length.kind <> immediate value OR
+ limit.kind <> immediate value
+ THEN errorstop (no immediate value)
+ FI .
+
+subs index : REPR param field [first+1].addr .
+
+base addr : REPR param field [first].addr .
+
+subs result : REPR param field [first+4].addr .
+
+first addr :
+ param field [first].addr .
+
+left type :
+ param field [first].type .
+
+second addr :
+ param field [nextparam (first)].addr .
+
+third addr :
+ param field [nextparam(nextparam(first))].addr
+ENDPROC apply ;
+
+PROC push params if necessary (INT CONST first, nr of params, mod nr) :
+ init param push (mod nr) ;
+ IF nr of params > 0 THEN push params ;
+ push result if there is one
+ FI .
+
+push params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO nr of params REP
+ apply p1 (push code, param addr) ;
+ NEXTPARAM field pointer
+ PER .
+
+push code :
+ param field [field pointer].push opn .
+
+param addr :
+ param field [field pointer].addr .
+
+push result if there is one :
+ IF push result necessary
+ THEN push result address (REPR param field [field pointer].addr)
+ FI .
+
+push result necessary :
+ param field [field pointer].push opn.kind <> nil AND
+ is not void bool or undefined (param field [field pointer].type)
+ENDPROC push params if necessary ;
+
+PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) :
+ IF opn.mod nr = q ln THEN generate line number
+ ELIF opn.mod nr = q pproc THEN push module nr
+ ELSE gen p1 instruction
+ FI .
+
+gen p1 instruction :
+ address representation := REPR addr ;
+ SELECT opn.mod nr OF
+ CASE q inc1 : t1 (q inc1 code, address representation)
+ CASE q dec1 : t1 (q dec1 code, address representation)
+ CASE q clear : t1 (q clear code,address representation)
+ CASE q test : test bool object (address representation)
+ CASE q pp : push param (address representation)
+ CASE q make false : s1 (q make false code, address representation)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+generate line number :
+ IF addr.kind = immediate value THEN mark line (addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+push module nr :
+ IF addr.kind = module nr THEN push param proc (addr.value)
+ ELSE errorstop (no mod nr)
+ FI
+ENDPROC apply p1;
+
+PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr):
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movim THEN move immediate
+ ELSE gen p2 instruction
+ FI .
+
+gen p2 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q move : t2 (q move code, right repr, left repr)
+ CASE q inc : t2 (q inc code, right repr, left repr)
+ CASE q dec : t2 (q dec code, right repr, left repr)
+ CASE q equ : compare (q equ code, left repr, right repr)
+ CASE q lsequ : compare (q lsequ code, left repr, right repr)
+ CASE q fmove : t2 (q fmove code, right repr, left repr)
+ CASE q flsequ : compare (q flsequ code, left repr, right repr)
+ CASE q tmove : t2 (q tmove code, right repr, left repr)
+ CASE q tequ : compare (q tequ code, left repr, right repr)
+ CASE q compl int : s2 (q compl int code, left repr, right repr)
+ CASE q compl real : s2 (q compl real code, left repr, right repr)
+ CASE q fequ : compare (q fequ code, left repr, right repr)
+ CASE q tlsequ : compare (q tlsequ code, left repr, right repr)
+ CASE q accds : t2 (q access ds code, left repr, right repr)
+ CASE q ref : t2 (q ref code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+move immediate :
+ IF right addr.kind = immediate value
+ THEN s0 (q esc movim code) ;
+ s1 (left repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI
+ENDPROC apply p2;
+
+PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype,
+ ADDRESS CONST left addr, right addr, result addr ):
+ left repr := REPR left addr ;
+ result repr := REPR result addr ;
+ IF opn.mod nr = q select THEN gen select instruction
+ ELIF opn.mod nr = q movex THEN gen long move
+ ELSE gen p3 instruction
+ FI .
+
+gen p3 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q add : int add
+ CASE q sub : int sub
+ CASE q fadd : real add
+ CASE q fsub : real sub
+ CASE q fmult : real mult
+ CASE q fdiv, q real div : real div
+ CASE q esc mult : int mult
+ CASE q esc div, q int div : int div
+ CASE q esc mod : int mod
+ CASE q plus : int real add
+ CASE q minus : int real sub
+ CASE q mult : int real mult
+ CASE q equal, q lessequal : compare (comp code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+gen select instruction :
+ IF right addr.kind = immediate value
+ THEN t1 (q select code, left repr) ;
+ s1 (right addr.value, result repr)
+ ELSE errorstop (no immediate value)
+ FI .
+
+gen long move :
+ IF right addr.kind = immediate value
+ THEN long move (left repr, result repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+int add : compute (q add code, left repr, right repr, result repr) .
+
+int sub : compute (q sub code, left repr, right repr, result repr) .
+
+real add : compute (q fadd code, left repr, right repr, result repr) .
+
+real sub : compute (q fsub code, left repr, right repr, result repr) .
+
+real mult : compute (q fmult code, left repr, right repr, result repr) .
+
+real div : compute (q fdiv code, left repr, right repr, result repr) .
+
+int mult : s3 (q esc mult code, left repr, right repr, result repr) .
+
+int div : s3 (q esc div code, left repr, right repr, result repr) .
+
+int mod : s3 (q esc mod code, left repr, right repr, result repr) .
+
+int real add :
+ IF left type = int THEN int add
+ ELSE real add
+ FI .
+
+int real sub :
+ IF left type = int THEN int sub
+ ELSE real sub
+ FI .
+
+int real mult :
+ IF left type = int THEN int mult
+ ELSE real mult
+ FI .
+
+comp code :
+ SELECT left type OF
+ CASE int : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI
+ CASE real : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI
+ CASE string : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI
+ OTHERWISE errorstop (type error); q equ
+ ENDSELECT .
+
+left type : CONCR (left dtype)
+
+ENDPROC apply p3;
+
+
+ (***** Modul *****)
+
+BOOL VAR module open ;
+
+.init opn section :
+ module open := FALSE .;
+
+PROC begin module :
+ IF module open THEN errorstop (nested module)
+ ELSE begin modul ;
+ module open := TRUE
+ FI
+ENDPROC begin module ;
+
+PROC end module :
+ IF NOT module open
+ THEN errorstop (module not opened)
+ ELSE end modul ;
+ module open := FALSE
+ FI
+ENDPROC end module ;
+
+TEXT PROC dump (OPN CONST operation) :
+ IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5)
+ ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation)
+ ELSE " undef. Opn"
+ FI
+ENDPROC dump ;
+
+PROC begin modul :
+ EXTERNAL 10071
+ENDPROC begin modul ;
+
+PROC end modul :
+ EXTERNAL 10011
+ENDPROC end modul ;
+
+PROC proc head (INT VAR mod nr, top of stack) :
+ EXTERNAL 10012
+ENDPROC proc head ;
+
+PROC set length (INT CONST top of stack, size) :
+ EXTERNAL 10013
+ENDPROC set length ;
+
+PROC get module nr (INT VAR module nr) :
+ EXTERNAL 10016
+ENDPROC get module nr ;
+
+PROC compute (INT CONST op code, l addr, r addr, result address) :
+ EXTERNAL 10017
+ENDPROC compute ;
+
+PROC compare (INT CONST op code, l addr, r addr) :
+ EXTERNAL 10018
+ENDPROC compare ;
+
+PROC long move (INT CONST to, from, length) :
+ EXTERNAL 10019
+ENDPROC long move ;
+
+PROC put next permanent (INT CONST permanent value) :
+ EXTERNAL 10020
+ENDPROC put next permanent ;
+
+PROC call (INT CONST mod nr) :
+ EXTERNAL 10022
+ENDPROC call ;
+
+PROC call param (INT CONST mod nr) :
+ EXTERNAL 10023
+ENDPROC call param ;
+
+PROC push param (INT CONST addr) :
+ EXTERNAL 10024
+ENDPROC push param ;
+
+PROC push param proc (INT CONST mod nr) :
+ EXTERNAL 10025
+ENDPROC push param proc ;
+
+PROC init param push (INT CONST mod nr) :
+ EXTERNAL 10026
+ENDPROC init param push ;
+
+PROC push result address (INT CONST addr) :
+ EXTERNAL 10027
+ENDPROC push result address ;
+
+PROC test bool object (INT CONST addr) :
+ EXTERNAL 10186
+ENDPROC test bool object ;
+
+PROC mark line (INT CONST line number) :
+ EXTERNAL 10030
+ENDPROC mark line ;
+
+PROC s0 (INT CONST op code) :
+ EXTERNAL 10038
+ENDPROC s0 ;
+
+PROC s1 (INT CONST op code, addr) :
+ EXTERNAL 10039
+ENDPROC s1 ;
+
+PROC s2 (INT CONST op code , addr1, addr2) :
+ EXTERNAL 10040
+ENDPROC s2 ;
+
+PROC s3 (INT CONST op code, addr1, addr2, addr3) :
+ EXTERNAL 10041
+ENDPROC s3 ;
+
+PROC t1 (INT CONST op code, addr) :
+ EXTERNAL 10042
+ENDPROC t1 ;
+
+PROC t2 (INT CONST op code, addr1, addr2) :
+ EXTERNAL 10043
+ENDPROC t2 ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 9. Speicherverwaltung 21.03.1986 *)
+(* *)
+(* Ablage der Paketdaten *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR address value;
+
+INT CONST data allocation by coder := 1 ,
+ data allocation by user := 2 ;
+
+LET not initialized = 0 ,
+ wrong mm mode = "Wrong MM Mode" ,
+ define on non global = "Define for GLOB only" ,
+ text too long = "TEXT too long" ;
+
+TEXT VAR const buffer :: point line ;
+
+.reset memory management mode :
+ memory management mode := not initialized . ;
+
+PROC reserve storage (INT CONST size) :
+ IF memory management mode <> data allocation by user
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (address value, size) ;
+ memory management mode := not initialized
+ENDPROC reserve storage ;
+
+PROC allocate variable (ADDRESS VAR addr, INT CONST size) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (addr.value, size) ;
+ addr.kind := global
+ENDPROC allocate variable ;
+
+PROC allocate denoter (ADDRESS VAR addr, INT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate int denoter (addr.value) ;
+ put data word (value, addr.value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate real denoter (addr.value) ;
+ addr.kind := global ;
+ define (addr, value)
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ;
+ addr.kind := global ;
+ skip heaplink;
+ define (addr, value) ;
+ reset heaplink .
+
+skip heaplink :
+ addr.value INCR 1 .
+
+reset heaplink :
+ addr.value DECR 1
+ENDPROC allocate denoter ;
+
+PROC define (ADDRESS CONST addr, INT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value, addr.value)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, REAL CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ replace (const buffer, 1, value) ;
+ address value := addr.value ;
+ FOR index FROM 1 UPTO 4 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, TEXT CONST value) :
+ IF addr.kind <> global THEN errorstop (define on non global)
+ ELIF LENGTH value > 255 THEN errorstop (text too long)
+ FI ;
+ address value := addr.value ;
+ const buffer := code (LENGTH value) ;
+ const buffer CAT value ;
+ const buffer CAT " " ;
+ FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER ;
+ const buffer := point line
+ENDPROC define ;
+
+PROC prep pbase (INT VAR offset) :
+ EXTERNAL 10032
+ENDPROC prep pbase;
+
+PROC allocate var (INT VAR addr, INT CONST length) :
+ EXTERNAL 10033
+ENDPROC allocate var ;
+
+PROC allocate int denoter (INT VAR addr) :
+ EXTERNAL 10034
+ENDPROC allocate int denoter ;
+
+PROC allocate real denoter (INT VAR addr) :
+ EXTERNAL 10035
+ENDPROC allocate real denoter ;
+
+PROC allocate text denoter (INT VAR addr, INT CONST length) :
+ EXTERNAL 10036
+ENDPROC allocate text denoter ;
+
+PROC put data word (INT CONST value, INT CONST addr) :
+ EXTERNAL 10037
+ENDPROC put data word ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 08.01.1986 *)
+(* *)
+(**************************************************************************)
+
+TEXT VAR type and mode ;
+
+TEXT PROC type name (DTYPE CONST type) :
+ type and mode := "" ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC type name ;
+
+TEXT PROC dump (DTYPE CONST type) :
+ type and mode := "TYPE " ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC dump ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DATASPACE"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+ENDPACKET eumel coder ;
diff --git a/system/eumel-coder/1.8.0/src/eumel0 codes b/system/eumel-coder/1.8.0/src/eumel0 codes new file mode 100644 index 0000000..428f71e --- /dev/null +++ b/system/eumel-coder/1.8.0/src/eumel0 codes @@ -0,0 +1,50 @@ +LN
+MOVE
+INC1
+DEC1
+INC
+DEC
+ADD
+SUB
+CLEAR
+TEST
+EQU
+LSEQU
+FMOVE
+FADD
+FSUB
+FMULT
+FDIV
+FLSEQU
+TMOVE
+TEQU
+ACCDS
+REF
+SUBSCRIPT
+SELECT
+PPV
+PP
+MAKE_FALSE
+MOVEX
+RETURN
+TRUE_RETURN
+FALSE_RETURN
+ESC_MULT
+ESC_DIV
+ESC_MOD
+PPROC
+COMPL_INT
+COMPL_REAL
+ALIAS_DS
+MOVIM
+FEQU
+TLSEQU
+CASE
++
+-
+*
+DIV
+/
+=
+<=
+
diff --git a/system/eumel-coder/1.8.1/source-disk b/system/eumel-coder/1.8.1/source-disk new file mode 100644 index 0000000..972580b --- /dev/null +++ b/system/eumel-coder/1.8.1/source-disk @@ -0,0 +1 @@ +debug/eumel-coder-1.8.1.img diff --git a/system/eumel-coder/1.8.1/src/eumel coder 1.8.1 b/system/eumel-coder/1.8.1/src/eumel coder 1.8.1 new file mode 100644 index 0000000..0047067 --- /dev/null +++ b/system/eumel-coder/1.8.1/src/eumel coder 1.8.1 @@ -0,0 +1,3086 @@ +PACKET eumel coder (* Autor: U. Bartling *) + DEFINES coder on, coder off, + declare, define, apply, identify, + :=, =, + dump, + + LIB, + + LABEL, + gosub, goret, + computed branch, + complement condition code, + + ADDRESS , + GLOB, LOC, REF, DEREF, + ref length, + +, + adjust, + get base, + is global, is local, is ref, + + DTYPE, + type class, type name, + void type, int type, real type, text type, bool type, + bool result type, dataspace type, undefined type, + row type, struct type, proc type, end type, + + OPN, + set length of local storage, + begin module, end module, + is proc, is eumel 0 instruction, + address, operation, + nop, + mnemonic, + + parameter, + next param, + NEXTPARAM, + access , + dtype , + param address, + same type , + + reserve storage, + allocate denoter , + allocate variable, + data allocation by coder , + data allocation by user, + + run, run again, + insert, + prot, prot off, + check, check on, check off, + + help, bulletin, packets, + +(**************************************************************************) +(* *) +(* E U M E L - C O D E R *) +(* *) +(* *) +(* Zur Beschreibung des Coders siehe *) +(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *) +(* *) +(* Stand der Dokumentation : 29.10.1986 *) +(* Stand der Implementation : 03.09.1986 *) +(* *) +(* *) +(**************************************************************************) + +#page# +(**************************************************************************) +(* *) +(* 0. Datentyp DINT 03.09.1987 *) +(* *) +(* Definition des Datentyps *) +(* arithmetischer Operationen *) +(* und Konvertierungsprozeduren *) +(* *) +(**************************************************************************) + + + DINT, + -, *, DIV, MOD, <, <=, + AND, OR, XOR, + dput, dget, dmov, + ddec1, dinc1, dinc, ddec, + dadd, dsub, + dequ, dlseq, + INCR, DECR, + put, get, cout, + text, real, int, dint, + replace, DSUB : + + +TYPE DINT = STRUCT (INT low, high) ; + + +REAL VAR real value ; (* auch fuer Ausrichtung ! *) +TEXT VAR convertion buffer ; + +DINT CONST dint0 :: dint(0) ; +DINT VAR result :: dint 0 ; + + +DINT PROC dint (INT CONST number) : + EXTERNAL 144 +ENDPROC dint ; + +INT PROC int (DINT CONST i) : + EXTERNAL 143 +ENDPROC int; + +REAL PROC real (DINT CONST number) : + real value := 65536.0 * real (number.high) ; + + IF number.low >= 0 + THEN real value INCR real (number.low) + ELSE real value INCR (real (number.low AND maxint) + 32768.0) + FI ; + real value +ENDPROC real ; + +DINT PROC dint (REAL CONST number) : + real value := abs (number) ; + REAL CONST low := real value MOD 65536.0 ; + + result.high := int(real value / 65536.0) ; + IF low < 32768.0 + THEN result.low := int (low) + ELSE result.low := int (low-32768.0) OR minint + FI ; + IF number < 0.0 THEN dsub (dint0, result, result) FI ; + result +ENDPROC dint ; + +TEXT PROC text (DINT CONST number) : + IF number.high = 0 THEN convert low part only + ELSE convert number + FI ; + convertion buffer . + +convert low part only : + IF number.low >= 0 THEN convertion buffer := text (number.low) + ELSE convertion buffer := text (real of low) ; + erase decimal point + FI . + +real of low : + real (number.low AND maxint) + 32768.0 . + +convert number : + convertion buffer := text (real(number)) ; + erase decimal point . + +erase decimal point : + convertion buffer := subtext (convertion buffer, 1, LENGTH convertion buffer-2) +ENDPROC text; + +DINT PROC dint (TEXT CONST dint txt) : + convertion buffer := dint txt ; + INT CONST dot pos :: pos (convertion buffer, ".") ; + IF dot pos = 0 THEN convertion buffer CAT ".0" FI ; + dint (real(convertion buffer)) +ENDPROC dint ; + +PROC get (DINT VAR dest) : + REAL VAR number ; + get (number) ; + dest := dint (number) +ENDPROC get ; + +PROC put (DINT CONST number) : + put (text (number)); +ENDPROC put ; + +PROC cout (DINT CONST number) : + EXTERNAL 61 +ENDPROC cout; + +OP := (DINT VAR a, DINT CONST b) : +# INLINE ; # + dmov (b, a); +ENDOP :=; + +OP INCR (DINT VAR a, DINT CONST b) : +# INLINE ; # + dinc (b, a); +ENDOP INCR; + +OP DECR (DINT VAR a, DINT CONST b) : +# INLINE ; # + ddec (b, a); +ENDOP DECR; + +BOOL OP = (DINT CONST a, b) : + EXTERNAL 137 +ENDOP =; + +BOOL OP <= (DINT CONST a, b) : + EXTERNAL 138 +ENDOP <=; + +BOOL OP < (DINT CONST a, b) : +# INLINE ; # + NOT (b <= a) +ENDOP <; + +BOOL PROC dequ (DINT CONST a, b) : + EXTERNAL 137 +ENDPROC dequ ; + +BOOL PROC dlseq (DINT CONST a, b) : + EXTERNAL 138 +ENDPROC dlseq ; + +PROC replace (TEXT VAR text, INT CONST index of dint, DINT CONST value) : + INT VAR subscript := index of dint * 2 ; + replace (text, subscript - 1,value.low); + replace (text, subscript, value.high); +ENDPROC replace; + +DINT OP DSUB (TEXT CONST text, INT CONST index of dint) : + INT VAR subscript := index of dint * 2 ; + result.low := text ISUB subscript - 1; + result.high := text ISUB subscript; + result +ENDOP DSUB; + +DINT OP + (DINT CONST a, b) : + EXTERNAL 135 +ENDOP + ; + +DINT OP - (DINT CONST a, b) : + EXTERNAL 136 +ENDOP - ; + +PROC dadd (DINT CONST a, b, DINT VAR res) : + EXTERNAL 135 +ENDPROC dadd ; + +PROC dsub (DINT CONST a, b, DINT VAR res) : + EXTERNAL 136 +ENDPROC dsub ; + +PROC dinc (DINT CONST source, DINT VAR dest) : + EXTERNAL 133 +ENDPROC dinc ; + +PROC ddec (DINT CONST source, DINT VAR dest) : + EXTERNAL 134 +ENDPROC ddec ; + +PROC dmov (DINT CONST source, DINT VAR dest) : + EXTERNAL 130 +ENDPROC dmov; + +DINT OP DIV (DINT CONST a,b) : + EXTERNAL 152 +ENDOP DIV ; + +DINT OP MOD (DINT CONST a,b) : + EXTERNAL 153 +ENDOP MOD ; + +DINT OP AND (DINT CONST a,b) : + result.low := a.low AND b.low ; + result.high := a.high AND b.high ; + result +ENDOP AND ; + +DINT OP OR (DINT CONST a,b) : + result.low := a.low OR b.low ; + result.high := a.high OR b.high ; + result +ENDOP OR ; + +DINT OP XOR (DINT CONST a,b) : + result.low := a.low XOR b.low ; + result.high := a.high XOR b.high ; + result +ENDOP XOR ; + +PROC dput (ROW 32000 DINT VAR array, DINT CONST index, value) : + EXTERNAL 139 +ENDPROC dput ; + +PROC dget (ROW 32000 DINT VAR array, DINT CONST index, DINT VAR dest) : + EXTERNAL 140 +ENDPROC dget ; + +PROC dinc1 (DINT VAR dest) : + EXTERNAL 131 +ENDPROC dinc1 ; + +PROC ddec1 (DINT VAR dest) : + EXTERNAL 132 +ENDPROC ddec1 ; + +DINT OP * (DINT CONST a,b) : + EXTERNAL 151 +ENDOP * ; + +#page# + (***** Globale Variable *****) + +TEXT VAR object name; + +FILE VAR bulletin file; + +INT VAR memory management mode, global address offset, packet base, + hash table pointer, nt link, permanent pointer, param link, + packet link, index, mode, field pointer, word, + number of errors := 0 ; + +BOOL VAR found, end of params; + +#page# +(**************************************************************************) +(* *) +(* 1. Interface zum ELAN-Compiler 13.11.1986 *) +(* 1.8.1 *) +(* *) +(* Beschreibung der Tabellen (-groessen), *) +(* internen Vercodung von Typen *) +(* und Kennungen . *) +(* Initialisieren und Beenden des Compilers, *) +(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *) +(* *) +(**************************************************************************) + + +TYPE LIB = STRUCT (TEXT name, INT nt link, pt link, ADDRESS base) ; + +LET begin of hash table = 0 , + end of hash table = 1023 , + + begin of permanent table = 22784 , + before first pt entry = 22784 , + first permanent entry = 22785 , + end of permanent table = 32767 , + + wordlength = 1 , (* compile u n d run time *) + two word length = 2 , + three word length = 3 , + four word length = 4 , + + permanent param const = 10000 , + permanent param var = 20000 , + permanent proc op = 30000 , + permanent type = 30000 , + permanent row = 10 , + permanent struct = 11 , + permanent param proc = 12 , + permanent param proc end marker = 0 , + permanent type field = 0 , + + ptt limit = 10000 , + begin of pt minus ptt limit = 12784 , + begin of pt minus ptt limit 1 = 12785 , (* plus wordlength *) + + void id = 0 , + int id = 1 , + real id = 2 , + string id = 3 , + bool id = 5 , + bool result id = 6 , + dataspace id = 7 , + undefined id = 9 , + row id = 10 , + struct id = 11 , + end id = 0 , + + const = 1 , + var = 2 , + proc id = 3 , +(* denoter = 5 , *) + bold = 2 , + + ins = TRUE , + no ins = FALSE , + no lst = FALSE , + sermon = TRUE , + no sermon = FALSE , + + run again mode = 0 , + compile file mode = 1 , + prep coder mode = 5 , + + warning message = 2 , + error message = 4 , + + point line = "..............." ; + +INT CONST permanent packet := -2 , + permanent end := -3 ; + +BOOL VAR coder active := FALSE ; + +INT VAR run again mod nr := 0 ; + + + (***** Start/Ende *****) + +LET coder not active = "CODER not active" , + illegal define packet = "illegal define packet" ; + +PROC coder on (INT CONST data allocation mode) : + mark coder on ; + init opn section ; + init compiler ; + init memory management . + +mark coder on : + coder active := TRUE . + +init memory management : + memory management mode := data allocation mode . + +init compiler : + no do again ; + elan (prep coder mode, bulletin file, "", run again mod nr, + no ins, no lst, check option, no sermon) + +ENDPROC coder on; + +PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) : + IF coder active + THEN mark coder off ; + end coder (insert, sermon, start mod nr if no insert) + ELSE errorstop (coder not active) + FI . + +start mod nr if no insert : + IF insert THEN run again mod nr := 0 + ELSE run again mod nr := start proc.mod nr + FI ; + run again mod nr . + +mark coder off : + reset memory management mode ; + init opn section ; + coder active := FALSE +ENDPROC coder off ; + +PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) : + EXTERNAL 10021 +ENDPROC end coder ; + +PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line, + INT VAR start module number, BOOL CONST ins, lst, rtc, ser) : + EXTERNAL 256 +ENDPROC elan ; + +PROC unsigned arithmetic : + EXTERNAL 92 +ENDPROC unsigned arithmetic ; + + + (***** Paket-Rahmen *****) + +PROC declare (TEXT CONST name, LIB VAR packet) : + packet.name := name +ENDPROC declare ; + +PROC define (LIB VAR packet) : + check if definition possible ; + declare object (packet.name, packet.nt link, packet.pt link) ; + open packet (packet.nt link, global address offset, packet base) ; + set to actual base (packet) . + +check if definition possible : + IF NOT coder active THEN errorstop (coder not active) FI ; + IF module open THEN errorstop (illegal define packet) FI +ENDPROC define ; + +PROC open packet (INT CONST nt link of packet name, INT VAR offset, base) : + EXTERNAL 10032 +ENDPROC open packet ; + +PROC identify (TEXT CONST name, LIB VAR packet, BOOL VAR packet exists) : + to packet (name) ; + packet exists := found ; + IF found THEN packet.name := name ; + packet.nt link := nt link ; + packet.pt link := packet link ; + get pbas (packet.base) + FI +ENDPROC identify ; + + + (***** Hash/Namenstabelle *****) +. +next hash entry : + hash table pointer INCR wordlength . + +end of hash table reached : + hash table pointer > end of hash table . + +yet another nt entry : + nt link := cdb int (nt link) ; + nt link <> 0 . ; + +PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) : + EXTERNAL 10031 +ENDPROC declare object ; + +PROC to object (TEXT CONST searched object) : + hash ; + search nt entry . + +hash : + hash code := 0 ; + FOR index FROM 1 UPTO LENGTH searched object REP + addmult cyclic + ENDREP . + +addmult cyclic : + hash code INCR hash code ; + IF hash code > end of hash table THEN wrap around FI ; + hash code := (hash code + code (searched object SUB index)) MOD 1024 . + +wrap around : + hash code DECR end of hash table . + +hash code : nt link . + +search nt entry : + found := FALSE ; + WHILE yet another nt entry REP + read current entry ; + IF object name = searched object + THEN found := TRUE ; + LEAVE to object + FI + PER . + +read current entry : + permanent pointer := cdb int (nt link + wordlength) ; + object name := cdb text (nt link + two word length) +ENDPROC to object ; + + + (***** Permanent Tabelle *****) +. +next procedure : + permanent pointer := cdb int (permanent pointer) . ; + +PROC next pt param : + mode := cdb int (param link) MOD ptt limit ; + param link INCR wordlength ; + IF mode = permanent row THEN skip over permanent row + ELIF mode = permanent struct THEN skip over permanent struct + FI ; + set end marker if end of list . + +skip over permanent row : + param link INCR wordlength ; + next pt param . + +skip over permanent struct : + REP + mode := cdb int (param link) ; + IF mode = permanent type field + THEN param link INCR wordlength ; + LEAVE skip over permanent struct + FI ; + next pt param + PER +ENDPROC next pt param ; + +PROC set end marker if end of list : + mode := cdb int (param link) ; + end of params := mode >= permanent proc op OR mode <= 0 +ENDPROC set end marker if end of list ; + +PROC get type and mode (INT VAR type) : + mode := cdb int (param link) ; + IF mode < 0 THEN type := 2769 + (32767 + mode) ; + mode := 0 + ELIF mode = permanent param proc THEN translate type + ELSE type := mode MOD ptt limit ; + mode DECR type ; + translate type if necessary ; + translate mode if necessary + FI . + +translate type if necessary : + IF permanent row or struct THEN translate type FI . + +translate type : + type := param link - begin of pt minus ptt limit . + +translate mode if necessary : + IF mode = permanent param const THEN mode := const + ELIF mode = permanent param var THEN mode := var + FI . + +permanent row or struct : + type = permanent row OR type = permanent struct +ENDPROC get type and mode ; + +PROC put next permanent (INT CONST permanent value) : + EXTERNAL 10020 +ENDPROC put next permanent ; + + + (***** Allgemeine Zugriffsprozeduren *****) + +INT PROC cdb int (INT CONST index) : + EXTERNAL 116 +ENDPROC cdb int ; + +TEXT PROC cdb text (INT CONST index) : + EXTERNAL 117 +ENDPROC cdb text ; + + +#page# +(**************************************************************************) +(* *) +(* 2. Spruenge und Marken 07.10.1986 *) +(* *) +(* Definition des Datentyps LABEL *) +(* *) +(* Deklaration, Definition und Applikation von Marken *) +(* *) +(**************************************************************************) + + + +TYPE LABEL = INT ; + +BOOL VAR invers :: FALSE ; + +PROC declare (LABEL VAR label) : + CONCR (label) := 0 +ENDPROC declare ; + +PROC define (LABEL VAR label) : + EXTERNAL 10085 +ENDPROC define ; + +PROC complement condition code : + invers := NOT invers +ENDPROC complement condition code ; + +PROC apply (LABEL VAR label) : + EXTERNAL 10151 +ENDPROC apply ; + +PROC apply (LABEL VAR label, BOOL CONST condition) : + IF condition xor invers THEN branch true (label) + ELSE branch false (label) + FI ; + invers := FALSE . + +condition xor invers : + IF condition THEN NOT invers + ELSE invers + FI +ENDPROC apply ; + +OP := (LABEL VAR global label, local label) : (* EQUATE ! *) + EXTERNAL 10014 +ENDOP := ; + +TEXT PROC dump (LABEL CONST label) : + "LAB " + text (CONCR (label)) +ENDPROC dump ; + +PROC gosub (LABEL VAR label) : + EXTERNAL 10015 +ENDPROC gosub ; + +PROC goret : + s0 (q goret code) +ENDPROC goret ; + +PROC branch true (LABEL VAR label) : + EXTERNAL 10028 +ENDPROC branch true ; + +PROC branch false (LABEL VAR label) : + EXTERNAL 10029 +ENDPROC branch false ; + +PROC computed branch (ADDRESS CONST switch, INT CONST limit, LABEL VAR out) : + s1 (q esc case, REPR switch) ; + s0 (limit) ; + branch false (out) +ENDPROC computed branch ; + + +#page# +(**************************************************************************) +(* *) +(* 3. Datenaddressen 13.11.1986 *) +(* *) +(* Definition des Datentyps ADDRESS *) +(* *) +(* Aufbau von Datenaddressen (Vercodung) *) +(* Fortschalten und Ausrichten von Adressen *) +(* Behandlung von Paketbasis-Adressen *) +(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *) +(* *) +(**************************************************************************) + + + +TYPE ADDRESS = STRUCT (INT kind, value) ; + +LET global = 0 , + local = 1 , + ref mask = 2 , + global ref = 2 , + local ref = 3 , + module nr = 4 , + immediate value = 5 , + p base = 6 , + + eumel0 stack offset = 4 , + local address limit = 16 384 , + global address zero = 0 , + + illegal ref operation = "REF not allowed" , + deref on non ref = "DEREF on non-ref address" , + global ref not allowed = "GLOBAL REF not allowed" , + unknown kind = "Unknown address kind" , + address overflow = "Address Overflow" , + illegal plus operation = "+ not allowed" ; + +ADDRESS VAR result addr; + +INT CONST ref length :: 2 ; + +OP := (ADDRESS VAR l, ADDRESS CONST r) : + CONCR (l) := CONCR (r) +ENDOP := ; + +ADDRESS OP GLOB (INT CONST address level) : + result addr.kind := global ; + result addr.value := address level ; + IF memory management mode = data allocation by user + THEN result addr.value INCR global address offset + FI ; + result addr +ENDOP GLOB ; + +ADDRESS OP LOC (INT CONST address level) : + result addr.kind := local ; + result addr.value := address level + eumel0 stack offset ; + result addr +ENDOP LOC ; + +ADDRESS OP REF (ADDRESS CONST addr) : + CONCR (result addr) := CONCR (addr) ; + IF result addr.kind = local THEN result addr.kind INCR ref mask + ELIF result addr.kind = global THEN errorstop (global ref not allowed) + ELSE errorstop (illegal ref operation) + FI ; + result addr +ENDOP REF ; + +ADDRESS OP DEREF (ADDRESS CONST ref address) : + CONCR (result addr) := CONCR (ref address) ; + IF is not local ref THEN errorstop (deref on non ref) FI ; + result addr.kind DECR ref mask ; + result addr . + +is not local ref : + result addr.kind <> local ref +ENDOP DEREF ; + +INT OP REPR (ADDRESS CONST addr) : + CONCR (result addr) := CONCR (addr) ; + SELECT result addr.kind OF + CASE global : + CASE local : set bit (result addr.value, 15) + CASE global ref : errorstop (global ref not allowed) + CASE local ref : prep local ref + OTHERWISE errorstop (unknown kind) + ENDSELECT ; + result addr.value . + +prep local ref : + IF address limit exceeded THEN errorstop (address overflow) FI ; + set bit (result addr.value, 14) ; + set bit (result addr.value, 15) . + +address limit exceeded : + result addr.value < eumel0 stack offset OR + result addr.value > local address limit +ENDOP REPR ; + +PROC get base (LIB CONST packet, ADDRESS VAR base) : + CONCR (base) := CONCR (packet.base) +ENDPROC get base ; + +PROC set to actual base (LIB VAR packet) : + packet.base.kind := p base ; + packet.base.value := packet base +ENDPROC set to actual base ; + +PROC get pbas (ADDRESS VAR base) : + base.kind := p base ; + base.value := cdbint (packet link + 2) +ENDPROC get pbas ; + +BOOL OP = (ADDRESS CONST l,r) : + l.kind = r.kind AND l.value = r.value +ENDOP = ; + +BOOL PROC is ref (ADDRESS CONST addr) : + addr.kind = local ref +ENDPROC is ref ; + +BOOL PROC is global (ADDRESS CONST addr) : + addr.kind = global +ENDPROC is global ; + +BOOL PROC is local (ADDRESS CONST addr) : + addr.kind = local +ENDPROC is local ; + +ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) : + CONCR (result addr) := CONCR (addr) ; + SELECT result addr.kind OF + CASE global : inc global + CASE local : inc local + OTHERWISE errorstop (illegal plus operation) + ENDSELECT ; + result addr . + +inc global : + result addr.value INCR offset ; + IF result addr.value < 0 THEN errorstop (address overflow) FI . + +inc local : + result addr.value INCR offset ; + IF result addr.value < eumel 0 stack offset OR + result addr.value > local address limit + THEN errorstop (address overflow) + FI +ENDOP + ; + +PROC adjust (ADDRESS VAR addr, INT CONST adjust length) : + IF is local or global THEN adjust to length FI . + +is local or global : + addr.kind <= local . + +adjust to length : + mode := addr.value MOD adjust length ; + IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI +ENDPROC adjust ; + +TEXT PROC dump (ADDRESS CONST addr) : + kind + text (addr.value) . + +kind : + SELECT addr.kind OF + CASE global : "GLOBAL " + CASE local : "LOCAL " + CASE immediate value : "IMMEDIATE " + CASE module nr : "PARAM PROC " + CASE global ref : "GLOBAL REF " + CASE local ref : "LOCAL REF " + CASE p base : "PBAS " + OTHERWISE "undef. Addr: " + ENDSELECT +ENDPROC dump; + + +#page# +(**************************************************************************) +(* *) +(* 4. Datentypen Teil I 08.09.1986 *) +(* *) +(* Definition des Datentyps DTYPE *) +(* *) +(* Interne Repraesentation der primitiven Datentypen *) +(* Identifikation von DTYPEs *) +(* *) +(**************************************************************************) + + + +TYPE DTYPE = INT ; + +OP := (DTYPE VAR l, DTYPE CONST r) : + CONCR (l) := CONCR (r) +ENDOP := ; + +BOOL OP = (DTYPE CONST l, r) : + CONCR (l) = CONCR (r) +ENDOP = ; + +DTYPE PROC void type : DTYPE :(void id) ENDPROC void type ; + +DTYPE PROC int type : DTYPE :(int id) ENDPROC int type ; + +DTYPE PROC real type : DTYPE :(real id) ENDPROC real type ; + +DTYPE PROC text type : DTYPE :(string id) ENDPROC text type ; + +DTYPE PROC bool type : DTYPE :(bool id) ENDPROC bool type ; + +DTYPE PROC bool result type : DTYPE :(bool result id) ENDPROC bool result type; + +DTYPE PROC dataspace type : DTYPE :(dataspace id) ENDPROC dataspace type ; + +DTYPE PROC undefined type : DTYPE :(undefined id) ENDPROC undefined type ; + +DTYPE PROC row type : DTYPE :(row id) ENDPROC row type ; + +DTYPE PROC struct type : DTYPE :(struct id) ENDPROC struct type ; + +DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ; + +DTYPE PROC end type : DTYPE :(end id) ENDPROC end type ; + +INT PROC type class (DTYPE CONST type) : + SELECT type id OF + CASE int id, real id, bool id, bool result id, string id, + dataspace id, undefined id : 1 + CASE void id : 0 + CASE row id : 3 + CASE struct id : 4 + CASE permanent param proc : 5 + OTHERWISE pt type + ENDSELECT . + +pt type : + IF type id > ptt limit THEN permanent row or struct + ELSE abstract type + FI . + +abstract type : 2 . + +permanent row or struct : + unsigned arithmetic ; + mode := cdbint (type link into pt) MOD ptt limit ; + IF mode = struct id THEN 4 + ELIF mode = row id THEN 3 + ELIF mode = permanent param proc THEN 5 + ELSE 2 + FI . + +type link into pt : + type id + begin of pt minus ptt limit . + +type id : CONCR (type) +ENDPROC type class ; + +PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) : + SELECT type pos OF + CASE 1 : size := 0; align := 0; type id := void id + CASE 6 : size := 1; align := 1; type id := int id + CASE 10 : size := 4; align := 4; type id := real id + CASE 15 : size := 8; align := 4; type id := string id + CASE 20 : size := 1; align := 1; type id := bool id + CASE 25 : size := 1; align := 1; type id := dataspace id + OTHERWISE search for type in permanent table + ENDSELECT . + +type pos : + enclose in delimiters ; + pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) . + +enclose in delimiters : + object name := "." ; + object name CAT name ; + object name CAT "." . + +search for type in permanent table : + to object (name) ; + IF not found THEN size := 0; align := 0; type id := undefined id + ELSE size := cdbint (permanent pointer + two wordlength) ; + type id := permanent pointer - begin of permanent table ; + IF size < two wordlength THEN align := 1 + ELIF size < four wordlength THEN align := 2 + ELSE align := 4 + FI + FI . + +not found : + NOT found OR invalid entry . + +invalid entry : + permanent pointer = 0 OR + cdb int (permanent pointer + wordlength) <> permanent type . + +type id : CONCR (type) +ENDPROC identify ; + + +#page# +(**************************************************************************) +(* *) +(* 5. Operationen Teil I 30.09.1986 *) +(* *) +(* Definition des Datentyps OPN *) +(* Primitive Operationen (:= etc.) *) +(* Initialisieren mit den externen Namen der EUMEL-0-Codes *) +(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *) +(* *) +(**************************************************************************) + + +TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ; + +LET proc op = 0 , + param proc = 1 , + eumel 0 = 2 , + nil = 3 , + + param proc at non ref = "PARAM PROC at non-ref address" , + proc op expected = "PROC expected" ; + +OPN VAR eumel0 opn; +eumel0 opn.kind := eumel0 ; +eumel0 opn.top of stack := 0 ; + +eumel0 opn.mod nr := q pp ; +OPN CONST pp :: eumel0 opn , + nop code :: OPN :(nil, 0, 0) ; + +IF NOT exists ("eumel0 codes") + THEN IF yes ("Archive 'eumel coder' eingelegt") + THEN archive ("eumel coder") ; + fetch ("eumel0 codes", archive) ; + release (archive) + ELSE errorstop ("""eumel0 codes"" gibt es nicht") + FI +FI ; +BOUND THESAURUS VAR initial opcodes :: old ("eumel0 codes") ; +THESAURUS VAR eumel 0 opcodes :: initial opcodes ; +forget ("eumel0 codes") ; + +ADDRESS PROC address (OPN CONST opn) : + IF opn.kind <> proc op THEN errorstop (proc op expected) FI ; + result addr.kind := module nr ; + result addr.value := opn.mod nr ; + result addr +ENDPROC address ; + +OPN PROC operation (ADDRESS CONST addr) : + IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ; + OPN VAR opn ; + opn.kind := param proc ; + opn.mod nr :=addr.value ; + opn.top of stack := 0 ; + opn +ENDPROC operation ; + +TEXT PROC mnemonic (OPN CONST op code) : + name (eumel 0 opcodes, op code.mod nr) +ENDPROC mnemonic ; + +OPN PROC nop : + nop code +ENDPROC nop ; + +OP := (OPN VAR r, OPN CONST l) : + CONCR (r) := CONCR (l) +ENDOP := ; + +BOOL PROC is proc (OPN CONST operation) : + operation.kind = proc op +ENDPROC is proc ; + +BOOL PROC is eumel 0 instruction (TEXT CONST op code name) : + link (eumel 0 opcodes, op code name) <> 0 +ENDPROC is eumel 0 instruction ; + +BOOL PROC is eumel 0 instruction (OPN CONST operation) : + operation.kind = eumel0 +ENDPROC is eumel 0 instruction ; + + +#page# +(**************************************************************************) +(* *) +(* 6. Parameterfeld 10.04.1986 *) +(* *) +(* Bereitstellen des Parameterfeldes *) +(* Schreiben und Lesen von Eintraegen im Parameterfeld *) +(* Fortschalten von Zeigern in das Parameterfeld *) +(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *) +(* *) +(**************************************************************************) + + + +LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access, + ADDRESS addr, OPN push opn) , + + size of param field = 100 , + param field exceeded = "Param Field Overflow", + param nr out of range = "Illegal Param Number" ; + +ROW size of param field PARAMDESCRIPTOR VAR param field ; + + + (***** Schreiben *****) + +PROC test param pos (INT CONST param nr) : + IF param nr < 1 OR param nr > size of param field + THEN errorstop (param nr out of range) + FI +ENDPROC test param pos ; + +PROC declare (INT CONST param nr, DTYPE CONST type) : + test param pos (param nr) ; + enter type . + +enter type : + CONCR (param field [param nr].type) := CONCR (type) +ENDPROC declare ; + +PROC declare (INT CONST param nr, access) : + test param pos (param nr) ; + enter access . + +enter access : + param field [param nr].access := access +ENDPROC declare ; + +PROC define (INT CONST param nr, ADDRESS CONST addr) : + test param pos (param nr) ; + enter address . + +enter address : + CONCR (param field [param nr].addr) := CONCR (addr) +ENDPROC define ; + +PROC define (INT CONST param nr, value) : + result addr.kind := immediate value ; + result addr.value := value ; + define (param nr, result addr) +ENDPROC define ; + +PROC apply (INT CONST param nr, OPN CONST opn) : + test param pos (param nr) ; + enter push opn . + +enter push opn : + CONCR (param field [param nr].push opn) := CONCR (opn) +ENDPROC apply ; + +PROC parameter (INT CONST param nr, DTYPE CONST type, + INT CONST access, ADDRESS CONST addr) : + test param pos (param nr) ; + enter type ; + enter access ; + enter address ; + enter pp as default . + +enter type : + CONCR (param field [param nr].type) := CONCR (type) . + +enter access : + param field [param nr].access := access . + +enter address : + CONCR (param field [param nr].addr) := CONCR (addr) . + +enter pp as default : + CONCR (param field [param nr].push opn) := CONCR (pp) +ENDPROC parameter ; + + + (***** Lesen *****) + +ADDRESS PROC param address (INT CONST param nr) : + test param pos (param nr) ; + param field [param nr].addr +ENDPROC param address ; + +DTYPE PROC dtype (INT CONST param nr) : + test param pos (param nr) ; + param field [param nr].type +ENDPROC dtype ; + +INT PROC access (INT CONST param nr) : + test param pos (param nr) ; + param field [param nr].access +ENDPROC access ; + + + (***** Fortschalten *****) + +OP NEXTPARAM (INT VAR param nr) : + test param pos (param nr) ; + INT CONST class :: type class (param field [param nr].type) ; + param nr INCR 1 ; + SELECT class OF + CASE 3 : NEXTPARAM param nr + CASE 4,5 : read until end + ENDSELECT . + +read until end : + WHILE NOT end marker read or end of field REP + NEXTPARAM param nr + PER ; + param nr INCR 1 . + +end marker read or end of field : + param nr > size of param field OR + CONCR (param field [param nr].type) = end id +ENDOP NEXTPARAM ; + +INT PROC next param (INT CONST p) : + INT VAR index := p ; + NEXTPARAM index ; + index +ENDPROC next param ; + +TEXT PROC dump (INT CONST p) : + IF p > 0 AND p <= 100 THEN dump entry (param field (p)) + ELSE param nr out of range + FI +ENDPROC dump ; + +TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) : +(* object name := dump (id.type) ; *) + object name := "TYPE " ; (* siehe *) + object name CAT dump (id.type) ; (* TEXT PROC dump (DTYPE d) *) + object name CAT text (id.access) ; + object name CAT dump (id.addr) ; + object name CAT dump (id.push opn) ; + object name +ENDPROC dump entry ; + + +#page# +(**************************************************************************) +(* *) +(* 7. Datentypen Teil II 08.09.1986 *) +(* *) +(* Deklaration neuer Datentypen *) +(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *) +(* *) +(**************************************************************************) + + + +DTYPE VAR pt type ; + +PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) : + entry into name table ; + put next permanent (permanent type) ; + put next permanent (size) ; + put next permanent (nt link) ; + mark no offsets of text elements . + +entry into name table : + declare object (name, nt link, CONCR (type)) ; + CONCR (type) DECR begin of permanent table . + +mark no offsets of text elements : + put next permanent (0) +ENDPROC declare ; + +BOOL PROC same type (INT CONST param 1, param 2) : + INT CONST left type :: CONCR (param field [param 1].type) ; + IF left type = right type + THEN same fine structure if there is one + ELSE left type = undefined id OR right type = undefined id + FI . + +right type : CONCR (param field [param 2].type) . + +same fine structure if there is one : + IF left type = row id THEN compare row + ELIF left is struct or proc THEN compare struct + ELSE TRUE + FI . + +left is struct or proc : + left type = struct id OR left type = proc id . + +compare row : + equal sizes AND same type (param1 + 1, param2 + 1) . + +equal sizes : + param field [param1+1].access = param field [param2+1].access . + +compare struct : + INT VAR p1 :: param1+1, p2 :: param2+1 ; + WHILE same type (p1, p2) AND NOT end type found REP + NEXTPARAM p1 ; + NEXTPARAM p2 + UNTIL end of field PER ; + FALSE . + +end type found : + CONCR (param field [p1].type) = end id . + +end of field : + p1 > size of param field OR p2 > size of param field +ENDPROC same type ; + +BOOL PROC same type (INT CONST param nr, DTYPE CONST type) : + field pointer := param nr ; + CONCR (pt type) := CONCR (type) ; + equal types +ENDPROC same type ; + +BOOL PROC equal types : + identical types OR one type is undefined . + +one type is undefined : + type of actual field = undefined id OR CONCR(pt type) = undefined id . + +identical types : + SELECT type class (pt type) OF + CASE 0, 1, 2 : type of actual field = CONCR (pt type) + CASE 3 : perhaps equal rows + CASE 4 : perhaps equal structs + CASE 5 : perhaps equal param procs + OTHERWISE FALSE + ENDSELECT . + +perhaps equal rows : + param link := CONCR (pt type) + begin of pt minus ptt limit ; + is row AND equal row sizes AND equal row types . + +is row : + type of actual field = row id . + +perhaps equal structs : + param link := CONCR (pt type) + begin of pt minus ptt limit ; + is struct AND same type fields . + +is struct : + type of actual field = struct id . + +equal row sizes : + pt row size = row size within param field . + +equal row types : + field pointer INCR 1 ; + param link INCR 2 ; + get type and mode (CONCR(pt type)) ; + equal types . + +pt row size : + cdb int (param link + 1) . + +row size within param field : + param field [field pointer + 1].access . + +same type fields : + REP + field pointer INCR 1 ; + param link INCR 1 ; + IF type of actual field = end id + THEN LEAVE same type fields WITH pt struct end reached + FI ; + get type and mode (CONCR(pt type)) ; + IF NOT equal types THEN LEAVE same type fields WITH FALSE FI + UNTIL end of field PER ; + FALSE . + +pt struct end reached : + cdbint (param link) = permanent type field . + +end of field : + field pointer > size of param field . + +type of actual field : + CONCR (param field [field pointer].type) . + +perhaps equal param procs : + param link := CONCR (pt type) + begin of pt minus ptt limit ; + is proc AND same param list . + +is proc : cdbint (param link) = permanent param proc . + +same param list : + param link INCR wordlength ; + DTYPE VAR proc result type ; + get type and mode (CONCR (proc result type)) ; + compare param list ; + check results . + +compare param list : + INT VAR last param := field pointer + 1 ; + REP + field pointer INCR 1 ; + param link INCR wordlength ; + IF pt param list exhausted THEN LEAVE compare param list FI ; + IF type of actual field = end id + THEN LEAVE equal types WITH FALSE + FI ; + get type and mode (CONCR(pt type)) ; + last param := field pointer ; + UNTIL NOT equal types OR end of field PER . + +check results : + pt param list exhausted AND equal result types . + +equal result types : + save param link ; + IF same type (last param, proc result type) + THEN restore ; + TRUE + ELSE FALSE + FI . + +pt param list exhausted : + cdbint (param link) = permanent param proc end marker . + +save param link : + INT CONST p :: param link . + +restore : + field pointer INCR 1 ; + param link := p + +ENDPROC equal types ; + +BOOL PROC is not void bool or undefined (DTYPE CONST dtype) : + type <> void id AND type <> bool result id AND type <> undefined id . + +type : CONCR (dtype) +ENDPROC is not void bool or undefined ; + + +#page# +(**************************************************************************) +(* *) +(* 8. Operationen Teil II 08.09.1986 *) +(* *) +(* Definition der Opcodes *) +(* Deklaration, Definition, Identifikation und Applikation *) +(* Eroeffnen und Schliessen eines Moduls *) +(* *) +(**************************************************************************) + + + +LET module not opened = "Module not opened" , + define missing = "DEFINE missing" , + wrong nr of params = "Wrong Nr. of Params:" , + illegal kind = "Opcode expected" , + nested module = "Nested Modules" , + no mod nr = "Param Proc expected" , + no immediate value = "Value expected" , + type error = "Type Error" , + + q ln = 1 , + q move = 2 , q move code = 2 048 , + q inc1 = 3 , q inc1 code = 3 072 , + q dec1 = 4 , q dec1 code = 4 096 , + q inc = 5 , q inc code = 5 120 , + q dec = 6 , q dec code = 6 144 , + q add = 7 , q add code = 7 168 , + q sub = 8 , q sub code = 8 192 , + q clear = 9 , q clear code = 9 216 , + q test = 10 , + q equ = 11 , q equ code = 11 264 , + q lsequ = 12 , q lsequ code = 12 288 , + q fmove = 13 , q fmove code = 13 312 , + q fadd = 14 , q fadd code = 14 336 , + q fsub = 15 , q fsub code = 15 360 , + q fmult = 16 , q fmult code = 16 384 , + q fdiv = 17 , q fdiv code = 17 408 , + q flsequ = 18 , q flsequ code = 18 432 , + q tmove = 19 , q tmove code = 19 456 , + q tequ = 20 , q tequ code = 20 480 , + q accds = 21 , q access ds code = 22 528 , + q ref = 22 , q ref code = 23 552 , + q subscript = 23 , q subscript code = 24 576 , + q select = 24 , q select code = 25 600 , + q ppv = 25 , q ppv code = 26 624 , + q pp = 26 , + q make false = 27 , (* q make false code = 65 513 *) + q movex = 28 , +(* q longa subs q longa subs code = 65 376 *) + q return = 29 , q return code = 32 512 , + q true return = 30 , q true return code = 32 513 , + q false return = 31 , q false return code = 32 514 , + q goret code = 32 519 , + q esc mult = 32 , q esc mult code = 32 553 , + q esc div = 33 , q esc div code = 32 554 , + q esc mod = 34 , q esc mod code = 32 555 , + q pproc = 35 , + q compl int = 36 , q compl int code = 32 551 , + q compl real = 37 , q compl real code = 32 550 , + q alias ds = 38 , q alias ds code = 32 546 , + q movim = 39 , q esc movim code = 32 547 , + q fequ = 40 , q fequ code = 32 548 , + q tlsequ = 41 , q tlsequ code = 32 549 , +(* q case = 42 , *) q esc case = 32 544 , + q plus = 43 , + q minus = 44 , + q mult = 45 , + q int div = 46 , + q real div = 47 , + q equal = 48 , + q lessequal = 49 , + q ulseq = 50 , q ulseq code = 21 504 , + q pdadd = 51 , q pdadd code = 32 653 , + q ppsub = 52 , q ppsub code = 32 654 , + q dimov = 53 , q dimov code = 32 655 , + q idmov = 54 , q idmov code = 32 656 ; + +INT CONST q make false code :: - 1 022 , + q longa subs code :: - 159 , + q penter code :: - 511 ; + + + (***** Deklaration *****) + +PROC declare (OPN VAR operation) : + operation.kind := proc op ; + get module nr (operation.mod nr) ; + operation.top of stack := 0 +ENDPROC declare ; + +PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) : + declare (operation) ; + entry into name and pt table if necessary ; + enter params ; + enter result ; + enter module number . + +entry into name and pt table if necessary : + declare object (name, nt link, permanent pointer) . + +enter params : + field pointer := first ; + FOR index FROM 1 UPTO params REP + enter param (param field [field pointer]) ; + NEXTPARAM field pointer + PER . + +enter result : + enter param (param field[field pointer].type, permanent proc op) . + +enter module number : + put next permanent (operation.mod nr) +ENDPROC declare ; + +PROC enter param (PARAMDESCRIPTOR CONST param) : + IF param.access = const + THEN enter param (param.type, permanent param const) + ELIF param.access = var + THEN enter param (param.type, permanent param var) + ELSE errorstop ("Unknown Access") + FI +ENDPROC enter param ; + +PROC enter param (DTYPE CONST type, INT CONST permanent mode) : + unsigned arithmetic ; + SELECT type class (type) OF + CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode) + OTHERWISE errorstop ("Illegal Type") + ENDSELECT +ENDPROC enter param ; + + + (***** Definition *****) + +PROC define (OPN VAR opn) : + IF NOT module open THEN errorstop (module not opened) + ELSE proc head (opn.mod nr, opn.top of stack) + FI +ENDPROC define ; + +PROC set length of local storage (OPN VAR opn, INT CONST size) : + IF size < 0 OR size > local address limit + THEN errorstop (address overflow) + ELIF opn.top of stack = 0 + THEN errorstop (define missing) + ELIF opn.kind <> proc op + THEN errorstop (proc op expected) + FI ; + set length (opn.top of stack, size + eumel0 stack offset) +ENDPROC set length of local storage ; + +PROC define (OPN VAR operation, INT CONST size) : + define (operation) ; + set length of local storage (operation, size) +ENDPROC define ; + + + (***** Identifikation *****) + +INT VAR counter, result index, result type repr; + +PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation, + BOOL VAR object exists) : + find result entry ; + to object (name) ; + IF found THEN first fit and leave if found FI ; + IF eumel0 THEN identify eumel0 instruction + ELSE yield undefined operation + FI . + +find result entry : + result index := first; + counter := 0 ; + WHILE counter < params REP + NEXTPARAM result index ; + counter INCR 1 + PER ; + check on param field exceeded . + +check on param field exceeded : + IF result index > size of param field + THEN errorstop (param field exceeded) + FI . + +yield undefined operation : + declare (result index, undefined type) ; + apply (result index, nop) ; + object exists := FALSE . + +first fit and leave if found : + WHILE yet another procedure exists REP + check one procedure and leave if match ; + next procedure + PER . + +yet another procedure exists : + permanent pointer <> 0 . + +check one procedure and leave if match: + param link := permanent pointer + wordlength ; + set end marker if end of list ; + counter := params ; + field pointer := first ; + REP + IF end of params AND counter = 0 + THEN procedure found + ELIF end of params OR counter = 0 + THEN LEAVE check one procedure and leave if match + ELSE check next param + FI + PER . + +check next param : + get type and mode (CONCR(pt type)) ; + IF same types THEN set param mode ; + field pointer INCR 1 ; + param link INCR 1 ; + set end marker if end of list ; + counter DECR 1 ; + ELSE LEAVE check one procedure and leave if match + FI . + +same types : (* inline version ! *) + equal types . + +set param mode : + param field [field pointer].access := mode . + +procedure found : + get result ; + operation.kind := proc op ; + operation.mod nr := module number ; + operation.top of stack := 0 ; + object exists := TRUE ; + LEAVE identify . + +get result : + get type and mode (result type) ; + declare (result index, mode) . + +module number : + cdbint (param link + 1) . + +result type : + CONCR (param field [result index].type) . + +eumel0 : + eumel0 opn.mod nr := link (eumel 0 opcodes, name) ; + eumel0 opn.mod nr <> 0 . + +identify eumel 0 instruction : + init result type with void ; + CONCR (operation) := CONCR (eumel0 opn) ; + object exists := check params and set result ; + declare (result index, DTYPE:(result type repr)) ; + declare (result index, const) . + +init result type with void : + result type repr := void id . + +check params and set result : + SELECT operation.mod nr OF + CASE q return, q false return, q true return : no params + CASE q inc1, q dec1 : one int param yielding void + CASE q pproc, q pp, q ln : one param yielding void + CASE q test : one param yielding bool + CASE q clear, q ppv : one int or bool param yielding void + CASE q make false : one bool param yielding void + CASE q move : two int or bool params yielding void + CASE q compl int, q inc, q dec : two int params yielding void + CASE q compl real, q fmove : two real params yielding void + CASE q equ, q lsequ, q ulseq : two int params yielding bool + CASE q fequ, q flsequ : two real params yielding bool + CASE q tequ, q tlsequ : two text params yielding bool + CASE q tmove : two text params yielding void + CASE q accds, q ref, q movim, + q dimov, q idmov : two params yielding void + CASE q add, q sub, q esc mult, + q esc div, q esc mod : three int params yielding void + CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void + CASE q select, q movex, q alias ds, + q pdadd, q ppsub : three params + CASE q subscript : five params + CASE q plus, q mult : two intreals yielding intreal + CASE q minus : monadic or dyadic minus + CASE q int div : two int params yielding int + CASE q real div : two real params yielding real + CASE q equal, q lessequal : two intrealtexts yielding bool + OTHERWISE FALSE + ENDSELECT . + +no params : + params = 0 . + +one int param yielding void : + p1 void (int type, first, params) . + +one param yielding void : + params = 1 . + +one param yielding bool : + IF params = 1 THEN result type repr := bool id ; + TRUE + ELSE FALSE + FI . + +one int or bool param yielding void : + p1 void (int type, first, params) OR p1 void (bool type, first, params) . + +one bool param yielding void : + p1 void (bool type, first, params) . + +two int or bool params yielding void : + p2 (int type, first, params, void id) OR + p2 (bool type, first, params, void id) . + +two int params yielding void : + p2 (int type, first, params, void id) . + +two real params yielding void : + p2 (real type, first, params, void id) . + +two text params yielding void : + p2 (text type, first, params, void id) . + +two int params yielding bool : + p2 (int type, first, params, bool id) . + +two real params yielding bool : + p2 (real type, first, params, bool id) . + +two text params yielding bool : + p2 (text type, first, params, bool id) . + +two params yielding void : + params = 2 . + +three int params yielding void : + p3 void (int type, first, params) . + +three real params yielding void : + p3 void (real type, first, params) . + +three params : + params = 3 . + +five params : + params = 5 . + +two intreals yielding intreal : + two int params yielding int OR two real params yielding real . + +monadic or dyadic minus : + IF params = 2 THEN two intreals yielding intreal + ELIF params = 1 THEN monadic minus + ELSE FALSE + FI . + +monadic minus : + result type repr := CONCR (param field[first].type) ; + result type repr = int id OR result type repr = real id . + +two intrealtexts yielding bool : + two int params yielding bool OR two real params yielding bool OR + two text params yielding bool . + +two int params yielding int : + p2 (int type, first, params, int id) . + +two real params yielding real : + p2 (real type, first, params, real id) +ENDPROC identify ; + +BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) : + param nr = 1 AND param type is requested plain type . + +param type is requested plain type : + CONCR (param field [first].type) = CONCR (requested type) + +ENDPROC p1 void ; + +BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr, + INT CONST result type) : + IF param nr = 2 AND param types equal requested plain type + THEN result type repr := result type ; + TRUE + ELSE FALSE + FI . + +param types equal requested plain type : + CONCR (param field [first] .type) = CONCR (requested type) AND + CONCR (param field [first+1].type) = CONCR (requested type) + +ENDPROC p2 ; + +BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) : + param nr = 3 AND param types ok . + +param types ok : + FOR index FROM first UPTO first+2 REP + IF different param types THEN LEAVE p3 void WITH FALSE FI + PER ; + TRUE . + +different param types : + CONCR (param field [index].type) <> CONCR (requested type) +ENDPROC p3 void; + + + (***** Applikation *****) + +INT VAR address representation, left repr, right repr, result repr; + +PROC apply (INT CONST first, nr of params, OPN CONST opn) : + IF NOT module open THEN errorstop (module not opened) FI ; + SELECT opn.kind OF + CASE eumel 0 : generate eumel0 instruction + CASE proc op : call operation + CASE param proc : call param proc + CASE nil : + OTHERWISE errorstop (illegal kind) + ENDSELECT . + +call operation : + push params if necessary (first, nr of params, opn.mod nr) ; + call (opn.mod nr) . + +call param proc : + result addr.kind := local ref ; + result addr.value := opn.mod nr ; + INT CONST module nr := REPR result addr ; + push params if necessary (first, nr of params, module nr) ; + call param (module nr) . + +generate eumel0 instruction : + SELECT real nr of params OF + CASE 0 : p0 instruction + CASE 1 : apply p1 (opn, first addr) + CASE 2 : apply p2 (opn, first addr, second addr) + CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr) + CASE 5 : subscript operation + OTHERWISE errorstop (wrong nr of params + text (nr of params)) + ENDSELECT . + +real nr of params : + IF operator denotation THEN nr of params + 1 + ELSE nr of params + FI . + +operator denotation : + opn.mod nr >= q plus AND opn.mod nr < q ulseq . + +p0 instruction : + IF opn.mod nr = q return THEN s0 (q return code) + ELIF opn.mod nr = q true return THEN s0 (q true return code) + ELIF opn.mod nr = q false return THEN s0 (q false return code) + ELSE errorstop (wrong nr of params + + mnemonic (opn)) + FI . + +subscript operation : + IF opn.mod nr = q subscript + THEN subscription + ELSE errorstop (wrong nr of params + text (nr of params)) + FI . + +subscription : + ADDRESS CONST element length :: param field [first+2].addr , + limit :: param field [first+3].addr ; + check on immediates ; + IF element length.value < 1024 + THEN s0 (q subscript code + element length.value) + ELSE s0 (q longa subs code) ; + s0 (element length.value) + FI ; + s3 (limit.value - 1, subs index, base addr, subs result) . + +check on immediates : + IF element length.kind <> immediate value OR + limit.kind <> immediate value + THEN errorstop (no immediate value) + FI . + +subs index : REPR param field [first+1].addr . + +base addr : REPR param field [first].addr . + +subs result : REPR param field [first+4].addr . + +first addr : + param field [first].addr . + +left type : + param field [first].type . + +second addr : + param field [nextparam (first)].addr . + +third addr : + param field [nextparam(nextparam(first))].addr +ENDPROC apply ; + +PROC push params if necessary (INT CONST first, nr of params, mod nr) : + init param push (mod nr) ; + field pointer := first ; + IF nr of params > 0 THEN push params FI ; + push result if there is one . + +push params : + FOR index FROM 1 UPTO nr of params REP + apply p1 (push code, param addr) ; + NEXTPARAM field pointer + PER . + +push code : + param field [field pointer].push opn . + +param addr : + param field [field pointer].addr . + +push result if there is one : + IF push result necessary + THEN push result address (REPR param field [field pointer].addr) + FI . + +push result necessary : + param field [field pointer].push opn.kind <> nil AND + is not void bool or undefined (param field [field pointer].type) +ENDPROC push params if necessary ; + +PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) : + IF opn.mod nr = q ln THEN generate line number + ELIF opn.mod nr = q pproc THEN push module nr + ELSE gen p1 instruction + FI . + +gen p1 instruction : + address representation := REPR addr ; + SELECT opn.mod nr OF + CASE q inc1 : t1 (q inc1 code, address representation) + CASE q dec1 : t1 (q dec1 code, address representation) + CASE q clear : t1 (q clear code,address representation) + CASE q test : test bool object (address representation) + CASE q pp : push param (address representation) + CASE q ppv : s1 (q ppv code, address representation) + CASE q make false : s1 (q make false code, address representation) + OTHERWISE errorstop (wrong nr of params + mnemonic (opn)) + ENDSELECT . + +generate line number : + IF addr.kind = immediate value THEN mark line (addr.value) + ELSE errorstop (no immediate value) + FI . + +push module nr : + IF addr.kind = module nr THEN push param proc (addr.value) + ELSE errorstop (no mod nr) + FI +ENDPROC apply p1; + +PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr): + left repr := REPR left addr ; + IF opn.mod nr = q movim THEN move immediate + ELSE gen p2 instruction + FI . + +gen p2 instruction : + right repr := REPR right addr ; + SELECT opn.mod nr OF + CASE q move : t2 (q move code, right repr, left repr) + CASE q inc : t2 (q inc code, right repr, left repr) + CASE q dec : t2 (q dec code, right repr, left repr) + CASE q equ : compare (q equ code, left repr, right repr) + CASE q lsequ : compare (q lsequ code, left repr, right repr) + CASE q ulseq : compare (q ulseq code, left repr, right repr) + CASE q fmove : t2 (q fmove code, right repr, left repr) + CASE q flsequ : compare (q flsequ code, left repr, right repr) + CASE q tmove : t2 (q tmove code, right repr, left repr) + CASE q tequ : compare (q tequ code, left repr, right repr) + CASE q compl int : s2 (q compl int code, left repr, right repr) + CASE q compl real : s2 (q compl real code, left repr, right repr) + CASE q fequ : compare (q fequ code, left repr, right repr) + CASE q tlsequ : compare (q tlsequ code, left repr, right repr) + CASE q accds : t2 (q access ds code, left repr, right repr) + CASE q ref : t2 (q ref code, left repr, right repr) + CASE q dimov : s2 (q dimov code, left repr, right repr) + CASE q idmov : s2 (q idmov code, left repr, right repr) + OTHERWISE errorstop (wrong nr of params + mnemonic (opn)) + ENDSELECT . + +move immediate : + IF right addr.kind = immediate value + THEN s0 (q esc movim code) ; + s1 (right addr.value, left repr) + ELSE errorstop (no immediate value) + FI +ENDPROC apply p2; + +PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype, + ADDRESS CONST left addr, right addr, result addr ): + result repr := REPR result addr ; + IF opn.mod nr = q pdadd THEN select with dint; LEAVE apply p3 + ELIF opn.mod nr = q select THEN gen select instruction; LEAVE apply p3 FI ; + left repr := REPR left addr ; + IF opn.mod nr = q movex THEN gen long move + ELIF opn.mod nr = q alias ds THEN alias dataspace + ELSE gen p3 instruction + FI . + +gen long move : + IF right addr.kind = immediate value + THEN long move (left repr, result repr, right addr.value) + ELSE errorstop (no immediate value) + FI . + +alias dataspace : + IF right addr.value = immediate value + THEN s0 (q alias ds code) ; + s2 (right addr.value, result repr, left repr) + ELSE errorstop (no immediate value) + FI . + +gen select instruction : + IF right addr.kind = immediate value + THEN IF different bases + THEN access external (left addr.value, right addr.value) + ELSE t1 (q select code, REPR left addr) ; + s1 (right addr.value, result repr) + FI + ELSE errorstop (no immediate value) + FI . + +select with dint : + right repr := REPR right addr ; + IF different bases THEN access external packet + ELSE simple access + FI . + +different bases : + left addr.kind = p base AND left addr.value <> packet base . + +simple access : + s3 (q pdadd code, REPR left addr, right repr, result repr) . + +access external packet : + access external (left addr.value, global address zero) ; + s3 (q pdadd code, REPR REF result addr, right repr, result repr) . + +gen p3 instruction : + right repr := REPR right addr ; + SELECT opn.mod nr OF + CASE q add : int add + CASE q sub : int sub + CASE q fadd : real add + CASE q fsub : real sub + CASE q fmult : real mult + CASE q fdiv, q real div : real div + CASE q esc mult : int mult + CASE q esc div, q int div : int div + CASE q esc mod : int mod + CASE q plus : int real add + CASE q minus : int real sub + CASE q mult : int real mult + CASE q equal, q lessequal : compare (comp code, left repr, right repr) + CASE q ppsub : distance between two objects + OTHERWISE errorstop (wrong nr of params + mnemonic (opn)) + ENDSELECT . + +int add : compute (q add code, left repr, right repr, result repr) . + +int sub : compute (q sub code, left repr, right repr, result repr) . + +real add : compute (q fadd code, left repr, right repr, result repr) . + +real sub : compute (q fsub code, left repr, right repr, result repr) . + +real mult : compute (q fmult code, left repr, right repr, result repr) . + +real div : compute (q fdiv code, left repr, right repr, result repr) . + +int mult : s3 (q esc mult code, left repr, right repr, result repr) . + +int div : s3 (q esc div code, left repr, right repr, result repr) . + +int mod : s3 (q esc mod code, left repr, right repr, result repr) . + +int real add : + IF left type = int id THEN int add + ELSE real add + FI . + +int real sub : + IF left type = int id THEN int sub + ELSE real sub + FI . + +int real mult : + IF left type = int id THEN int mult + ELSE real mult + FI . + +comp code : + SELECT left type OF + CASE int id : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI + CASE real id : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI + CASE string id : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI + OTHERWISE errorstop (type error); q equ + ENDSELECT . + +left type : CONCR (left dtype) . + +distance between two objects : + s3 (q ppsub code, left repr, right repr, result repr) + +ENDPROC apply p3; + +PROC access external (INT CONST old base, offset) : + s0 (q penter code + old base) ; + t2 (q ref code, offset, result repr) ; + s0 (q penter code + packet base) +ENDPROC access external ; + + + (***** Modul *****) + +BOOL VAR module open ; + +.init opn section : + module open := FALSE .; + +PROC begin module : + IF module open THEN errorstop (nested module) + ELSE begin modul ; + module open := TRUE + FI +ENDPROC begin module ; + +PROC end module : + IF NOT module open + THEN errorstop (module not opened) + ELSE end modul ; + module open := FALSE + FI +ENDPROC end module ; + +TEXT PROC dump (OPN CONST operation) : + IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5) + ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation) + ELSE " undef. Opn" + FI +ENDPROC dump ; + +PROC begin modul : + EXTERNAL 10073 +ENDPROC begin modul ; + +PROC end modul : + EXTERNAL 10011 +ENDPROC end modul ; + +PROC proc head (INT VAR mod nr, top of stack) : + EXTERNAL 10012 +ENDPROC proc head ; + +PROC set length (INT CONST top of stack, size) : + EXTERNAL 10013 +ENDPROC set length ; + +PROC get module nr (INT VAR module nr) : + EXTERNAL 10016 +ENDPROC get module nr ; + +PROC compute (INT CONST op code, l addr, r addr, result address) : + EXTERNAL 10017 +ENDPROC compute ; + +PROC compare (INT CONST op code, l addr, r addr) : + EXTERNAL 10018 +ENDPROC compare ; + +PROC long move (INT CONST to, from, length) : + EXTERNAL 10019 +ENDPROC long move ; + +PROC call (INT CONST mod nr) : + EXTERNAL 10022 +ENDPROC call ; + +PROC call param (INT CONST mod nr) : + EXTERNAL 10023 +ENDPROC call param ; + +PROC push param (INT CONST addr) : + EXTERNAL 10024 +ENDPROC push param ; + +PROC push param proc (INT CONST mod nr) : + EXTERNAL 10025 +ENDPROC push param proc ; + +PROC init param push (INT CONST mod nr) : + EXTERNAL 10026 +ENDPROC init param push ; + +PROC push result address (INT CONST addr) : + EXTERNAL 10027 +ENDPROC push result address ; + +PROC test bool object (INT CONST addr) : + EXTERNAL 10192 +ENDPROC test bool object ; + +PROC mark line (INT CONST line number) : + EXTERNAL 10030 +ENDPROC mark line ; + +PROC s0 (INT CONST op code) : + EXTERNAL 10038 +ENDPROC s0 ; + +PROC s1 (INT CONST op code, addr) : + EXTERNAL 10039 +ENDPROC s1 ; + +PROC s2 (INT CONST op code , addr1, addr2) : + EXTERNAL 10040 +ENDPROC s2 ; + +PROC s3 (INT CONST op code, addr1, addr2, addr3) : + EXTERNAL 10041 +ENDPROC s3 ; + +PROC t1 (INT CONST op code, addr) : + EXTERNAL 10042 +ENDPROC t1 ; + +PROC t2 (INT CONST op code, addr1, addr2) : + EXTERNAL 10043 +ENDPROC t2 ; + +#page# +(**************************************************************************) +(* *) +(* 9. Speicherverwaltung 03.06.1986 *) +(* *) +(* Ablage der Paketdaten *) +(* *) +(**************************************************************************) + + + +INT VAR address value; + +INT CONST data allocation by coder := 1 , + data allocation by user := 2 ; + +LET not initialized = 0 , + wrong mm mode = "Wrong MM Mode" , + define on non global = "Define for GLOB only" , + text too long = "TEXT too long" ; + +TEXT VAR const buffer :: point line ; + +.reset memory management mode : + memory management mode := not initialized . ; + +PROC reserve storage (INT CONST size) : + IF memory management mode <> data allocation by user + THEN errorstop (wrong mm mode) + FI ; + allocate var (address value, size) ; + memory management mode := not initialized +ENDPROC reserve storage ; + +PROC allocate variable (ADDRESS VAR addr, INT CONST size) : + IF memory management mode <> data allocation by coder + THEN errorstop (wrong mm mode) + FI ; + allocate var (addr.value, size) ; + addr.kind := global +ENDPROC allocate variable ; + +PROC allocate denoter (ADDRESS VAR addr, INT CONST value) : + IF memory management mode <> data allocation by coder + THEN errorstop (wrong mm mode) + FI ; + allocate int denoter (addr.value) ; + put data word (value, addr.value) ; + addr.kind := global +ENDPROC allocate denoter ; + +PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) : + IF memory management mode <> data allocation by coder + THEN errorstop (wrong mm mode) + FI ; + allocate real denoter (addr.value) ; + addr.kind := global ; + define (addr, value) +ENDPROC allocate denoter ; + +PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) : + IF memory management mode <> data allocation by coder + THEN errorstop (wrong mm mode) + FI ; + allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ; + addr.kind := global ; + skip heaplink; + define (addr, value) ; + reset heaplink . + +skip heaplink : + addr.value INCR 1 . + +reset heaplink : + addr.value DECR 1 +ENDPROC allocate denoter ; + +PROC allocate denoter (ADDRESS VAR addr, DINT CONST value) : + IF memory management mode <> data allocation by coder + THEN errorstop (wrong mm mode) + FI ; + allocate dint denoter (addr.value, value) ; + addr.kind := global +ENDPROC allocate denoter ; + +PROC allocate dint denoter (INT VAR addr offset, DINT CONST value) : + adjust to an even address if necessary ; + put data word (value.low, addr offset) ; + allocate int denoter (address value) ; + put data word (value.high, address value) . + +adjust to an even address if necessary : + allocate int denoter (addr offset) ; + IF (addr offset AND 1) <> 0 THEN allocate int denoter (addr offset) FI +ENDPROC allocate dint denoter ; + +PROC define (ADDRESS CONST addr, INT CONST value) : + IF addr.kind <> global + THEN errorstop (define on non global) + FI ; + put data word (value, addr.value) +ENDPROC define ; + +PROC define (ADDRESS CONST addr, DINT CONST value) : + IF addr.kind <> global + THEN errorstop (define on non global) + FI ; + put data word (value.low , addr.value); + put data word (value.high, addr.value + 1) +ENDPROC define ; + +PROC define (ADDRESS CONST addr, REAL CONST value) : + IF addr.kind <> global + THEN errorstop (define on non global) + FI ; + replace (const buffer, 1, value) ; + address value := addr.value ; + FOR index FROM 1 UPTO 4 REP + put data word (const buffer ISUB index, address value) ; + address value INCR 1 + PER +ENDPROC define ; + +PROC define (ADDRESS CONST addr, TEXT CONST value) : + IF addr.kind <> global THEN errorstop (define on non global) + ELIF LENGTH value > 255 THEN errorstop (text too long) + FI ; + address value := addr.value ; + const buffer := code (LENGTH value) ; + const buffer CAT value ; + const buffer CAT ""0"" ; + FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP + put data word (const buffer ISUB index, address value) ; + address value INCR 1 + PER ; + const buffer := point line +ENDPROC define ; + +PROC allocate var (INT VAR addr, INT CONST length) : + EXTERNAL 10033 +ENDPROC allocate var ; + +PROC allocate int denoter (INT VAR addr) : + EXTERNAL 10034 +ENDPROC allocate int denoter ; + +PROC allocate real denoter (INT VAR addr) : + EXTERNAL 10035 +ENDPROC allocate real denoter ; + +PROC allocate text denoter (INT VAR addr, INT CONST length) : + EXTERNAL 10036 +ENDPROC allocate text denoter ; + +PROC put data word (INT CONST value, INT CONST addr) : + EXTERNAL 10037 +ENDPROC put data word ; + + +#page# +(**************************************************************************) +(* *) +(* 10. Inspector 28.10.1987 *) +(* *) +(**************************************************************************) + + + +INT VAR line number, pattern length, begin of packet, + last packet entry, indentation; + +TEXT VAR bulletin name, type and mode, pattern, buffer, dummy name; + +DATASPACE VAR bulletin ds :: nilspace ; + +.packet name : + cdb text (cdb int(packet link + wordlength) + two word length) . + +.packet entry : + permanent pointer = 0 OR + cdbint (permanent pointer) = permanent packet OR + cdbint (permanent pointer + wordlength) = permanent packet . + +.within editor : + aktueller editor > 0 . ; + +TEXT PROC type name (DTYPE CONST type) : + type and mode := "" ; + IF CONCR (type) = void id THEN type and mode CAT "VOID" + ELSE name of type (CONCR (type)) + FI ; + type and mode +ENDPROC type name ; + +TEXT PROC dump (DTYPE CONST type) : +(* type and mode := "TYPE " ; + name of type (CONCR (type)) ; + type and mode +*) + type name (type) (* aus Kompatibilitätsgründen zum 1.9.2 Coder / rr *) +ENDPROC dump ; + +PROC name of type (INT CONST type) : + SELECT type OF + CASE void id : + CASE int id : type and mode CAT "INT" + CASE real id : type and mode CAT "REAL" + CASE string id : type and mode CAT "TEXT" + CASE bool id, bool result id : type and mode CAT "BOOL" + CASE dataspace id : type and mode CAT "DATASPACE" + CASE row id : type and mode CAT "ROW " + CASE struct id : type and mode CAT "STRUCT" + OTHERWISE : complex type + ENDSELECT . + +complex type : + unsigned arithmetic ; + IF type > ptt limit THEN perhaps permanent struct or row + ELSE get complex type + FI . + +perhaps permanent struct or row : + index := type + begin of pt minus ptt limit ; + mode := cdb int (index) MOD ptt limit ; + IF mode = permanent row THEN get permanent row + ELIF mode = permanent struct THEN get permanent struct + ELSE type and mode CAT "-" + FI . + +get complex type : + index := type + begin of permanent table ; + IF is complex type THEN get name + ELSE type and mode CAT "-" + FI . + +is complex type : + permanent type definition mode = permanent type . + +get name : + type and mode CAT cdb text (link to type name + two word length) . + +link to type name : + cdb int (index + three word length) . + +permanent type definition mode : + cdb int (index + wordlength) . + +get permanent row : + INT VAR t; + type and mode CAT "ROW " ; + type and mode CAT text (cdb int (index + wordlength)) ; + type and mode CAT " " ; + param link := index + two wordlength ; + get type and mode (t) ; + name of type (t) . + +get permanent struct : + type and mode CAT "STRUCT ( ... )" +ENDPROC name of type ; + +PROC help (TEXT CONST proc name) : + prep bulletin ; + prep help ; + scan (object name) ; + next symbol (pattern) ; + packet link := end of permanent table ; + IF function = 0 THEN standard help + ELSE asterisk help + FI . + +prep help : + object name := compress (proc name) ; + INT VAR function :: 0 ; + INT CONST l :: LENGTH object name ; + IF l > 1 AND object name <> "**" + THEN IF (object name SUB l) = "*" + THEN function INCR 2 ; + delete char (object name, l) + FI ; + IF (object name SUB 1) = "*" + THEN function INCR 1 ; + delete char (object name, 1) + FI ; + IF another asterisk THEN wrong function FI + FI. + +another asterisk : + pos (object name, "*") <> 0 . + +wrong function : + errorstop ("unzulaessige Sternfunktion") . + +standard help : + to object (pattern) ; + IF found THEN display + ELSE error stop ("unbekannt: " + proc name) + FI . + +display : + IF NOT packet entry + THEN WHILE permanent pointer <> 0 REP + put name of packet if necessary ; + put specifications (pattern) ; + next procedure + ENDREP ; + show bulletin file + FI . + +put name of packet if necessary : + IF new packet THEN packet link := permanent pointer ; + find begin of packet ; + writeline (2) ; + write packet name + FI . + +find begin of packet : + REP + packet link DECR wordlength + UNTIL begin of packet found PER . + +begin of packet found : + cdb int (packet link) = permanent packet . + +new packet : + permanent pointer < packet link . + +asterisk help : + hash table pointer := begin of hash table ; + pattern length := LENGTH pattern - 1 ; + REP + list all objects in current hash table chain ; + next hash entry + UNTIL end of hash table reached ENDREP ; + show bulletin file . + +list all objects in current hash table chain : + nt link := hash table pointer ; + WHILE yet another nt entry REP + permanent pointer := cdb int (nt link + wordlength) ; + object name := cdb text (nt link + two word length) ; + IF matching THEN into bulletin FI + PER . + +matching : + INT CONST p :: pos (object name, pattern) ; + SELECT function OF + CASE 1 : p <> 0 AND p = LENGTH object name - pattern length + CASE 2 : p = 1 + CASE 3 : p <> 0 + OTHERWISE FALSE + ENDSELECT . + +into bulletin : + object names into bulletin (BOOL PROC not end of chain) +ENDPROC help ; + +BOOL PROC not end of chain : + permanent pointer <> 0 +ENDPROC not end of chain ; + +PROC write packet name : + indentation := 0 ; + write line ; + write bulletin line ("PACKET ") ; + indentation := 7 ; + object name := packet name ; + write bulletin line (object name) ; + write bulletin line (":") ; + writeline (2) +ENDPROC write packet name ; + +PROC put specifications (TEXT CONST proc name) : + put obj name (proc name) ; + to first param ; + IF NOT end of params THEN put param list FI ; + put result ; + writeline . + +to first param : + param link := permanent pointer + word length ; + set end marker if end of list . + +put result : + INT VAR type; + get type and mode (type) ; + IF type <> void id THEN type and mode := " --> " ; + name of type (type) ; + write bulletin line (type and mode) + FI +ENDPROC put specifications ; + +PROC put param list : + write bulletin line (" (") ; + REP + INT VAR type, param mode; + get type and mode (type) ; + param mode := mode ; + put type and mode ; + maybe param proc ; + next pt param ; + IF end of params THEN write bulletin line (")") ; + LEAVE put param list + FI ; + write bulletin line (", ") ; + PER . + +put type and mode : + type and mode := "" ; + name of type (type) ; + type and mode CAT name of mode ; + write bulletin line (type and mode) . + +name of mode : + IF param mode = const THEN " CONST" + ELIF param mode = var THEN " VAR" + ELSE " PROC" + FI . + +maybe param proc : + IF mode = permanent param proc THEN put virtual params FI . + +put virtual params : + skip over result type if complex type ; + IF NOT end of virtual params THEN put param list FI. + +skip over result type if complex type : + next pt param . + +end of virtual params : + end of params +ENDPROC put param list ; + +PROC to packet (TEXT CONST packet name) : + to object ( packet name) ; + IF found THEN find start of packet objects FI . + +find start of packet objects : + last packet entry := 0 ; + packet link := before first pt entry ; + REP + packet link INCR wordlength ; + word := cdb int (packet link) ; + IF word < 0 THEN IF word = permanent packet THEN packet found + ELIF word = permanent end THEN return + FI + FI + ENDREP . + +packet found : + IF cdb int (packet link + wordlength) = nt link + THEN last packet entry := packet link FI . + +return : + IF last packet entry <> 0 THEN found := TRUE ; + packet link := last packet entry + ELSE found := FALSE + FI ; + LEAVE to packet +ENDPROC to packet ; + +PROC next packet : + REP + packet link INCR wordlength ; + word := cdb int (packet link) ; + IF word = permanent packet THEN true return + ELIF end of permanents THEN false return + FI ; + ENDREP . + +true return : + found := TRUE ; + LEAVE next packet . + +false return : + found := FALSE ; + LEAVE next packet . + +end of permanents : + word = permanent end OR packet link > end of permanent table +ENDPROC next packet ; + +PROC prep bulletin : + forget (bulletin ds) ; + bulletin ds := nilspace ; + bulletin file := sequential file (output, bulletin ds) ; + line number := 0 ; + buffer := "" +ENDPROC prep bulletin ; + +PROC show bulletin file : + IF within editor THEN ueberschrift neu FI ; + DATASPACE VAR local ds :: bulletin ds ; + FILE VAR local file :: sequential file (modify, local ds) ; + show (local file) ; + forget (local ds) +ENDPROC show bulletin file ; + +PROC write bulletin line (TEXT CONST line) : + IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ; + buffer CAT line +ENDPROC write bulletin line ; + +PROC writeline : + write (bulletin file, buffer) ; + line (bulletin file) ; + line number INCR 1 ; + cout (line number) ; + buffer := indentation * " " +ENDPROC writeline ; + +PROC writeline (INT CONST times) : + IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ; + writeline + ELSE index := times + FI ; + line (bulletin file, index) ; + line number INCR index; + indentation := 0 ; + cout (line number) +ENDPROC writeline ; + +PROC bulletin (TEXT CONST packet name) : + prep bulletin ; + scan (packet name) ; + next symbol (pattern) ; + to packet (pattern) ; + IF found THEN list packet ; + show bulletin file + ELSE error stop (packet name + " ist kein Paketname") + FI . + +ENDPROC bulletin ; + +PROC list packet : + begin of packet := packet link + word length ; + write packet name ; + find end of packet ; + run through nametab and list all packet objects . + +find end of packet : + last packet entry := begin of packet ; + REP + last packet entry INCR wordlength ; + word := cdb int (last packet entry) ; + UNTIL end of packet entries PER . + +end of packet entries : + word = permanent packet OR word = permanent end . + +run through nametab and list all packet objects : + hashtable pointer := begin of hashtable ; + REP + nt link := hashtable pointer ; + list objects of current packet in this chain ; + next hash entry + UNTIL end of hashtable reached ENDREP . + +list objects of current packet in this chain : + WHILE yet another nt entry REP + permanent pointer := cdb int (nt link + wordlength) ; + put objects of this name + PER . + +put objects of this name : + IF there is an entry THEN into bulletin FI . + +there is an entry : + NOT packet entry AND + there is at least one object of this name in the current packet . + +there is at least one object of this name in the current packet : + REP + IF permanent pointer >= begin of packet AND + permanent pointer < last packet entry + THEN LEAVE there is at least one object of this name + in the current packet WITH TRUE FI ; + next procedure + UNTIL permanent pointer = 0 PER ; + FALSE . + +into bulletin : + object name := cdb text (nt link + two word length) ; + object names into bulletin (BOOL PROC within packet) +ENDPROC list packet ; + +BOOL PROC within packet : + permanent pointer >= begin of packet AND + permanent pointer < last packet entry +ENDPROC within packet ; + +PROC object names into bulletin (BOOL PROC link ok) : + scan (object name) ; + next symbol (dummy name, mode) ; + IF type definition THEN put type definition + ELSE put object definitions + FI . + +type definition : + mode = bold AND no params . + +no params : + cdb int (permanent pointer + word length) >= permanent type . + +put type definition : + put obj name (object name) ; + write bulletin line ("TYPE ") ; + writeline (1) . + +put object definitions : + WHILE link ok REP + put specifications (object name) ; + next procedure + ENDREP +ENDPROC object names into bulletin ; + +PROC bulletin : + prep bulletin ; + packet link := first permanent entry ; + REP + list packet ; + write line (4) ; + next packet + UNTIL NOT found PER ; + show bulletin file +ENDPROC bulletin ; + +PROC put obj name (TEXT CONST name) : + buffer := " " ; + bulletin name := point line ; + change (bulletin name, 1, end of line or name, name) ; + buffer CAT bulletin name ; + indentation := LENGTH buffer + 1 . + +end of line or name : + min (LENGTH name, LENGTH bulletin name) +ENDPROC put obj name ; + +PROC packets : + prep bulletin ; + packet link := first permanent entry ; + REP + object name := packet name ; + put obj name (object name) ; + write line ; + next packet + UNTIL NOT found PER ; + show bulletin file +ENDPROC packets ; + +#page# +(**************************************************************************) +(* *) +(* 11. ELAN Run-Interface 04.08.1986 *) +(* *) +(* Uebersetzen von ELAN-Programmen *) +(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *) +(* *) +(**************************************************************************) + + + +BOOL VAR list option := FALSE , + check option := TRUE , + warning option := FALSE , + listing enabled := FALSE ; + +FILE VAR listing file ; + +TEXT VAR listing file name := "" ; + + +PROC run (TEXT CONST file name) : + enable stop ; + IF NOT exists (file name) + THEN errorstop ("""" + file name + """ gibt es nicht") + FI ; + last param (file name) ; + run elan (file name, no ins) +END PROC run; + +PROC run : + run (last param) +ENDPROC run ; + +PROC run again : + IF run again mod nr <> 0 + THEN elan (run again mode, bulletin file, "", run again mod nr, + no ins, no lst, check option, no sermon) + ELSE errorstop ("'run again' nicht moeglich") + FI +ENDPROC run again ; + +PROC insert (TEXT CONST file name) : + enable stop ; + IF NOT exists (file name) + THEN errorstop ("""" + file name + """ gibt es nicht") + FI ; + last param (file name) ; + run elan (file name, ins) +ENDPROC insert ; + +PROC insert : + insert (last param) +ENDPROC insert ; + +PROC run elan (TEXT CONST file name, BOOL CONST insert option) : + FILE VAR source := sequential file (modify, file name) ; + IF listing enabled + THEN open listing file + FI ; + + disable stop ; + no do again ; + elan (compile file mode, source, "" , run again mod nr, + insert option, list option, check option, sermon) ; + + IF anything noted AND command dialogue + THEN ignore halt during compiling ; + note edit (source) ; + last param (file name) ; + errorstop ("") + FI . + +ignore halt during compiling : + IF is error + THEN put error ; + clear error ; + pause (5) + FI . + +open listing file : + listing file := sequential file (output, listing file name) ; + max line length (listing file, 130) + +ENDPROC run elan ; +(* +PROC out text (TEXT CONST text, INT CONST out type) : + INTERNAL 257 ; + IF online + THEN out (text) + FI ; + IF out type = error message OR (warning option AND out type = warning message) + THEN note (text) ; + FI ; + IF listing enabled + THEN write (listing file, text) + FI +ENDPROC out text ; + +PROC out line (INT CONST out type) : + INTERNAL 258 ; + IF online + THEN out (""13""10"") + FI ; + IF out type = error message + OR (warning option AND out type = warning message) + THEN note line + ELIF listing enabled + THEN line (listing file) + FI +ENDPROC out line ; +*) +PROC prot (TEXT CONST file name) : + list option := TRUE ; + listing file name := file name ; + listing enabled := TRUE +ENDPROC prot ; + +PROC prot off : + list option := FALSE ; + listing enabled := FALSE +ENDPROC prot off ; + +BOOL PROC prot : + list option +ENDPROC prot ; + +PROC check on : + check option := TRUE +ENDPROC check on ; + +PROC check off : + check option := FALSE +ENDPROC check off ; + +BOOL PROC check : + check option +ENDPROC check ; + +PROC warnings on : + warning option := TRUE +ENDPROC warnings on ; + +PROC warnings off : + warning option := FALSE +ENDPROC warnings off ; + +BOOL PROC warnings : + warning option +ENDPROC warnings ; + +ENDPACKET eumel coder ; + +PACKET dint2 DEFINES dint type : + +INT VAR dummy ; +DTYPE VAR d ; +identify ("DINT", dummy, dummy, d) ; + +DTYPE CONST dint type := d + +ENDPACKET dint2 ; + 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; + diff --git a/system/net/1.7.5/doc/EUMEL Netz b/system/net/1.7.5/doc/EUMEL Netz new file mode 100644 index 0000000..ad39db3 --- /dev/null +++ b/system/net/1.7.5/doc/EUMEL Netz @@ -0,0 +1,832 @@ +#type ("trium8")##limit (11.0)#
+#start(2.5,1.5)##pagelength (17.4)#
+#block#
+#headeven#
+
+% EUMEL-Netzbeschreibung
+
+
+#end#
+#headodd#
+
+#center#Inhalt#right#%
+
+
+#end#
+
+#type ("triumb12")#
+1. Einleitung
+
+
+Teil 1: Netz einrichten und benutzen
+#type ("trium8")#
+
+1. Benutzung des Netzes
+
+2. Hardwarevoraussetzungen
+
+3. Einrichten des Netzes
+
+4. Informationsmglichkeiten
+
+5. Eingriffsmglichkeiten
+
+6. Fehlerbehebung im Netz
+
+#type ("triumb12")#
+
+Teil 2: Arbeitsweise der Netzsoftware
+#type ("trium8")#
+
+1. Die Netztask
+
+2. Protokollebenen
+
+3. Stand der Netzsoftware
+
+#page#
+#headodd#
+
+#center#Einleitung#right#%
+
+
+#end#
+
+#type("triumb12")#
+1. Einleitung #type("trium8")#
+
+
+Das EUMEL-Netz dient dazu mehrere EUMEL-Rechner (sog. Stationen) mit-
+einander zu koppeln. Diese Kopplung wird von Betriebsystem dazu benutzt, das
+Sendungskonzept (siehe Systemhandbuch 1.7, Intertaskkommunikation) so auszu-
+dehnen, da Tasks verschiedener Stationen einander Datenrume zusenden
+knnen. Auf dem Sendungskonzept aufbauende Konzepte nutzen daher automa-
+tisch das Netz aus: So ist es z.B. mglich
+
+- von einer Station aus auf einer anderen zu Drucken,
+
+- in PUBLIC einer anderen Station Dateien zu sichern (save), vorausgesetzt, da
+ PUBLIC dort ein free global manager ist,
+
+- auf einer anderen Station zu archivieren (z.B. wenn das eigene Archivlaufwerk
+ defekt ist oder ein anderes Format hat).
+
+Das Netz kann ab EUMEL-Version 1.7.3 eingesetzt werden.
+
+
+#type("triumb12")#
+Teil 1: Netz einrichten und benutzen
+
+1. Benutzung des Netzes #type("trium8")#
+#headodd#
+
+#center#Teil 1: Netz einrichten und benutzen#right#%
+
+
+#end#
+
+ Zur Benutzung des Netzes stehen folgende Operatoren und Prozeduren zur
+ Verfgung:
+
+
+1.1
+
+ TASK OP / (INT CONST station, TEXT CONST taskname)
+
+ liefert die Task #on("bold")#taskname#off("bold")# von der Station #on("bold")#station#off("bold")#.
+
+ Wenn die Station #on("bold")#station#off("bold")# nicht am Netz ist oder nicht eingeschaltet ist, wird
+ solange gewartet, bis das der Fall ist.
+
+ Fehlerflle:
+
+ - task "..." gibt es nicht
+
+ Die angeforderte Task gibt es in der Zielstation nicht.
+
+ - Collectortask fehlt
+
+ Das Kommando #on("bold")#define collector#off("bold")# wurde nicht gegeben (siehe 4.2).
+
+ - Station x antwortet nicht
+
+ Eine nicht vorhandene oder abgeschaltete Station wurde angesprochen.
+ Hinweis: Dieser Fehler wird angenommen, wenn eine berwachungszeit
+ von ca. 30 Sekunden verschrichen ist, ohne da Station x die
+ Taskidentifikation angeliefert hat.
+
+ Beispiel:
+
+ list (5/"PUBLIC")
+
+ Dateiliste von PUBLIC auf Station 5 wird angefordert.
+
+1.2
+
+ TASK OP / (INT CONST station, TASK CONST task)
+
+ liefert
+
+ station / name (task) .
+
+
+ Beispiel:
+
+ list (4/archive)
+
+
+1.3
+
+ INT PROC station (TASK CONST task)
+
+ liefert die Stationsnummer der Task #on("bold")#task#off("bold")#.
+
+ Beispiel:
+
+ put (station (myself))
+
+ gibt die eigene Stationsnummer aus.
+
+
+1.4
+
+ PROC archive (TEXT CONST archivename, INT CONST station)
+
+ dient dazu das Archiv auf der Station #on("bold")#station#off("bold")# anzumelden.
+
+ Beispiel:
+
+ archive ("std", 4); list (4/archive)
+
+ gibt das Inhaltsverzeichnis der Archivfloppy im Laufwerk der Station 4 aus.
+ Hinweis: Vergessen Sie bei solchen Querarchivierungen nicht die Stations-
+ angabe bei jedem einzelnen Archivkommando (z.B fetch ("xxx", #on("bold")#4/#off("bold")#
+ archive).
+ Hinweis: Querarchivieren ist langsam. Verwenden Sie es nur, wenn Sie Flop-
+ pyformate umsetzen wollen.
+
+
+1.5
+
+ PROC free global manager
+
+ dient dazu, die eigene Task ber das Netz ansprechbar zu machen. Jede
+ andere Task im Netz kann dann die blichen Manageraufrufe ('save', 'fetch',
+ u.s.w.) an die eigene Task machen, sofern diese nicht an ein Terminal gekop-
+ pelt ist.
+
+ Die Task wird (wie bei 'break') abgekoppelt und meldet sich in Zukunft mit
+ 'maintenance' statt mit 'gib kommando'.
+
+ Beispiel:
+
+ An Station 4 ruft man in der Task 'hugo' das Kommando #on("bold")#free global manager#off("bold")#
+ auf. Anschlieend kann man von jeder Station aus z.B. 'list (4/"hugo")' u.s.w.
+ machen.
+
+
+1.6
+
+ TEXT PROC name (TASK CONST t)
+
+ Diese (schon immer vorhandene) Prozedur wurde dahingehend erweitert, da der
+ Name einer Task einer anderen Station ber Netz angefordert wird.
+
+ Fehlerfall:
+
+ Station x antwortet nicht
+
+
+
+
+#type("triumb12")#2. Hardwarevoraussetzungen#type("trium8")#
+
+2.1 Zwei Stationen
+
+ Sie knnen zwei Stationen miteinander Vernetzen, wenn Sie dafr an jeder
+ Station eine V24-Schnittstelle zur Verfgung stellen.
+
+ Diese beiden Schnittstellen verbinden Sie mit einem Kabel zur Rechner-
+ kopplung (siehe Systemhandbuch 1.7 Teil 2).
+
+2.2 Mehrere Stationen
+
+ Wenn Sie mehr als zwei Stationen vernetzen wollen, brauchen neben je
+ einer V24 an jeder Station noch je eine Netzanschlubox.
+
+ Jede Box besitzt eine V24-Schnittstelle zum Anschlu an die V24-
+ Schnittstelle der zugeorneten Station und eine weitere Schnittstelle zur
+ Verbindung der Boxen untereinander.
+
+
+#type("triumb12")#3. Einrichten des Netzes #type("trium8")#
+
+Hinweis: Dieses Kapitel ist nur fr Systembetreuer wichtig.
+
+3.1 Legen Sie Stationsnummern fr die am Netz beteiligten Rechner fest (von 1 an
+ aufsteigend).
+
+ Die Boxen haben ebenfalls Stationsnummern. Die Stationsnummern der Box
+ und des zugeordneten Rechners mssen bereinstimmen.
+
+
+3.2 Holen Sie an jeder Station die Task #on("bold")#configurator#off("bold")# an ein Terminal und geben Sie
+ das Kommando #on("bold")#define collector ("net port")#off("bold")#. Geben Sie auerdem das
+ Kommando #on("bold")#define station (x)#off("bold")#, wobei #on("bold")#x#off("bold")# die gewhlte Stationsnummer ist.
+
+ Hinweis: Taskkommunikationen, die zu dem Zeitpunkt laufen, fhren zu feh-
+ lerhaften Verhalten. Dies liegt daran, da durch #on("bold")#define station#off("bold")# alle
+ Task-Id's gendert werden mssen, weil eine Task-Id u.a. die
+ Stationsnummer der eigenen Station enthlt (siehe 2.3). TASK-
+ Variable, die noch Task-Id's mit keiner oder falscher Stationsnum-
+ mer enthalten, knnen nicht mehr zum Ansprechen einer Task
+ verwendet werden.
+
+ Beispiel: Der Spoolmanager (siehe Benutzerhandbuch 1.7 Teil 12) richtet
+ beim Kommando #on("bold")#start#off("bold")# einen Worker ein und merkt sich dessen
+ Task-Id in einer TASK-Variablen, um sicherzustellen, da nur der
+ Worker Dateien zum Drucken abholt. Wird jetzt das Kommando #on("bold")#
+ define station#off("bold")# gegeben, kann der Spoolmanager seinen Worker
+ nicht mehr identifizieren, weil der Worker eine neue Task-Id er-
+ halten hat. Man mu daher den Worker lschen und mit dem
+ Kommando #on("bold")#start#off("bold")# im Spoolmanager wieder neu einrichten.
+
+
+ Sinnvollerweise gibt man #on("bold")#define station#off("bold")# sofort nach den Laden eines
+ frischen Systems von Archiv.
+
+ Konfigurieren Sie mit dem Kommando #on("bold")#configurate#off("bold")# den fr das Netz vorgese-
+ henen Kanal auf
+
+ - transparent
+ - 9600 Baud (Standardeinstellung der Boxen)
+ - RTS/CTS-Protokoll
+ - groen Puffer
+ - 8 bit
+ - even parity
+ - 1 stopbit.
+
+ Falls diese Einstellungen nicht alle angeboten werden, klren Sie mit Ihrem
+ Rechnerlieferanten, ob und wie diese Einstellungen erreicht werden knnen.
+ Hinweis: Notfalls kann auf das RTS/CTS-Protokoll verzichtet werden, wenn
+ der Eingabepuffer der Station gro genug ist. Die Anzahl simultan
+ laufender Netzkommunikationen ist dann auf
+
+ puffergre DIV 150
+
+ begrenzt (bei Z80, 8086: 3; bei M20: 10).
+ Hinweis: Es knnen auch andere Baudraten (2400, 4800, 19200) an der Box
+ eingestellt werden.
+
+3.3 Achten Sie bei der Verbindung von der Station zur Netzbox (bzw. zur Gegen-
+ station bei einem Zweistationennetz ohne Boxen) darauf, da neben den
+ Empfangs- und Sendeleitungen auch die Leitungen RTS und CTS verdrahtet
+ werden, also ein 5 poliges Kabel verwendet wird (siehe Systemhandbuch 1.7
+ Teil 2). Die Pin-Belegung der Boxen entspricht den dortigen Angaben.
+
+ Beispiel:
+
+ Verbindung eines CSK-Systems mit der Box:
+
+ Stecker Stecker
+ Pin Pin
+
+ 2 <---------> 3
+ 3 <---------> 2
+ 4 <---------> 5
+ 5 <---------> 4
+ 7 <---------> 7
+
+
+3.4 Richten Sie eine Task #on("bold")#net#off("bold")# unter #on("bold")#SYSUR#off("bold")# ein und insertieren Sie dort die Datei-
+en
+
+ net report/M
+ basic net
+ net manager/M.
+
+ Beantworten Sie die Frage nach dem Kanal fr das Netz und nach der Flu-
+ kontrolle (RTS/CTS).
+
+
+#type("triumb12")#4. Informationsmglichkeiten #type("trium8")#
+
+ In der Task #on("bold")#net#off("bold")# wird eine Datei #on("bold")#report#off("bold")# gefhrt in der Fehlersituationen des
+ Netzes verzeichnet werden. Diese Datei kann in jeder anderen Task mit #on("bold")#list
+ (/"net")#off("bold")# angezeigt werden.
+
+ In jeder Task kann durch das Kommando #on("bold")#list (/"net port")#off("bold")# eine bersicht ber
+ die momentan laufenden Netzbertragungen der eigenen Station erhalten
+ werden.
+
+
+#type("triumb12")#5. Eingriffsmglichkeiten #type("trium8")#
+#headodd#
+
+#center#Eingriffsmglichkeiten#right#%
+
+
+#end#
+
+5.1 Jede Task kann Sende- und Empfangsstrme, die bei #on("bold")#list (/"net port")#off("bold")# gemel-
+ det worden sind und die eigene Task betreffen, abbrechen. Hierzu ist das
+ Kommando #on("bold")#erase ("x",/"net port")#off ("bold")# zu geben, wobei x die Stromnummer (aus
+ dem 'list') ist.
+
+ Unberechtigte Lschversuche werden abgewiesen.
+
+ Von der Task 'net' aus knnen jedoch damit beliebige Strme abgebrochen
+ werden.
+
+5.2 Durch das Kommando #on("bold")#start#off("bold")# kann von der Task 'net' aus das Netz neu gestartet
+ werden. Dabei werden alle augenblicklichen Netzkommunikationen gelscht.
+ Die Tasks 'net port' und 'net timer' werden dabei gelscht und neu eingerich-
+ tet.
+
+ #on("bold")#start (kanal, quit)#off("bold")# wirkt wie #on("bold")#start#off("bold")#. Zustzlich wird als Netzkanal 'kanal' eingestellt
+ und maximal 'quit' Empfangsstrme zugelassen. 'quit' ist auf 3 zu setzen,
+ wenn der Kanal ohne RTS/CTS angeschlossen ist (siehe 3.2).
+
+
+#type("triumb12")#6. Fehlersuche im Netz #type("trium8")#
+
+ Fehler im Netz knnen sich verschiedenartig auswirken. Im Folgenden wird auf
+ einige Beispiele eingegangen:
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Station 4 antwortet nicht'.
+
+ Fehlermglichkeiten:
+
+ - Station 4 gibt es nicht am Netz.
+ Abhilfe: Richtige Station angeben.
+
+ - Station 4 ist nicht eingeschaltet.
+ Abhilfe: Station 4 einschalten. Kommando erneut geben.
+
+ - Netztask an Station 4 ist nicht arbeitsfhig.
+ Abhilfe: Kommando 'start' in der Task 'net'.
+
+ - Stationsnummern und Boxnummern stimmen nicht berein.
+ Abhilfe: Mit 'define station' Stationsnummern korrigieren (siehe 3.2).
+
+ - Verbindung Rechner/Box am eigenen Rechner oder an Station 4 fehlt.
+ Abhilfe: Verbindungen berprfen. Durch Ansprechen einer dritten Station
+ kann oft schnell geklrt werden, welche Rechner/Box-Verbindung
+ defekt sein mu.
+
+ - Verbindung der Boxen untereinander defekt.
+ Abhilfe: Fehlende Verbindung, Masseschlu und Dreher (keine 1:1 Ver-
+ bindung) berprfen und beheben.
+ Hinweis: Liegt z.B. ein Masseschlu vor, so kann es durchaus sein, da
+ Boxen, die nicht in der Nhe des Masseschlu stehen noch mitei-
+ nander arbeiten knnen. Man kann aus der Tatsache, da zwei
+ Boxen miteinander arbeiten knnen, also nicht schlieen, da man
+ nicht nach diesem Fehler suchen mu.
+
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt keine Reaktion.
+
+
+ - Station 4 ist whrend dieser Sendung zusammengebrochen.
+ Abhilfe: Station 4 wieder starten. Die Bearbeitung des 'list'-Kommandos
+ wird automatisch wieder aufgenommen.
+
+ - PUBLIC auf Station 4 ist nicht im Managerzustand.
+ Abhilfe: PUBLIC in den Managerzustand versetzen.
+
+
+ Hinweis: Das Netz hat nocht nicht die volle Sendungslogik des EUMEL. So
+ wird nur ca. 10 Minuten lang versucht, eine Sendung zuzustellen.
+ Danach wird die Sendung gelscht. Ist dies eingetreten, so mu
+ das list-Kommando erneut gegeben werden.
+
+ - Fehler in der Netzhardware.
+ berprfen Sie, ob
+
+ - die Boxen eingeschaltet sind,
+ - die Bereitlampe blinkt (wenn nicht: RESET an der Box)
+ - die V24-Kabel richtig stecken,
+ - die Boxen untereinander verbunden sind (1 zu 1 Verbindungen der 5
+ poligen Diodenbuchsen).
+
+
+ - Die Netzsoftware ist auf einen nicht vorhergesehenen Fehler gelaufen.
+ Dieser wird im Report vermerkt.
+ Abhilfe: Geben Sie in der Task #on("bold")#net#off("bold")# das Kommando #on("bold")#start#off("bold")#. Dadurch wird die
+ Netzsoftware neu gestartet. Alle Netzkommunikationen dieser
+ Station gehen verloren.
+
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Collectortask fehlt'.
+
+ - In der Task 'configurator' wurde das Kommando 'define collector' (siehe 3.2)
+ nicht gegeben.
+
+ - Die Task 'net port' existiert nicht mehr.
+ Abhilfe: Kommando 'start' in der Task 'net'.
+
+
+ Beispiel:
+
+ Nach #on("bold")#fetch ("hugo",4/public)#off("bold")# sind Teile von der Datei "hugo" verflscht.
+
+ - Die V24-Verbindung zur Box ist nicht in Ordnung.
+ Abhilfe: Abstand zwischen Rechner und Box verkrzen; Baudrate ernie-
+ drigen; Durch Wechseln der V24-Schnittstelle feststellen, ob
+ diese defekt ist.
+ Hinweis: Die Verbindung zwischen den Boxen ist durch Prfsummen abge-
+ sichert (Hardware).
+
+#headodd#
+
+#center#Teil 2: Arbeitsweise der Netzsoftware#right#%
+
+
+#end#
+#page#
+#type("triumb12")#
+
+Teil 2: Arbeitsweise der Netzsoftware
+
+
+1. Die Netztask #type ("trium8")#
+
+In diesem Kapitel wird beschrieben, wie eine Netztask in das System
+eingebettet ist und welche Aufgaben sie hat. Unter Einhaltung dieser
+Konzepte kann die ausgelieferte Netztask so gendert werden, da sie
+beliebige andere Netzhardware untersttzt. Z.Zt. ist die Netzsoftware noch
+nicht so gegliedert, da nur eine hardwareabhngige Komponente ausgetauscht
+werden mu.
+
+Die Kommunikation zwischen Tasks im EUMEL-Betriebssystem basiert auf einem
+Rendevouskonzept: Die Zieltask einer Sendung mu empfangsbereit sein, wenn die
+Quelltask sendet.
+
+Die Kommunikationsprozeduren auf der niedrigsten Ebene sind 'send' (Senden)
+und 'wait' (Warten auf Empfang). Bei der Kommunikation werden eine Integer
+'code' und ein Datenraum 'dr' bergeben. 'code' mu >= 0 sein, da negative
+Codes systemintern verwandt werden. Ist die empfangende Task an einen Kanal
+gekoppelt ('continue'), so fhrt eine Zeicheneingabe auf diesem Kanal dazu,
+da eine
+Sendung mit dem Code -4 ankommt. Die Eingabedaten mssen mit den blichen
+Eingabeprozeduren ('inchar' u.s.w.) abgeholt werden. Der bermittelte Datenraum
+und die Absendertask sind dabei ohne Bedeutung und drfen nicht interpretiert
+werden.
+
+Die Prozedur 'send' hat einen Rckmeldeparameter, der besagt, ob die Sendung
+bermittelt wurde. Gibt es die Zieltask nicht oder steht sie nicht im 'wait', so kann
+die Sendung nicht bermittelt werden.
+
+
+Ein Entwicklungskriterium fr das EUMEL-Netz war es, mglichst wenig Unter-
+sttzung von der virtuellen EUMEL-Maschine (EUMEL0) zu fordern, damit weit-
+gehend in ELAN programmiert werden kann. Dadurch ist es mglich eine (privili-
+gierte) Task mit der Netzabwicklung zu betrauen.
+
+Zunchst wird auf die EUMEL0-Untersttzung eingegangen:
+
+1.1. Es gibt die Prozedur 'define collector', mit der die fr das Netz verantwort-
+ liche Task der EUMEL0-Maschine bekannt gemacht wird. Diese Task wird im
+ folgenden Collector genannt.
+
+1.2. Es gibt die Prozedur 'define station', die fr den Rechner eine Stationsnum-
+ mer einstellt. Anhand dieser Nummer werden die Rechner eines Netzes un-
+ terschieden. Das Einstellen bewirkt, da fr alle Tasks die Stationsnummer in
+ ihre Task-Id eingetragen wird (Task-Id's sind die Werte, die der Typ TASK
+ annehmen kann).
+
+1.3. Der Befehl 'station (task)' liefert die Stationsnummer der 'task'. So liefert z.B.
+ 'station (myself)' die Stationsnummer des eigenen Rechners.
+
+1.4. Eine Sendung, deren Zieltask in einem anderen Rechner liegt (also station
+ (ziel) <> station (myself)), wird auf die Collectortask geleitet.
+
+1.5. Es gibt eine Prozedur 'collected destination', die es dem Collector erlaubt, die
+ eigentliche Zieltask einer auf ihn geleiteten Sendung zu erfahren.
+
+1.6. Es gibt eine Variante der Prozedur 'send', die es dem Collector gestattet, der
+ Zieltask eine beliebige andere Task als Absender vorzumachen.
+
+1.7. Es gibt eine spezielle Task-Id 'collector', durch die der augenblicklich ein-
+ gestellte Collector erreicht wird. Diese wird als Zieltask beim Aufruf der Ver-
+ mittlungsdienste angegeben (siehe 2.5). Eine Sendung an 'collector' wird von
+ EUMEL0 an den derzeitigen Collector geschickt.
+
+Ein Collector kann also auf drei Wegen von den brigen Tasks desselben Rechners
+Sendungen erhalten:
+
+ 1. ber ein normales Send (z.B. bei 'list (/"net port")', wenn "net port" der der-
+ zeitige Collector ist),
+
+ 2. ber ein Send an die Task 'collector' (s.u.) und
+
+ 3. als umgeleitete Sendung (z.B. bei 'list' an eine Task auf einem anderen
+ Rechner).
+
+Der Collector kann diese Flle anhand von 'collected destination' unterscheiden.
+
+Die Punkte 1.4...1.6 dienen dazu, den Collector fr ber Netz kommunizierende
+Task unsichtbar zu machen: Der Collector taucht nicht als Ziel oder Quelle von
+Sendungen auf. Das ist notwendig, damit normale Tasks sich nicht darum kmmern
+mssen, ob eine Sendung bers Netz geht oder im eigenen Rechner bleibt.
+
+Wenn ein Datenraum an einen anderen Rechner geschickt wird, mu der gesamte
+Inhalt (z. Zt. max. 1 MB) bertragen werden. Dies macht bei der blichen Netz-
+hardware eine Zerlegung in Packete ntig (siehe Systemhandbuch 173, Teil 4,
+Punkt 5). Fr Netze ber V24-Kanle stehen spezielle Blockbefehle zur verf-
+gung:
+
+1.8. blockin / blockout (dr,seite,512+abstand,anzahl,rest)
+
+ Es werden maximal 'anzahl' Bytes transferiert. In 'rest' wird zurckgemeldet,
+ wieviel Bytes nicht bearbeitet wurden (z.B. weil der Kanal nichts anliefert).
+ Bearbeitet werden die Bytes
+
+ 'seite' * 512 + 'abstand'
+
+ bis maximal
+
+ 'seite' * 512 + 'abstand' + 'anzahl' - 1
+
+ Der Kanal, an den die Task gekoppelt ist, wird dabei ber Stream-IO (d.h.
+ 'incharety' bei 'blockin' bzw. 'out' bei 'blockout') angesprochen.
+
+ Hinweis: Die Anforderung darf nicht ber Seitengrenze gehen, d.h.
+
+ 'abstand' + 'anzahl' <= 512
+
+ mu erfllt sein.
+
+
+Eine Netzsendung luft wie folgt ab:
+
+Die Task q auf Rechner rq mache ein 'send' an die Task z auf Rechner rz.
+
+1. Die Prozedur send ist ein EUMEL0-Befehl. Die EUMEL0-Ebene erkennt, da
+ die Sendung an die Station rz geht, da die Stationsnummer in der Task-Id
+ enthalten ist. Daher wird die Sendung zum Collector, den EUMEL0 wegen 'de-
+ fine collector' kennt, umgeleitet.
+
+2. Die Task Collector empfngt ber 'wait' den Datenraum, den Sendecode und
+ die Absendertask q. Die Zieltask z erfhrt sie durch 'collected destination'.
+
+3. Der Collector nimmt Kontakt mit dem Collector des Rechner rz, dessen Sta-
+ tionsnummer ja 'station(z)' ist, auf und bermittelt diesem Sendecode, Quelltask
+ (q), eigentliche Zieltask (z) und den Datenraum. Da die Collectoren in ELAN
+ geschrieben sind, knnen sie an beliebige Netzhardware und Protokolle ange-
+ pat werden.
+
+4. Der Collector auf Rechner rz verwendet das spezielle 'send', um der Zieltask die
+ Sendung zuzustellen. Dadurch erscheint nicht der Collector sondern die Task q
+ als Absender der Sendung.
+
+Zur Abwicklung der Vermittlungsebene (Teil 1: 2.4) mu der Collector noch
+spezielle Funktionen beherrschen. Diese sind
+
+ der /-Operator (Taskname in Task-Id wandeln) und
+ die name-Prozedur (Task-Id in Namen wandeln).
+
+Der /-Operator macht eine Sendung an den 'collector', wobei im Datenraum der
+Name der Task steht und der Sendecode gleich der Stationsnummer ist (siehe
+Quellcode 173, Packet tasks). Der Collector setzt sich mit dem Collector dieser Sta-
+tion in Verbindung, damit dieser die Task-Id ermittelt und zurckschickt. Der
+eigene Collector schickt dann dem /-Operator als Antwort einen Datenraum, der
+die Task-Id enthlt.
+
+Umgekehrt luft 'name' ab: Wenn die Task-Id von einer fremden Station ist,
+schickt 'name' eine Sendung an den 'collector', wobei im Datenraum die Task-Id
+steht und Sendecode = 256 ist. Der Collector entnimmt die Stationnummer der
+Task aus der Task-Id und lt sich vom entsprechenden Collector den Tasknamen
+geben. Dieser wird der 'name'-Prozedur im Antwortdatenraum bergeben.
+
+#type ("triumb12")#2. Ebenen #type("trium8")#
+
+In diesem Kapitel werden die Protokollebenen fr das Netz beschrieben, wie
+sie die ausgelieferte Netzsoftware benutzt und erwartet. Bei anderer
+Netzhardware mssen die Ebenen 1 bis 3 ausgetauscht werden. Unter Einhaltung
+der im vorigen Kapitel beschriebenen Randbedingungen knnen auch die hheren
+Ebenen gendert werden.
+
+
+2.1 Physikalische Ebene
+
+ 2.1.1 Station <--> Box
+
+ V24-Schnittstelle mit RTS/CTS-Handshake. Vollduplex.
+
+ 2.1.2 Box <--> Box
+
+ RS422 ber 2 verdrillte Leitungspaare (Takt und Daten).
+
+2.2 Verbindungsebene
+
+ 2.2.1 Station <--> Box
+
+ Asynchron
+ 8 Bit
+ Even Parity
+ 2400/4800/9600/19200 Baud (einstellbar ber Ltbrcken)
+
+ 2.2.2 Box <--> Box
+
+ SDLC
+ 400 KBaud
+
+2.3 Netzebene
+
+ 2.3.1 Station <--> Box
+
+ Telegrammformat: STX, <n>, <ziel>, <quelle>, <(n-4) byte>
+
+ <n> ist Lngenangabe ( 8 <= n <= 160)
+ <ziel>, <quelle> sind Stationsnummern. Diese mssen an den je-
+ weiligen Boxen ber Ltbrcken eingestellt sein.
+
+ Box --> Station:
+
+ Ein Telegramm kommt nur bei der Station an, bei deren Box die
+ Nummer <ziel> eingestellt ist. Dadurch ist ein Mithren fremder
+ bertragungen nicht mglich (Datenschutz).
+
+ Zwischen Telegrammen knnen Fehlermeldungen der Box (Klartext)
+ bermittelt werden (z.B. 'skipped x', wenn ein STX von der Box er-
+ wartet wurde, aber 'x' von der Station ankommt).
+
+ Station --> Box:
+
+ Ein Telegramm wird nur abgeschickt, wenn <quelle> mit der einge-
+ stellten Nummer bereinstimmt (Datenschutz: Man kann nicht eine
+ beliebige Station zu sein vorschwindeln, es sei denn man hat physi-
+ schen Zugriff zur Box und stellt dort die Stationsnummer um).
+
+ 2.3.2 Box <--> Box
+
+ Telegrammformat: FRAME, <ziel>, <quelle>, <daten> ,
+ <CRC-Code>
+
+ Eine Lngenangabe ist nicht ntig, da SDLC eine Rekonstruktion der
+ Lnge erlaubt.
+
+ Telegramme mit falschen CRC-Code werden vernichtet. Auf hheren
+ Ebenen mu dies durch Zeitberwachung erkannt und behandelt
+ werden.
+
+
+2.4 Transportebene
+
+ Diese Ebene wickelt das Rendevous zwischen einer Task, die 'send' macht,
+ und einer Task, die im 'wait' steht, ab (siehe: EUMEL-Systemhandbuch).
+
+ Der im 'send' angegebene Datenraum wird als Folge von Seiten (im
+ EUMEL-Sinne: Pagingeinheit und Allokiereinheit) bermittelt, wobei jede Seite
+ noch in 64 Byte groe Stcke zerlegt wird. Es werden nur echt allokierte Seiten
+ bermittelt. Um nicht jedes Telegramm voll qualifizieren zu mssen, wird
+ zunchst eine Art virtuelle Verbindung durch ein OPEN-Telegramm erffnet.
+ Danach folgen variable viele DATA-Telegramme. Beide Sorten werden durch
+ QUIT-Telegramme quittiert, um folgende Funktionen zu ermglichen:
+
+ Flukontrolle (z.B. Zielrechner langsam)
+ Wiederaufsetzen (verlorene Telegramme)
+ Abbruch (z.B. weil Zieltask inzwischen beendet).
+
+ Ein CLOSE-Telegramm ist nicht ntig, da das letzte DATA-Telegramm als
+ solches erkannt werden kann (siehe unten).
+
+ 2.4.1 OPEN-Telegramm
+
+ STX, 20, <ziel>, <quelle>, <strom>, <sequenz>, <seite>,
+ <quelltask>, <zieltask>, <code>
+
+ <ziel>, <quelle> siehe 2.3.1
+
+ <strom> Die Stromnummer identifiziert die virtuelle Verbindung.
+ Sie mu in den QUIT-Telegrammen angegeben wer-
+ den.
+
+ <sequenz> -1 (Kennzeichen fr OPEN)
+
+ <seite> Nummer der ersten echt allokierten Seite des Datenra-
+ ums (=-1, falls Nilspace)
+
+ <quelltask> Taskid der sendenden Task
+
+ <zieltask> Taskid der empfangenden Task
+
+ <code> Wert des im 'send' angegebenen Codes.
+
+ 2.4.2 DATA-Telegramm
+
+ STX, 74, <ziel>, <quelle>, <sequenz>, <seite>, <64 byte>
+
+ <sequenz> wird von Telegramm zu Telegramm hochgezhlt. Dient
+ der berwachung gegen verlorengegangene Telegramme
+ bzw. durch Zeitberwachung verdoppelter Telegramme.
+
+ <seite> Nummer der x.ten echt allokierten Seite des Datenra-
+ ums. (x = (<sequenz>+16) DIV 8).
+
+ <64 byte> Nutzinformation. Diese gehrt zur Adresse a des Daten-
+ raums.
+
+ a = N (<sequenz> DIV 8 + 1) * 512
+ + (<sequenz> MOD 8) * 64
+
+ wobei N (x) die Nummer der x.ten Seite ist.
+
+ Aus den Formeln ergibt sich, da diese Nummer schon in
+ einem vorhergehenden DATA/OPEN-Telegramm ber-
+ mittelt wurde (im Feld <seite>).
+
+ 2.4.3 QUIT-Telegramm
+
+ STX, 8, <ziel>, <quelle>, <strom>, <quit>
+
+ <strom> mu die Stromnummer sein, die in dem OPEN/DATA-
+ Telegramm stand, das quittiert wird.
+
+ <quit> 0 : ok. Nchstes Telegramm schicken.
+
+ -1: bertragung neu starten (mit OPEN), weil die
+ Empfangsstation das OPEN nicht erhalten hat.
+
+ -2: bertragung ca. 20 Telegramme zurcksetzen.
+
+ -3: bertragung abbrechen.
+
+
+2.5 Vermittlungsebene
+
+ Diese Ebene ist dafr zustndig, Tasknamen von Task auf anderen Stationen
+ in Taskids (Werte des Typs TASK) zu wandeln und umgekehrt. Hierzu wird im
+ entsprechenden OPEN-Telegramm der Code -6 (bzw. -7) als <code>
+ eingetragen. Die Netzempfangstask erkennt diese Codes und wickelt die
+ Aufgaben selbst ab, soda es dabei nicht ntig ist, irgendeine Taskid der
+ Zielstation zu kennen.
+
+ Dieses Verfahren ist mglich, weil im 'send' nur positive Codes erlaubt sind.
+
+2.6 Hhere Ebenen
+
+ Hhere Ebenen sind nicht mehr netzspezifisch. Sie basieren alle auf dem
+ Send/Wait-Konzept des EUMEL. So gibt es z.B. den 'global manager', der
+ Aufbewahrung und Zugriff von Dateien in einer Task regelt. Dabei darf diese
+ Task (bei der Variante 'free global manager') auf einer beliebigen Station im
+ Netz liegen. Wegen des Rendevous-Konzepts knnen beliebige Sicherheit-
+ strategien benutzt werden (z.B.: Keine Dateien an Station 11 ausliefern). Von
+ groen Wert ist z.B., da man ohne weiteres das Archiv (Floppylaufwerk) einen
+ anderen Station anmelden und benuzten kann, wodurch eine einfache Kon-
+ vertierung von Floppyformaten mglich ist. Dies ist mglich, weil auch die Ar-
+ chiv-Task der Stationen sich an das Globalmanagerprotokoll halten.
+
+
+#type("triumb12")#
+Bemerkungen#type("trium8")#
+
+Fehlerbehandlung besteht bis Ebene 3 darin, fehlerhafte Telegramme einfach zu
+entfernen. Die Ebene 4 berwacht den Netzverkehr sowieso ber Timeouts, die
+eine Wiederhohlung eines Telegrammes bewirken, wenn die Quittung ausbleibt.
+
+Da bei der sendenden Station der ganze Datenraum zur Verfgung steht, ist eine
+Fenstertechnik (wie bei HDLC) nicht ntig. Es kann zu jedem Zeitpunkt um beliebig
+viele Telegramme zurckgesetzt werden.
+
+Da im EUMEL eine Textdatei ein Datenraum mit sehr komplexer Struktur ist (wegen
+der Insert/Delete-Mglichkeiten, ohne den Rest der Datei zu schieben), ist es ein
+hoher Aufwand, von einem fremden Betriebssytem her Textdateien ins EUMEL-
+Netz zu senden. Fr solche Zwecke mu noch eine einfachere Dateistruktur defi-
+niert werden und entsprechende Dateikonverter erstellt werden.
+
+
+
+#type("triumb12")#3. Stand der Netzsoftware #type("trium8")#
+
+Das EUMEL-System wickelt die Prozedur #on("bold")#send#off("bold")# ber das Netz ab, wenn die
+Stationsnummer der Zieltask ungleich der eigenen Stationsnummer ist. Umge-
+kehrt kann man der von der Prozedur #on("bold")#wait#off("bold")# gelieferten Absendertask die Absen-
+derstation entnehmen (siehe Prozedur #on("bold")#station#off("bold")# in Abschnitt 3).
+
+Nicht untersttzt wird z.Zt. die Logik der Prozeduren #on("bold")#call#off("bold")# und #on("bold")#pingpong#off("bold")#. Diese
+funktionieren nur in der gewohnten Weise, wenn die Zieltask in #on("bold")#wait#off("bold")# steht. Ist
+die Zieltask lnger als ca. 10 Minuten #on("bold")#busy#off("bold")# oder nicht mehr vorhanden, geht die
+Sendung einfach verloren (Gefordert ist: bei #on("bold")#call#off("bold")#: immer wieder versuchen; bei #on("bold")#
+pingpong#off("bold")#: Rckmeldung -2).
+
+Wegen dieser Einschrnkung kann man z.B. ein sicheres Drucken von Station a
+auf einen Drucker der Station b nur durch einen eigenen Spoolmanager auf
+Station a verwirklichen. Die Einrichtung eines solchen Managers ist allerdings
+sowieso sinnvoll, damit man
+
+- das normale 'print'-Kommando verwenden kann (statt z.B. save ("xxx",
+4/printer);) und
+- nicht zu warten braucht, bis die Datei bers Netz gesendet ist.
+
+
+
+
+
diff --git a/system/net/1.7.5/src/basic net b/system/net/1.7.5/src/basic net new file mode 100644 index 0000000..41c8402 --- /dev/null +++ b/system/net/1.7.5/src/basic net @@ -0,0 +1,840 @@ +PACKET basic net DEFINES (* D. Heinrichs *)
+ (* 02.10.85 *)
+ nam,
+ max verbindungsnummer,
+ neuer start,
+ packet eingang,
+ neue sendung,
+ zeitueberwachung,
+ verbindung,
+ loesche verbindung:
+
+TEXT PROC nam (TASK CONST t):
+ IF t = collector THEN name (t)
+ ELIF station (t) <> station (myself)
+ THEN "** fremd **"
+ ELSE name (t)
+ FI
+END PROC nam;
+
+INT PROC tasknr (TASK CONST t):
+ IF t = collector THEN maxtasks
+ ELSE index (t)
+ FI
+END PROC tasknr;
+
+LET
+ maxtasks = 127,
+ max strom = 20,
+ max strom 1 = 21,
+ stx = ""2"",
+ code stx = 2,
+ ack = 0,
+ nak = 1,
+ error nak = 2,
+ zeichen eingang = 4,
+ list code = 15,
+ fetch code = 11,
+ inspect code = 30,
+ continue code = 100,
+ erase code = 14,
+ report code = 99,
+ seiten groesse = 512,
+ dr verwaltungslaenge = 8,
+ dr verwaltungslaenge2=10,
+ nutzlaenge = 64,
+ openlaenge = 20,
+ vorspannlaenge = 10,
+ neue ack laenge = 10,
+ ack laenge = 8,
+
+ (* Typen von Kommunikationsstrmen *)
+
+ send wait = 0,
+ zustellung = 1,
+ call pingpong = 2,
+ call im wait = 3,
+ call im abbruch = 4,
+ call in zustellung = 5,
+
+ (*quittungscodes*)
+
+ ok = 0,
+ von vorne = 1,
+ wiederhole = 2,
+ loesche = 3,
+ beende = 4;
+
+LET STEUER =
+ STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ sequenz,
+ seitennummer,
+ TASK quelle,ziel,
+ INT sende code);
+
+BOUND STEUER VAR open block;
+
+BOUND STRUCT (STEUER steuer, INT typ) VAR info block;
+
+BOUND STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ sequenz,
+ seitennummer) VAR vorspann ;
+
+BOUND STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ code) VAR ack packet ;
+
+INT CONST max verbindungsnummer := max strom;
+
+BOOL PROC blockin (DATASPACE VAR ds, INT CONST seite, abstand, laenge):
+ INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512;
+ REAL VAR time out := clock (1) + 10.0;
+ REP
+ blockin (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge);
+ UNTIL hilfslaenge = 0 OR clock (1) > time out PER ;
+ hilfslaenge = 0
+END PROC blockin;
+
+PROC blockout (DATASPACE CONST ds, INT CONST seite, abstand, laenge):
+ INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512;
+ REP
+ blockout (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge);
+ UNTIL hilfslaenge = 0 PER
+END PROC blockout;
+
+
+
+
+DATASPACE VAR work space;
+
+
+INT CONST packete pro seite:= seitengroesse DIV nutzlaenge,
+ packete pro seite minus 1 := packete pro seite -1,
+ datenpacketlaenge := vorspannlaenge + nutzlaenge;
+
+INT VAR err,strom;
+
+INT VAR own:=station (myself) ,
+ quit max := 3,
+ quit zaehler := 3,
+ own256 := 256*own;
+INT CONST stx open := code stx+256*openlaenge,
+ stx quit := code stx+256*acklaenge;
+
+ ROW maxstrom1 STEUER VAR verbindungen;
+ ROW maxstrom1 DATASPACE VAR netz dr;
+ ROW maxstrom1 INT VAR zeit, typ;
+ FOR strom FROM 1 UPTO maxstrom1 REP vdr := nilspace; forget (vdr) PER;
+ ROW maxstrom INT VAR dr page ;
+ ROW maxtasks INT VAR alter call;
+ STEUER VAR opti;
+
+.vx : verbindungen (strom).
+
+vdr: netz dr (strom).
+
+falsche stromnummer: strom < 1 OR strom > maxstrom.
+
+call aufruf: typ(strom) >= call pingpong.
+
+alles raus: vx.seitennummer = -1 AND letztes packet der seite .
+
+letztes packet der seite :
+(vx.sequenz AND packete pro seite minus 1) = packete pro seite minus 1.
+
+PROC neuer start (INT CONST empfangsstroeme):
+ workspace := nilspace;
+ open block := workspace;
+ info block := workspace;
+ vorspann := workspace;
+ ack packet := workspace;
+ FOR strom FROM 1 UPTO maxstrom1 REP
+ vx.strom := 0; forget (vdr)
+ PER;
+ INT VAR i;
+ FOR i FROM 1 UPTO maxtasks REP alter call (i) := 0 PER;
+ quitmax := empfangsstroeme;
+ own:=station (myself);
+ quit zaehler := quit max;
+ own256 := 256*own;
+ reset box.
+
+reset box:
+ out (90*""4"");
+ REP UNTIL incharety (1) = "" PER.
+
+END PROC neuer start;
+
+DATASPACE PROC verbindung (INT CONST nr):
+ infoblock.steuer := verbindungen (nr);
+ infoblock.typ := typ (nr);
+ workspace
+END PROC verbindung;
+
+PROC neue sendung (TASK CONST q,z, INT CONST cod, DATASPACE CONST dr):
+
+ naechste verbindung vorbereiten;
+ forget (vdr); vdr := dr;
+ IF z = collector
+ THEN
+ verbindungsebene
+ ELSE
+ sendung starten (q,z,cod)
+ FI.
+
+verbindungsebene:
+ IF cod = 256 THEN name von fremdstation
+ ELIF cod > 256
+ THEN
+ taskinfo fremd
+ ELSE
+ task id von fremd
+ FI.
+
+taskinfo fremd: sendung starten (q, collector, cod-256, -8).
+
+task id von fremd: sendung starten (q,collector, zielstation,-6) .
+
+name von fremdstation:
+ BOUND TASK VAR tsk := vdr;
+ TASK VAR tsk1 := tsk;
+ forget (vdr);
+ vdr := nilspace;
+ sendung starten (q, tsk1, -7).
+
+zielstation: cod.
+
+END PROC neue sendung;
+
+PROC zeitueberwachung
+ (INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ snr INCR 1;
+ FOR strom FROM snr UPTO maxstrom REP zeitkontrolle PER;
+ snr := 0.
+
+zeitkontrolle:
+ IF vx.strom <> 0 AND zeit(strom) > 0
+ THEN
+ zeit(strom) DECR 1;
+ IF sendung noch nicht zugestellt
+ THEN
+ IF zeit(strom) = 0 THEN
+ report ("Nicht zustellbar. """+nam (vx.ziel)+""". "+
+ text (vx.rechnernummernDIV256));
+ loesche verbindung (strom)
+ ELSE
+ snr := strom;
+ q := vx.quelle;
+ z := vx.ziel;
+ ant := vx.sendecode;
+ dr := vdr;
+ LEAVE zeitueberwachung
+ FI
+ ELIF zeit(strom) = 0 THEN wiederholen FI
+ FI.
+
+sendung noch nicht zugestellt:
+ typ (strom) = zustellung.
+
+wiederholen:
+ IF sendeeintrag
+ THEN
+ sendung wiederholen
+ ELSE
+ empfangseintrag freigeben
+ FI.
+
+sendeeintrag : vx.rechnernummern DIV 256 = own .
+
+sendung wiederholen:
+ IF wiederholung noch sinnvoll
+ THEN
+ IF frisch
+ THEN
+ time out bei open
+ ELSE
+ datenteil wiederholen
+ FI
+ ELSE
+ sendung loeschen
+ FI.
+
+wiederholung noch sinnvoll:
+ task noch da AND bei call noch im call.
+
+task noch da: vx.quelle = collector OR exists (vx.quelle).
+
+bei call noch im call:
+ IF call aufruf
+ THEN
+ callee (vx.quelle) = vx.ziel
+ ELSE
+ TRUE
+ FI.
+
+frisch: vx.sequenz = -1.
+
+time out bei open:
+ IF vx.sendecode > -4 THEN open wiederholen ELSE nak an quelle senden FI.
+
+nak an quelle senden:
+ forget (vdr); vdr := nilspace;
+ BOUND TEXT VAR erm := vdr;
+ erm := "Station "+text(vx.rechnernummernMOD256)+" antwortet nicht";
+ snr := strom;
+ q := collector;
+ z := vx.quelle;
+ ant := error nak;
+ dr := vdr;
+ sendung loeschen;
+ LEAVE zeitueberwachung .
+
+open wiederholen:
+ sendereport ("wdh open");
+ zeit(strom) := 20;
+ openblock := vx;
+ openblock.head := stx open;
+ ab die post.
+
+datenteil wiederholen:
+ sendereport ("wdh data. sqnr "+text (vx.sequenz));
+ senden .
+
+empfangseintrag freigeben:
+ IF antwort auf call
+ THEN
+ weiter warten
+ ELSE
+ empfangsreport ("Empfangseintrag freigegeben");
+ empfang loeschen
+ FI.
+antwort auf call: callee (vx.ziel) = vx.quelle.
+
+weiter warten: zeit (strom) := 200.
+
+END PROC zeitueberwachung;
+
+PROC sendereport (TEXT CONST txt):
+ report (text (strom)+":"+txt+". Absender: """+nam (vx.quelle)+
+ """. Ziel "+text(vx.rechnernummernMOD256));
+END PROC sendereport;
+
+PROC empfangsreport (TEXT CONST txt):
+ report (text (strom)+":"+txt+". Empfnger: """
+ +nam (vx.ziel)+""". Quelle "+text (vx.rechnernummernDIV256));
+END PROC empfangsreport ;
+
+PROC sendung loeschen:
+ IF callaufruf CAND alter call (tasknr (vx.quelle)) = strom
+ THEN
+ alter call (tasknr (vx.quelle)) := 0
+ FI;
+ vx.strom := 0;
+ forget (vdr)
+END PROC sendung loeschen;
+
+PROC empfang loeschen:
+ quit zaehler INCR 1;
+ IF callaufruf AND alter call (tasknr (vx.ziel)) = strom
+ THEN
+ alter call (tasknr (vx.ziel)) := 0
+ FI;
+ forget (vdr);
+ vx.strom := 0
+END PROC empfang loeschen;
+
+PROC loesche verbindung (INT CONST nr):
+ strom := nr;
+ IF sendeeintrag
+ THEN
+ sendung loeschen
+ ELSE
+ gegenstelle zum loeschen auffordern;
+ empfang loeschen
+ FI.
+
+gegenstelle zum loeschen auffordern:
+ IF verbindung aktiv THEN quittieren (-loesche) FI.
+
+verbindung aktiv: vx.strom > 0.
+
+sendeeintrag: vx.rechnernummern DIV 256 = own .
+
+END PROC loesche verbindung;
+
+PROC weiter senden:
+ IF NOT alles raus
+ THEN
+ sequenz zaehlung;
+ IF neue seite THEN seitennummer eintragen FI;
+ senden
+ FI.
+
+sequenz zaehlung:
+ vx.sequenz INCR 1.
+
+neue seite:
+ (vx.sequenz AND packete pro seite minus 1) = 0.
+
+seitennummer eintragen:
+ dr page (strom) := vx.seiten nummer;
+ vx.seitennummer := next ds page (vdr, dr page (strom)).
+
+
+END PROC weiter senden;
+
+PROC senden:
+ zeit(strom) := 3;
+ vorspann senden;
+ daten senden.
+
+vorspann senden:
+ openblock := vx;
+ blockout (workspace, 1, dr verwaltungslaenge, vorspannlaenge).
+
+daten senden:
+ blockout (vdr,dr page (strom),distanz,nutzlaenge).
+
+distanz: nutzlaenge* (vx.sequenz AND (packete pro seite minus 1)).
+
+END PROC senden;
+
+PROC naechste verbindung vorbereiten:
+ FOR strom FROM 1 UPTO maxstrom REP
+ UNTIL vx.strom = 0 PER;
+ IF vx.strom <> 0 THEN errorstop ("Verbindungsengpass") FI.
+END PROC naechste verbindung vorbereiten;
+
+PROC sendung starten (TASK CONST quelle, ziel, INT CONST code):
+ sendung starten (quelle,ziel, station(ziel), code)
+END PROC sendung starten;
+
+PROC sendung starten (TASK CONST quelle, ziel, INT CONST ziel station,code):
+ IF ziel station = own
+ THEN
+ report ("Irrlufer: Sendung an eigene Station. Absender:"""+
+ nam (quelle)+""".");
+ vx.strom := 0;
+ forget (vdr)
+ ELSE
+ openblock.ziel := ziel;
+ openblock.quelle :=quelle;
+ openblock.sendecode := code;
+ openblock.rechnernummern:= ziel station + own256;
+ alten call loeschen (quelle);
+ IF call oder ping pong
+ THEN typ (strom) := call pingpong; call merken
+ ELSE typ (strom) := send wait FI;
+ sendung neu starten
+ FI.
+
+call oder pingpong: openblock.ziel = callee (openblock.quelle).
+
+call merken: alter call (tasknr (quelle)) := strom.
+
+END PROC sendung starten;
+
+PROC sendung neu starten:
+ openblock.head:= stx open;
+ openblock.sequenz := -1;
+ openblock.seitennummer:= next ds page (vdr,-1);
+ openblock.strom := strom;
+ vx := open block;
+ zeit(strom) := 3;
+ ab die post;
+ vx.head:=code stx+256*(vorspannlaenge+nutzlaenge).
+
+END PROC sendung neu starten; .
+
+ab die post:
+ block out (work space,1, dr verwaltungslaenge,open laenge).
+
+PROC alten call loeschen (TASK CONST quelle):
+ IF alter call aktiv
+ THEN
+ INT VAR lstrom := strom;
+ vx:=openblock;
+ strom := alter call (tasknr (quelle));
+ IF in ausfuehrungsphase
+ THEN
+ sendereport ("Call-Lschung vorgemerkt");
+ loeschung vormerken
+ ELSE
+ report ("Call gelscht."""+nam(quelle)+""". Strom "+text(strom));
+ loesche verbindung (strom)
+ FI;
+ strom := lstrom;
+ openblock := vx
+ FI.
+
+in ausfuehrungsphase:
+ typ(strom) = call im wait OR typ (strom) = call in zustellung.
+
+loeschung vormerken:
+ typ(strom) := call im abbruch;
+ alter call (tasknr (quelle)) := 0.
+
+
+ alter call aktiv:
+ alter call (tasknr (quelle)) > 0.
+
+END PROC alten call loeschen;
+
+PROC packet eingang
+ (TEXT CONST ft, INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ snr := 0;
+ vorspann holen;
+ IF NOT ring logik THEN daten teil FI.
+
+ring logik: FALSE.
+# IF selbst quelle THEN daten aus puffer entfernen ; TRUE
+ ELIF NOT selbst ziel THEN weitergeben; TRUE
+ ELSE FALSE
+ FI.
+
+selbst quelle: openblock.rechnernummern DIV 256 = station (myself).
+
+selbst ziel: (openblock.rechnernummern AND 255) = own.
+#
+daten aus puffer entfernen:
+ IF code (t) > nutzlaenge
+ THEN
+ BOOL VAR dummy :=blockin (workspace, 1, drverwaltungslaenge, nutzlaenge)
+ FI.
+#
+weitergeben:
+ IF code (t) > nutzlaenge
+ THEN
+ IF NOT blockin (workspace, 2, 0, nutzlaenge)
+ THEN LEAVE test auf packeteingang FI;
+ FI;
+ out (stx+t);
+ blockout (workspace, 1, drverwaltungslaenge2, blocklaenge);
+ IF code (t) > nutzlaenge
+ THEN
+ blockout (workspace, 2, 0, nutzlaenge)
+ FI.
+#
+vorspann holen:
+ sync;
+ IF NOT blockin (workspace, 1, dr verwaltungslaenge2, block laenge)
+ THEN LEAVE packeteingang
+ FI.
+
+
+blocklaenge: IF code t > nutzlaenge
+ THEN
+ vorspannlaenge-2
+ ELSE
+ code t -2
+ FI.
+
+sync:
+ TEXT VAR skipped:=ft , t :="";
+ REP
+ skipped CAT t;
+ t := incharety (1);
+ IF t = "" THEN
+ report ("skipped",skipped);
+ LEAVE packet eingang
+ FI ;
+ INT VAR codet := code (t);
+ UNTIL blockanfang PER;
+ IF skipped <> stx THEN report ("skipped bei sync:", skipped) FI.
+
+blockanfang:
+ (skipped SUB length(skipped)) = stx
+ AND
+ (codet = datenpacketlaenge
+ OR codet = ack laenge OR codet = neue ack laenge OR code t = openlaenge).
+
+daten teil:
+ IF neue verbindung
+ THEN
+ verbindung bereitstellen
+ ELIF quittung
+ THEN
+ strom := ack packet.strom;
+ IF falsche stromnummer THEN report ("Strom falsch in Quittung");
+ LEAVE datenteil FI;
+ IF vx.strom = 0 THEN LEAVE datenteil FI;
+ IF ackpacket.code >= ok THEN weiter senden
+ ELIF ackpacket.code = -von vorne THEN
+ sendereport ("Neustart");
+ openblock := vx;
+ sendung neu starten
+ ELIF ackpacket.code = -wiederhole THEN back 16
+ ELIF ackpacket.code = -loesche THEN fremdloeschung
+ ELIF ackpacket.code = -beende AND alles raus THEN strom abschliessen
+ FI
+ ELIF verbindung festgestellt
+ THEN
+ zeit(strom) := 200;
+ opti := vx;
+ datenpacket
+ ELSE
+ strom := maxstrom1;
+ vx:=openblock;
+ report ("Daten ohne Eroeffnung von " +text(vx.rechnernummernDIV256)
+ +" Sequenznr "+text(openblock.sequenz));
+ daten aus puffer entfernen;
+ IF alles raus THEN quittieren (-beende) ELSE quittieren(-von vorne) FI
+ FI.
+
+verbindung bereitstellen:
+ IF openblock.ziel = collector OR station (openblock.ziel) = own
+ THEN
+ freie verbindungsnummer;
+ vdr := nilspace;
+ vx := open block;
+ zeit(strom) := 10;
+ quittieren falls genug pufferplatz;
+ vx.sequenz := 0 ;
+ IF loeschung vorgemerkt
+ THEN
+ loesche verbindung (strom)
+ ELSE
+ opti := vx;
+ abschluss testen
+ FI;
+ FI.
+
+loeschung vorgemerkt: typ(strom) = call im abbruch.
+
+strom abschliessen:
+ IF call aufruf THEN zeit(strom) := 80; ausfuehrungsphase merken
+ ELSE
+ vx.strom := 0;
+ forget (vdr)
+ FI.
+
+ausfuehrungsphase merken: typ(strom) := call in zustellung.
+
+back16:
+ datenraum etwas rueckspulen;
+ nicht sofort senden (* wegen vagabundierender Quittungen *).
+
+nicht sofort senden: zeit(strom) := 2.
+
+datenraum etwas rueckspulen:
+ sendereport ("etwas rueckgespult");
+ INT VAR sk , vs :=-1;
+ dr page (strom) := -1;
+ INT VAR i;
+ FOR i FROM 1 UPTO vx.sequenz DIV packete pro seite - etwas REP
+ vs INCR packete pro seite;
+ dr page (strom) := next ds page (vdr, dr page (strom))
+ PER;
+ vx.seiten nummer := next ds page (vdr, dr page (strom)) ;
+ vx.sequenz := vs.
+
+etwas: 3.
+
+fremdloeschung:
+ IF fremdrechner ok und sendung
+ THEN
+ IF typ (strom) = call in zustellung
+ THEN
+ typ (strom) := call im wait
+ ELSE
+ sendereport ("Sendung von Gegenstelle geloescht");
+ sendung loeschen
+ FI
+ FI.
+
+fremdrechner ok und sendung:
+ (ackpacket.rechnernummern DIV 256) = (vx.rechnernummern AND 255).
+
+
+quittieren falls genug pufferplatz:
+ IF quit zaehler > 0 THEN
+ quit zaehler DECR 1;
+ open quittieren;
+ block vorab quittieren
+ FI.
+
+open quittieren: quittieren (ok).
+block vorab quittieren: quittieren (ok).
+
+quittung: code t <= neue ack laenge.
+
+neue verbindung: code t = open laenge.
+
+verbindung festgestellt:
+ FOR strom FROM maxstrom DOWNTO 1 REP
+ IF bekannter strom
+ THEN LEAVE verbindung festgestellt WITH TRUE FI
+ PER;
+ FALSE.
+
+bekannter strom:
+ vx.strom = vorspann.strom AND vom selben rechner.
+
+vom selben rechner:
+ vx.rechnernummern = vorspann.rechnernummern.
+
+daten:
+ IF NOT blockin (vdr, opti.seiten nummer, distanz, nutzlaenge)
+ THEN quittieren (-wiederhole); LEAVE packeteingang
+ FI;
+ sequenz zaehlung;
+ IF neue seite kommt
+ THEN
+ vx.seiten nummer := vorspann.seiten nummer
+ FI.
+
+datenpacket:
+ IF sendung wartet auf zustellung THEN auffrischen ELSE daten holen FI.
+
+sendung wartet auf zustellung: typ (strom) = zustellung.
+
+auffrischen: zeit (strom) := 100; daten aus puffer entfernen.
+
+daten holen:
+ IF opti.sequenz >= vorspann.sequenz AND opti.sequenz < vorspann.sequenz+100
+ THEN
+ IF opti.sequenz <> vorspann.sequenz
+ THEN empfangsreport ("Sequenzreset von "+text(opti.sequenz)+" auf "+
+ text (vorspann.sequenz));
+ vx.sequenz := vorspann.sequenz;
+ vorabquittung regenerieren
+ FI;
+ quittieren(ok);
+ daten ;
+ abschluss testen
+ ELSE
+ empfangsreport ("Sequenzfehler: soll "+text(vx.sequenz)+" ist "+
+ text(vorspann.sequenz));
+ quittieren (-wiederhole);
+ daten aus puffer entfernen
+ FI.
+
+vorabquittung regenerieren: quittieren (ok).
+
+distanz: (opti.sequenz AND packete pro seite minus 1 ) * nutzlaenge.
+
+sequenz zaehlung:
+ vx.sequenz INCR 1.
+
+neue seite kommt:
+(vx.sequenz AND packete pro seite minus1) = 0.
+
+freie verbindungsnummer:
+ INT VAR h strom :=0;
+ FOR strom FROM 1 UPTO maxstrom REP
+ IF vx.strom = 0 THEN h strom := strom
+ ELIF bekannter strom
+ THEN empfangsreport ("Reopen");
+ quit zaehler INCR 1;
+ forget (vdr);
+ LEAVE freie verbindungsnummer
+ ELIF antwort auf call
+ THEN
+ typ (strom) := call pingpong;
+ forget (vdr);
+ LEAVE freie verbindungsnummer
+ FI
+ PER;
+ strom := h strom;
+ IF strom = 0 THEN
+ error stop ("Zuviele simulatane Verbindungen")
+ FI;
+ typ(strom) := send wait.
+
+antwort auf call:
+ openblock.sendecode >= 0 AND
+ call aufruf AND vx.quelle = openblock.ziel AND vx.ziel = openblock.quelle.
+
+abschluss testen:
+ IF neue seite kommt AND vx.seiten nummer = -1
+ THEN
+ quittieren (-beende);
+ an ziel weitergeben
+ FI.
+
+an ziel weitergeben:
+ IF tasknummerfrage THEN taskfrage beantworten ;pufferplatz freigeben;
+ ELIF tasknamenfrage THEN name senden ;pufferplatz freigeben;
+ ELIF taskinfofrage THEN task info senden;pufferplatz freigeben;
+ ELSE senden
+ FI.
+
+pufferplatz freigeben: quitzaehler INCR 1.
+
+senden:
+ max 100 versuche;
+ snr := strom;
+ IF NOT callaufruf THEN typ (strom) := zustellung FI;
+ q := vx.quelle;
+ z := vx.ziel;
+ ant := vx.sendecode;
+ dr := vdr;
+ LEAVE packet eingang.
+
+tasknummerfrage:opti.sendecode = -6.
+
+tasknamenfrage: opti.sendecode = -7.
+
+taskinfofrage: opti.sendecode = -8.
+
+max 100 versuche: zeit(strom) := 100.
+
+taskfrage beantworten:
+ BOUND TEXT VAR tsk := vdr;
+ TEXT VAR save tsk := tsk;
+ forget (vdr); vdr := nilspace;
+ BOUND TASK VAR task id := vdr;
+ disable stop;
+ task id := task(save tsk);
+ IF is error THEN
+ clear error; enable stop;
+ forget (vdr); vdr := nilspace;
+ BOUND TEXT VAR errtxt := vdr;
+ errtxt := text(station(myself))+"/"""+save tsk+""" gibt es nicht";
+ sendung starten (collector, opti.quelle, 2)
+ ELSE
+ enable stop;
+ sendung starten (collector, opti.quelle, 0)
+ FI.
+
+name senden:
+ forget (vdr); vdr := nilspace;
+ tsk := vdr;
+ disable stop;
+ tsk := nam (opti.ziel);
+ clear error; enable stop;
+ sendung starten (collector, opti.quelle, 0).
+
+task info senden:
+ BOUND INT VAR ti code := vdr;
+ INT VAR ti cd := ti code;
+ forget (vdr); vdr := nilspace;
+ FILE VAR task inf := sequential file (output,vdr);
+ head line (task inf,"Station "+text(own));
+ task info (ti cd, task inf);
+ sendung starten (collector,opti.quelle,0).
+
+END PROC packet eingang;
+
+PROC quittieren(INT CONST code) :
+ quellrechner wird zielrechner;
+ ackpacket.code := code;
+ ackpacket.head := stx quit;
+ ackpacket.strom := vx.strom;
+ blockout (workspace,1,dr verwaltungslaenge, ack laenge).
+
+quellrechner wird zielrechner:
+ ack packet.rechnernummern := vx.rechnernummern DIV 256
+ + own256.
+
+END PROC quittieren;
+
+END PACKET basic net;
diff --git a/system/net/1.7.5/src/callee b/system/net/1.7.5/src/callee new file mode 100644 index 0000000..42d80da --- /dev/null +++ b/system/net/1.7.5/src/callee @@ -0,0 +1,14 @@ +PACKET callee DEFINES callee:
+
+TASK PROC callee (TASK CONST t):
+ IF im wait THEN trick 1 (t); trick 2 ELSE niltask FI.
+im wait: (status(t) AND 3) = 2.
+END PROC callee;
+
+PROC trick 1 (TASK CONST t):
+ INT VAR x := pcb(t,11), y:=pcb(t,12);
+END PROC trick1;
+
+TASK PROC trick 2: TASK VAR calle; calle END PROC trick2;
+
+END PACKET callee;
diff --git a/system/net/1.7.5/src/net inserter b/system/net/1.7.5/src/net inserter new file mode 100644 index 0000000..8cccedd --- /dev/null +++ b/system/net/1.7.5/src/net inserter @@ -0,0 +1,50 @@ +
+{ Inserter fr EUMEL - Netz - Software; 04.12.83
+ bercksichtigt EUMEL - Versionen 1.7.3 und 1.7.5, sowie Multi / Single }
+
+
+INT VAR version :: id (0), cy :: 4;
+IF online THEN head FI;
+
+IF ich bin multi THEN insert multi net
+ ELSE meldung an single
+FI.
+
+ich bin multi : (pcb (9) AND 255) > 1.
+
+insert multi net :
+ IF version >= 173 THEN IF version < 175 THEN insert and say ("callee") FI;
+ insert and say ("net report/M");
+ insert and say ("basic net");
+ insert and say ("net manager/M")
+ ELSE versionsnummer zu klein
+ FI.
+
+meldung an single :
+ cursor (1, cy);
+ putline
+ ("Das EUMEL - Netz ist zur Zeit nur auf Multi - User - Versionen");
+ putline ("installierbar !").
+
+head :
+ page;
+ putline (" E U M E L - Netz - Inserter");
+ put ("---------------------------------").
+
+versionsnummer zu klein :
+ cursor (1, cy);
+ putline ("Netzsoftware erst ab Version 1.7.3 insertierbar !").
+
+PROC insert and say (TEXT CONST name of packet):
+ IF online THEN cl eop (1, cy);
+ put ("Paket '" + name of packet + "' wird insertiert");
+ line (2);
+ cy INCR 1
+ FI;
+ insert (name of packet);
+END PROC insert and say;
+
+PROC cl eop (INT CONST cx, cy) :
+ cursor (cx, cy);
+ out (""4"")
+END PROC cl eop;
diff --git a/system/net/1.7.5/src/net manager-M b/system/net/1.7.5/src/net manager-M new file mode 100644 index 0000000..0383211 --- /dev/null +++ b/system/net/1.7.5/src/net manager-M @@ -0,0 +1,302 @@ +PACKET net manager DEFINES start,stop,net manager,frei:
+TEXT VAR stand := "Netzsoftware vom 02.09.85";
+ (*Heinrichs *)
+
+LET
+ ack = 0,
+ nak = 1,
+ error nak = 2,
+ zeichen eingang = 4,
+ list code = 15,
+ fetch code = 11,
+ freigabecode = 29,
+ continue code = 100,
+ erase code = 14,
+ report code = 99,
+
+ (* Typen von Kommunikationsstrmen *)
+
+ send wait = 0,
+ zustellung = 1,
+ call pingpong = 2,
+ call im wait = 3,
+ call im abbruch = 4,
+ call in zustellung = 5;
+
+LET STEUER =
+ STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ INT sequenz,
+ seiten nummer,
+ TASK quelle,ziel,
+ INT sende code);
+
+LET INFO = STRUCT (STEUER steuer, INT typ);
+
+TASK VAR sohn;
+INT VAR strom,c.
+
+vx: v.steuer.
+
+PROC frei (INT CONST stat,lvl):
+ DATASPACE VAR ds := nilspace;
+ BOUND STRUCT (INT x,y) VAR msg := ds;
+ msg.x := stat; msg.y := lvl;
+ INT VAR return;
+ call (/"net port", freigabecode, ds, return) ;
+ forget (ds)
+END PROC frei;
+
+PROC net manager (DATASPACE VAR ds, INT CONST order, phase, TASK CONST
+ ordertask):
+
+ IF order = report code
+ THEN
+ forget ("report",quiet);
+ copy (ds,"report");
+ forget (ds)
+ ELSE
+ IF ordertask < myself
+ OR order = list code
+ OR order > continue code
+ THEN
+ IF order = list code
+ THEN
+ enable stop;
+ forget (ds); ds := old ("report");
+ FILE VAR ff := sequential file (output,ds);
+ putline (ff,stand);
+ putline (ff,"Rechner "+text(station(myself))+" um "+time of day);
+ send (ordertask, ack, ds)
+ ELSE
+ free manager (ds,order,phase,order task)
+ FI
+ ELSE
+ errorstop ("nur 'list' ist erlaubt")
+ FI
+ FI
+END PROC net manager;
+
+TASK VAR cd,stask;
+ROW 255 INT VAR erlaubt;
+INT VAR i;
+FOR i FROM 1 UPTO 255 REP erlaubt (i) := 0 PER;
+
+PROC communicate:
+ enable stop;
+ INT VAR scode;
+ DATASPACE VAR dr := nilspace;
+ neuer start (quit max);
+REP
+ forget (dr);
+ wait (dr, scode, stask);
+ cd := collected destination;
+ IF zeichen da OR zeit abgelaufen
+ THEN
+ packet
+ ELIF cd = myself
+ THEN
+ netz info und steuerung
+ ELSE
+ neue sendung (stask, cd, scode, dr)
+ FI
+PER.
+
+zeichen da: scode < 0 .
+
+zeit abgelaufen: scode = ack AND cd = myself.
+
+packet:
+ TEXT VAR t := incharety;
+ INT VAR snr, ant,err;
+ TASK VAR quelle, ziel;
+ snr := 0;
+ REP
+ IF t = ""
+ THEN
+ zeitueberwachung (snr, quelle, ziel, ant, dr);
+ ELSE
+ packet eingang (t, snr, quelle, ziel, ant, dr);
+ FI;
+ IF snr > 0
+ THEN
+ IF ant > 5 AND erlaubt(station (quelle)) < 0
+ THEN unerlaubt
+ ELSE
+ send (quelle,ziel,ant,dr,err);
+ fehlerbehandlung ;
+ FI
+ FI
+ UNTIL snr = 0 OR zeichen da PER.
+
+fehlerbehandlung:
+ IF ok oder ziel nicht da THEN loesche verbindung (snr) FI.
+
+ok oder ziel nicht da: err=0 OR err=-1.
+
+netz info und steuerung:
+ IF scode = list code THEN list status
+ ELIF scode = erase code THEN strom beenden
+ ELIF scode = freigabe code AND stask = father THEN freigabelevel
+ ELSE forget (dr); ablehnen ("nicht mglich")
+ FI.
+
+freigabelevel:
+ BOUND STRUCT (INT stat,lvl) VAR lv := dr;
+ IF lv.stat > 0 AND lv.stat < 256 THEN erlaubt (lv.stat) := lv.lvl FI;
+ send (stask,ack,dr).
+
+unerlaubt:
+ report ("Fremdzugriff von "+text(station (quelle))+" auf "+nam(ziel)
+ +" code "+text(ant));
+ loesche verbindung (snr).
+
+strom beenden:
+ BOUND TEXT VAR stromtext := dr;
+ INT VAR erase strom := int (stromtext);
+ forget (dr);
+ strom := erase strom;
+ IF falsche stromnummer THEN ablehnen ("Strom gibt es nicht")
+ ELSE
+ BOUND INFO VAR v := verbindung (strom);
+ IF
+ stask = father OR stask = vx.quelle OR stask = vx.ziel
+ THEN
+ loeschen
+ ELSE ablehnen ("Nur Empfnger/Absender darf lschen")
+ FI
+ FI.
+
+loeschen:
+ IF sendeeintrag THEN
+ IF callee (vx.quelle) = vx.ziel THEN absender warnen FI;
+ loesche verbindung (strom)
+ ELSE
+ IF callee (vx.ziel) = vx.quelle THEN warnen FI;
+ loesche verbindung (strom)
+ FI;
+ dr := nilspace;
+ send (stask,ack,dr).
+
+absender warnen:
+ dr := nilspace;
+ send(vx.ziel,vx.quelle,1,dr,err) .
+
+warnen:
+ dr := nilspace;
+BOUND TEXT VAR errtxt := dr; errtxt:= "Station antwortet nicht";
+send (vx.quelle,vx.ziel,error nak, dr, err).
+
+falsche stromnummer: strom < 1 OR strom > max verbindungsnummer.
+sendeeintrag: vx.rechnernummern DIV256 = station (myself).
+END PROC communicate;
+
+PROC ablehnen (TEXT CONST t):
+ DATASPACE VAR vdr := nilspace;
+ BOUND TEXT VAR errtxt := vdr;
+ errtxt := t;
+ send (stask, error nak, vdr).
+END PROC ablehnen;
+
+PROC stop:
+ disable stop;
+ end (task ("net port"));
+ end (task ("net timer"));
+ clear error;
+END PROC stop;
+
+PROC list status:
+
+ DATASPACE VAR ds := nilspace;
+ FILE VAR f:=sequential file (output, ds);
+ FOR strom FROM 1 UPTO max verbindungsnummer REP
+ BOUND INFO VAR v := verbindung (strom);
+ IF vx.strom <> 0 THEN info FI
+ PER;
+ send (stask, ack, ds).
+
+info:
+ put (f,"Strom "+text(strom)+" (sqnr"+text(vx.sequenz)+")");
+ IF sendeeintrag THEN sendeinfo ELSE empfangsinfo FI;
+ line (f).
+
+sendeeintrag: vx.rechnernummern DIV 256 = station(myself) .
+
+sendeinfo:
+ IF v.typ = call im wait THEN put (f,"erwartet Antwort von")
+ ELIF v.typ = call in zustellung THEN put (f,"Ziel busy. Zielstation:")
+ ELIF v.typ = call im abbruch THEN put (f,"wird gelscht bei Antwort von")
+ ELSE put (f,"sendet an")
+ FI;
+ put (f,vx.rechnernummernMOD256);
+ put (f,". Absender ist """+nam (vx.quelle)+""".").
+
+empfangsinfo:
+ IF v.typ = zustellung THEN
+ put (f,"Sendung noch nicht zustellbar")
+ ELSE
+ put (f,"empfngt von");
+ put (f,vx.rechnernummernDIV256);
+ FI;
+ put (f,". Empfaenger ist """+nam (vx.ziel)+""".").
+END PROC list status;
+
+
+PROC start (INT CONST chan):
+ c:=chan;
+ start
+END PROC start;
+INT VAR quitmax := 3;
+PROC start (INT CONST chan,quit):
+ quitmax := quit;
+ c:=chan;
+ start
+END PROC start;
+
+PROC start:
+stop;
+IF exists ("report") THEN forget ("report") FI;
+FILE VAR s := sequential file (output,"report");
+putline (s," N e u e r S t a r t "+time of day);
+begin ("net port",PROC net io, sohn);
+TASK VAR dummy;
+begin ("net timer",PROC timer,dummy);
+define collector (sohn)
+END PROC start;
+
+PROC timer:
+ disable stop;
+ REP
+ clear error;
+ DATASPACE VAR ds := nilspace;
+ pause (100);
+ send (sohn, ack, ds)
+ PER;
+END PROC timer;
+
+PROC net io:
+ disable stop;
+ fetch ("report");
+ commanddialogue (FALSE);
+ continue (c);
+ communicate;
+ TEXT VAR emsg := "++++++ "+error message +" Zeile "+text(errorline);
+ clear error;
+ report (emsg);
+ save ("report");
+ end (myself)
+END PROC net io;
+
+put ("Netzkanalnummer:"); get (c);line;
+IF yes ("Ist der Netzkanal mit Flukontrolle verdrahtet") THEN
+ quit max := 10
+ELSE
+ quit max := 3
+FI;
+END PACKET net manager;
+
+
+start; global manager (PROC (DATASPACE VAR,INT CONST,INT CONST, TASK
+CONST) net manager )
diff --git a/system/net/1.7.5/src/net report-M b/system/net/1.7.5/src/net report-M new file mode 100644 index 0000000..3ce67ff --- /dev/null +++ b/system/net/1.7.5/src/net report-M @@ -0,0 +1,29 @@ +PACKET net report DEFINES report:
+
+LET reportcode = 99;
+
+PROC report (TEXT CONST x):
+ report(x,"")
+END PROC report;
+
+PROC report (TEXT CONST txt, info):
+ IF storage (old("report")) > 20 THEN forget ("report",quiet) FI;
+ reportfile := sequential file (output, "report");
+ put (reportfile, date);
+ put (reportfile, time of day);
+ put (reportfile, txt);
+ INT VAR i;
+ FOR i FROM 1 UPTO length (info) REP
+ INT VAR z := code (infoSUBi) ;
+ IF z < 32 OR z > 126
+ THEN put (reportfile,"%"+text(z))
+ ELSE put (reportfile,infoSUBi)
+ FI
+ PER;
+ line (reportfile);
+ DATASPACE VAR net report := old ("report");
+ send (father, report code , net report)
+END PROC report;
+FILE VAR reportfile;
+
+END PACKET net report;
diff --git a/system/net/1.8.7/doc/netzhandbuch b/system/net/1.8.7/doc/netzhandbuch new file mode 100644 index 0000000..7083462 --- /dev/null +++ b/system/net/1.8.7/doc/netzhandbuch @@ -0,0 +1,2045 @@ +____________________________________________________________________________ + + +#on("b")##on ("u")# +#center#Betriebssystem E U M E L +#off ("u")# + + +#center#Netzsoftware + + + + +#off("b")# +#center#Lizenzfreie Software der +#on ("b")# + +#center#Gesellschaft für Mathematik und Datenverarbeitung mbH, +#center#5205 Sankt Augustin + + +#off("b")# +#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für +#center#nichtkommerzielle Zwecke gestattet. + +#center#Gewährleistung und Haftung werden ausgeschlossen + + +____________________________________________________________________________ +#page# +#pagenr ("%",1)##setcount(1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Inhalt +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right# GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# + +#center#Inhalt + +#clear pos##lpos(1.0)##rpos(9.5)# +#table# + +1. Einleitung #topage("0")# + +Teil 1: Netz einrichten und benutzen #topage("1")# + + +1.1. Hardwarevoraussetzungen #topage("1.1")# +1.2. Einrichten des Netzes #topage("1.2")# +1.3. Benutzung des Netzes #topage("1.3")# +1.4. Informationsmöglichkeiten #topage("1.4")# +1.5. Eingriffsmöglichkeiten #topage("1.5")# +1.6. Fehlerbehebung im Netz #topage("1.6")# +1.7. Sicherheit im Netz #topage("1.7")# + + + +Teil 2: Arbeitsweise der Netzsoftware #topage("2")# + + +2.1. Die Netztask #topage("2.1")# +2.2. Protokollebenen #topage("2.2")# +2.3. Stand der Netzsoftware #topage("2.3")# + + + +Teil 3: Netz-Hardware-Interface #topage("3")# + + +3.1. Einführung #topage("3.1")# +3.2. Arbeitsweise des Netz-Hardware-Interfaces #topage("3.2")# +3.3. Netztreiber #topage("3.3")# +3.4. Prozedurschnittstelle des EUMEL-Netzes #topage("3.4")# + + + +Anhang #topage("A")# + + +1. Fehlermeldungen #topage("A.1")# +2. Literaturhinweise #topage("A.2")# +3. Index #topage("A.3")# + +#table end# +#clear pos# + +#page# +#pagenr ("%", 2)##setcount (1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Einleitung +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# + +1. Einleitung + +#goalpage("0")# +Das EUMEL-Netz dient dazu, mehrere EUMEL-Rechner (sog. #ib#Station#ie#en) miteinan +der zu koppeln. Diese Kopplung wird vom Betriebssystem dazu benutzt, das Sen +dungskonzept [1] so auszudehnen, daß Tasks verschiedener Stationen einander +Datenräume zusenden können. Auf dem #ib#Sendungskonzept#ie# aufbauende Konzepte +nutzen daher automatisch das Netz aus: So ist es z.B. möglich + +- von einer Station aus auf einer anderen zu drucken, + +- in die Task PUBLIC einer anderen Station #ib#Datei#ie#en zu sichern (save), vorausge + setzt, daß PUBLIC dort ein #on("b")#free global manager#off("b")# ist, + +- auf einer anderen Station zu archivieren (z.B. wenn das eigene Archivlaufwerk + defekt ist oder ein anderes Format hat). + +Diese #ib#Netzversion#ie# kann ab EUMEL-Version 1.8.1 eingesetzt werden. + +Diese Netzbeschreibung besteht aus drei Teilen. In Teil 1 wird beschrieben, wie das +EUMEL-Netz benutzt und eingerichtet wird. Als Benutzer eines EUMEL- +Rechners, der vernetzt ist, ist nur dieser Teil der Netzbeschreibung für Sie wichtig. +Teil 2 erklärt die Funktionsweise der #ib#Netzsoftware#ie#, im dritten Teil wird die Schnitt +stelle für die Anpassung anderer #ib#Netzhardware#ie# definiert. + +Hinweis: + +Zur erstmaligen #ib#Installation#ie# des EUMEL-Netzes ist außer dieser Beschreibung noch +die Netzsoftware (auf Floppy) und die EUMEL-Netz-#ib#Installationsanleitung#ie#, die mit +der Software geliefert wird, notwendig. + +In der vorliegenden Netzbeschreibung wird das EUMEL-Netz möglichst "hardware +unabhängig" beschrieben. Wenn hardwareabhängige Beispiele gegeben werden, so +ist die dort beschriebene Hardware stets die #ib#Datenbox#ie#. +#pagenr ("%", 3)##setcount (1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#cneter#____________________________________________________________ + +#end# +#headodd# +#center#Teil 1 : Netz einrichten und benutzen +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# +#page# + +Teil 1: Netz einrichten und benutzen +#goalpage("1")# + + + +1.1. Hardwarevoraussetzungen +#goalpage("1.1")# + + +Zwei Stationen + +Sie können zwei #ib#Station#ie# miteinander vernetzen, wenn Sie dafür an jeder Station eine +#ib#V.24#ie#-#ib#Schnittstelle#ie# zur Verfügung stellen. + +Diese beiden Schnittstellen verbinden Sie mit einem Kabel zur #ib#Rechnerkopplung#ie# [2]. + + +Mehrere Stationen + +Wenn Sie mehr als zwei Stationen vernetzen wollen, stehen Ihnen zwei Konzepte zur +Verfügung: das Anlegen von #ib#Netzknoten#ie# bzw. das Verwenden eines #ib#Strang#ie#es. Die +Konzepte können gemischt eingesetzt werden. + +Ein Strang besteht aus einer Anzahl von #ib#Netzbox#ie#en (z.B. KHW-Box oder Ethernet +anschluß). + +Jede Box besitzt eine #ib#Schnittstelle#ie# (z.B. #ib#V.24#ie#) zum Anschluß an einen der Kanäle +1...15 der zugeordneten #ib#Station#ie# und eine weitere Schnittstelle zur #ib#Verbindung#ie# der +Boxen untereinander. + +Ein #ib#Knoten#ie# ist eine Station, bei der der Netzbetrieb über mehrere Kanäle läuft. + +Da die #ib#Netzsoftware#ie# pro #ib#Kanal#ie# eines Knotens eine Task generiert, ist das Knoten +konzept dem Strangkonzept hinsichtlich des #ib#Durchsatz#ie#es unterlegen. Preisgünstiger +ist jedoch das #ib#Knotenkonzept#ie#, weil dabei #ib#Netzbox#ie#en überflüssig werden. + +Beim Knotenkonzept wird eine #ib#Vermaschung#ie# nicht zur Optimierung benutzt (Ver +maschung heißt, daß eine #ib#Zielstation#ie# über verschiedene Knoten erreichbar ist). Daher +sollte man keine Vermaschung vorsehen. + +#ib#Nachbarn#ie# sind Stationen, die an denselben #ib#Netzstrang#ie# angeschlossen oder direkt +über ein #ib#V.24#ie#-Kabel verbunden sind. + +Bei der Entscheidung, welche Stationen man zu #ib#Knoten#ie# macht, sollte beachtet wer +den, daß (a) Stationen, zwischen denen hoher Verkehr besteht, Nachbarn werden und +daß (b) besonders leistungsfähige Rechner #ib#Knoten#ie#stationen sein sollten. +#page# + +1.2. Einrichten des Netzes +#goalpage("1.2")# + + +Hinweis: Dieses Kapitel ist nur für Systembetreuer wichtig. + +a) Legen Sie für die am Netz beteiligten Rechner #ib#Stationsnummer#ie#n fest (von 1 an + aufsteigend). + + Die Boxen haben ebenfalls Stationsnummern. Die Stationsnummern der Box und + des zugeordneten Rechners müssen übereinstimmen. + + +b) Holen Sie an jeder #ib#Station#ie# die Task #on("bold")#configurator#off("bold")# an ein Terminal und geben Sie + das Kommando #on("bold")##ib#define station#ie# (x)#off("bold")#, wobei #on("bold")#x#off("bold")# die gewählte Stationsnummer ist. + + Hinweis: Taskkommunikationen, die zu diesem Zeitpunkt laufen, führen zu feh + lerhaftem Verhalten. Dies liegt daran, daß durch #on("bold")#define station#off("bold")# alle + #ib#Task-Id#ie#'s geändert werden müssen, weil eine #ib#Task-Id#ie# u.a. die + Stationsnummer der eigenen Station enthält (siehe 1.3). TASK- + Variablen, die noch Task-Id's mit keiner oder falscher Stationsnum + mer enthalten, können nicht mehr zum Ansprechen einer Task ver + wendet werden. + + Beispiel: Der #ib#Spoolmanager#ie# [3] richtet beim Kommando #on("bold")#start#off("bold")# einen #ib#Worker#ie# ein + und merkt sich dessen #ib#Task-Id#ie# in einer TASK-Variablen, um sicher + zustellen, daß nur der Worker #ib#Datei#ie#en zum Drucken abholt. Wird jetzt + das Kommando #on("bold")# define station#off("bold")# gegeben, kann der Spoolmanager + seinen Worker nicht mehr identifizieren, weil der Worker eine neue + Task-Id erhalten hat. Man muß daher vor #on("b")#define station#off("b")# den Worker + löschen und ihn danach mit dem Kommando #on("bold")##ib#start#ie##off("bold")# im Spoolmanager + wieder neu einrichten. + + + Sinnvollerweise gibt man #on("bold")#define station#off("bold")# sofort nachdem man ein frisches System + vom Archiv geladen hat. + + Zum Anschluß einer #ib#Datenbox#ie# #ib#konfigurieren#ie# Sie mit dem Kommando #on("bold")##ib#configurate#ie##off("bold")# + den für das Netz vorgesehenen #ib#Kanal#ie# auf + + - transparent + - 9600 #ib#Baud#ie# (Standardeinstellung der Boxen) + - #ib#RTS/CTS#ie#-#ib#Protokoll#ie# + - großen Puffer + - 8 bit + - even parity + - 1 stopbit. + + Falls diese Einstellungen nicht alle angeboten werden, klären Sie mit Ihrem + Rechnerlieferanten, ob und wie diese Einstellungen erreicht werden können. + + Hinweis: Notfalls kann auf das #ib#RTS/CTS#ie#-Protokoll verzichtet werden, wenn der + Eingabepuffer der #ib#Station#ie# groß genug ist. Die Anzahl simultan laufen + der Netzkommunikationen ist dann auf + + puffergröße DIV 150 + + begrenzt (bei Z80, 8086: 3; bei M20: 10). + + Hinweis: Es können auch andere #ib#Baud#ie#raten (2400, 4800, 19200) an der Box + eingestellt werden. + + +c) Achten Sie bei der #ib#Verbindung#ie# von der Station zur #ib#Netzbox#ie# (bzw. zur Gegen + station bei einem Zweistationennetz ohne Boxen) darauf, daß neben den Emp + fangs- und Sendeleitungen auch die Leitungen RTS und CTS verdrahtet wer + den, also ein 5-poliges Kabel verwendet wird [2]. Die #ib#Pin-Belegung#ie# der Boxen + entspricht der eines Kabels zur Rechner-Rechner-Kopplung. + + Beispiel: + + Verbindung eines BICOS-Systems mit der Box: + + Stecker Stecker + Pin Pin + + 2 <---------> 3 + 3 <---------> 2 + 4 <---------> 5 + 5 <---------> 4 + 7 <---------> 7 + + +d) Richten Sie eine Task #on("bold")##ib#net#ie##off("bold")# unter #on("bold")#SYSUR#off("bold")# ein und legen Sie eine #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# an, die + Ihre #ib#Netzkonfiguration#ie# enthält, oder ändern Sie die mitgelieferte Datei ent + sprechend ab (siehe auch 1.5.).#goalpage("sperre")# + + + Dem bisherigen Netz entspricht eine Datei #on("b")#netz#off("b")# mit folgendem Inhalt: + + definiere netz; + routen (1,127,k); + starte kanal (k,1,x); + aktiviere netz. + + k: ihr netzkanal. + x: IF yes ("#ib#Flußkontrolle#ie#") THEN 10 ELSE 3 FI. + + + + Laden Sie die Datei #on("b")##ib#net install#ie##off("b")# vom Archiv #on("b")#net#off("b")# und übersetzen Sie diese. Je nach + dem, welche EUMEL-Version auf der Maschine installiert ist, werden die notwen + digen Programmdateien insertiert. + + Es sind dies + + net report + net hardware interface + basic net + net manager + + + Das Netz wird dabei gestartet. + + + Hinweis: Obwohl die Task #on("b")#net#off("b")# sich noch mit #on("bold")##ib#continue#ie##off ("bold")# an ein Terminal holen + läßt, sollte man dies nur kurzzeitig tun, da der Netzverkehr solange + blockiert ist. + + In der #ib#Datei#ie# #on("b")#netz#off("b")# sollte der #ib#Kanal#ie#, über den der meiste Verkehr erwar + tet wird, zuerst gestartet werden. Für ihn wird die Task #on("b")##ib#net port#ie##off("b")# gene + riert, für jeden weiteren Kanal wird eine Task #on("b")##ib#net port#ie# k#off("b")# (k=Kanal + nummer) generiert. +#page# + +1.3. Benutzung des Netzes +#goalpage("1.3")# + + +Zur Benutzung des Netzes stehen folgende Operatoren und Prozeduren zur Verfü +gung: + + + +TASK OP #ib#/#ie# (INT CONST station, TEXT CONST taskname) + +liefert die Task #on("bold")#taskname#off("bold")# von der #ib#Station#ie# #on("bold")#station#off("bold")#. + + +#ib#Fehlerfälle#ie#: + + - #ib(4)#Task "...." gibt es nicht#ie(4)# + + Die angeforderte Task gibt es auf der #ib#Zielstation#ie# nicht. + + - #ib(4)##ib#Collectortask#ie# fehlt#ie(4)# + + die Task #on("b")##ib#net port#ie##off("b")# existiert nicht (siehe 6). + + Hinweis: #on("b")#net port#off("b")# wird bei jedem Start des Netzes neu generiert und beim + Auftreten eines nicht vorhergesehenen #ib#Fehler#ie#s beendet. Die Feh + lermeldung steht im #on("b")##ib#report#ie##off("b")# (siehe 4). + + - #ib(4)#Station x antwortet nicht#ie(4)# + + Eine nicht vorhandene oder abgeschaltete Station wurde angesprochen. + + Hinweis: Dieser #ib#Fehler#ie# wird angenommen, wenn eine Überwachungszeit von + ca. 30 Sekunden verstrichen ist, ohne daß Station x die Taskidenti + fikation angeliefert hat. + + - #ib(4)#Station x gibt es nicht#ie(4)# + + #ib#Station#ie# x steht nicht in den #ib#Routentabelle#ie#n. + + Diese Meldung kann auch erscheinen, wenn Station x erst kürzlich an das Netz + angeschlossen wurde. Sie steht dann noch nicht in den Routentabellen (siehe + auch 5.3.). + + Beispiel: + + list (5/"PUBLIC") + + Die Dateiliste von PUBLIC der Station 5 wird angefordert. + + + +TASK OP #ib#/#ie# (INT CONST station, TASK CONST task) + +liefert + +station / name (task) + +Beispiel: + + list (4/public) + + +Fehlerfall: + + "......" #ib(4)#gibt es nicht#ie(4)# + + Auf der eigenen Station gibt es die Task #on("b")#task#off("b")# nicht. + Der Taskname wird auf der eigenen Station bestimmt, wenn es dort die Task + nicht gibt, führt dies zur obigen Fehlermeldung. + +Abhilfe: + + Statt list(4/public) das Kommando list (4/"PUBLIC") verwenden. + + + +INT PROC #ib#station#ie# (TASK CONST task) + +liefert die #ib#Stationsnummer#ie# der Task #on("bold")#task#off("bold")#. + +Beispiel: + + put (station (myself)) + + gibt die eigene Stationsnummer aus. + + + + +PROC #ib#reserve#ie# (TEXT CONST archivename, TASK CONST archivetask) + +dient dazu, das Archiv auf der #ib#Station#ie# #on("bold")#station#off("bold")# anzumelden. + +Beispiel: + + reserve ("std", 4/"ARCHIVE"); #ib#list#ie# (4/"ARCHIVE") + + gibt das Inhaltsverzeichnis der Archivfloppy im Laufwerk der Station 4 aus. + + Hinweis: Vergessen Sie bei solchen #ib#Querarchivierungen#ie# nicht die Stationsangabe + bei jedem einzelnen Archivkommando (z.B fetch ("xxx", #on("bold")#4/#off("bold")# + "ARCHIVE")). + + Hinweis: Querarchivieren ist langsam. Verwenden Sie es nur, wenn Sie Floppy + formate umsetzen wollen. + + + + +PROC #ib#free global manager#ie# + +dient dazu, die eigene Task über das Netz ansprechbar zu machen. Jede andere +Task im Netz kann dann die üblichen #ib#Manager#ie#aufrufe (#on("bold")##ib#save#ie##off ("bold")#, #on("bold")##ib#fetch#ie##off ("bold")#, usw.) an die +eigene Task machen, sofern diese nicht an ein Terminal gekoppelt ist. + +Die Task wird (wie bei #on("bold")#break#off ("bold")#) abgekoppelt und meldet sich in Zukunft mit #on("bold")#mainte +nance#off ("bold")# statt mit #on("bold")#gib kommando#off ("bold")#. + +Beispiel: + + An Station 4 ruft man in der Task "hugo" das Kommando #on("bold")#free global manager#off("bold")# + auf. Anschließend kann man von jeder Station aus z.B. #on("bold")#list (4/"hugo")#off ("bold")# usw. auf + rufen. + + + + +TEXT PROC #ib#name#ie# (TASK CONST t) + +Diese (schon immer vorhandene) Prozedur wurde dahingehend erweitert, daß der +Name einer auf einer anderen Station existierenden Task über Netz angefordert wird. + +Existiert die Task nicht, so wird #on("bold")##ib#niltext#ie##off ("bold")# geliefert. + +Hinweis: Die Prozedur #on("bold")##ib#exists#ie##off ("bold")# wurde nicht auf das Netz ausgedehnt, da sie in Situa + tionen eingesetzt wird, wo es auf eine sehr schnelle Antwort ankommt. + Daher liefert #on("bold")#exists#off ("bold")# für eine stationsfremde Task immer FALSE. Will man + wissen, ob eine solche Task existiert, verwende man die Abfrage + + #on("bold")#IF name (task) <> "" THEN ... #off ("bold")#. + +#ib#Fehlerfall#ie#: + + - #ib(4)#Station x antwortet nicht#ie(4)# + + - #ib(4)##ib#Station#ie# x gibt es nicht#ie(4)# + +#page# + +1.4. Informationsmöglichkeiten + +#goalpage("1.4")# + +In der Task #on("bold")#net#off("bold")# wird eine #ib#Datei#ie# #on("bold")##ib#report#ie##off("bold")# geführt, in der #ib#Fehlersituationen#ie# des Netzes +verzeichnet werden. Diese Datei kann in jeder anderen Task auf derselben Station mit +#on("bold")##ib#list#ie# (/"#ib#net#ie#")#off("bold")# angesehen werden. Eine Erklärung der wichtigsten Meldungen finden Sie +im Anhang. + +In jeder Task kann durch das Kommando #on("bold")##ib#list#ie# (/"#ib#net port#ie#")#off("bold")# eine Übersicht über die +momentan laufenden #ib#Netzübertragungen#ie# der eigenen #ib#Station#ie# erhalten werden (nur für +den #ib#Kanal#ie#, an dem #on("b")##ib#net port#ie##off("b")# hängt). Entsprechendes gilt für die weiteren Netports der +eigenen Station. + +Mit #on("bold")##ib#list#ie# (/"#ib#net list")#ie##off("bold")# erhält man die Informationen, die man mit #on("b")#list (/"net")#off("b")# und #on("b")##ib#list#ie##off("b")# auf +alle Netports bekommt, sofern #on("b")##ib#listoption#ie##off("b")# (siehe S. #topage("listop")#) beim Generieren des Netzes +aufgerufen wurde. Dieser Aufruf funktioniert auch bei fremden Stationen (z.B. #on("b")#list +(5/"net list")#off("b")#). + +#page# + +1.5. Eingriffsmöglichkeiten + +#goalpage("1.5")# + +- Jede Task kann #ib#Sende#ie(1,"ströme")#- und #ib#Empfangsströme#ie#, die bei #on("bold")#list (/"net port")#off("bold")# gemel + det worden sind und die eigene Task betreffen, abbrechen. Hierzu ist das Kom + mando #on("bold")##ib#erase#ie# ("x", /"#ib#net port#ie#")#off ("bold")# zu geben, wobei x die #ib#Stromnummer#ie# (aus dem #on("bold")#list#off ("bold")#) + ist. + Unberechtigte #ib#Löschversuche#ie# werden abgewiesen. + Von privilegierten Tasks aus können jedoch mit #on("b")##ib#erase#ie##off("b")# beliebige Ströme abge + brochen werden. + + +- Durch das Kommando #on("bold")##ib#start#ie##off("bold")# kann von der Task #on("b")##ib#net#ie##off("b")# aus das Netz neu gestartet + werden. Dies setzt eine gültige #ib#Datei#ie# #on("bold")#netz#off("bold")# voraus. Es wird ein #on("bold")##ib#run#ie##off("bold")# auf diese Datei + gegeben. Das Kommando #on("b")##ib#start#ie##off("b")# ist nur noch aus Kompatibilitätsgründen zum alten + Netz vorhanden. + + +- Durch das Kommando #on("bold")##ib#routen aufbauen#ie##off("bold")# in der Task #on("b")##ib#net#ie##off("b")# werden die #ib#Routentabelle#ie#n + neu aufgebaut. Dies kann notwendig werden, wenn eine neue #ib#Station#ie# ans Netz + angeschlossen wurde (#ib#Fehlermeldung#ie# '#ib(4)#Station x gibt es nicht#ie(4)#'). #on("bold")#routen aufbauen#off ("bold")# + muß zuvor auch an allen dazwischenliegenden #ib#Knotenstation#ie#en gegeben werden. + + #on("bold")#routen aufbauen#off ("bold")# erzeugt eine Task #on("b")##ib#router#ie##off("b")#, die sich an das Terminal koppelt (die + Task #on("b")#net#off("b")# koppelt sich ab) und ein #ib#Protokoll#ie# ausgibt. Sind die #ib#Route#ie#n aufgebaut, + beendet sich die Task #on("b")#router#off("b")# mit der Meldung #on("b")#fertig#off("b")#. Es werden nur Stationen + bearbeitet, die nicht #ib#gesperrt#ie# (siehe S. #topage("sperre")#), und für die keine festen Routen + vereinbart sind. Der Vorgang dauert ca. 5 Sek. pro nicht gesperrter Station und + #ib#Netzkanal#ie#. Die #ib#Route#ie#n werden in einem #ib#Datenraum#ie# #on("b")##ib#port intern#ie##off("b")# hinterlegt. + + +- Der Aufruf #on("bold")##ib#definiere netz#ie##off("bold")# leitet eine #ib#Netzdefinition#ie# in der #ib#Datei#ie# #on("bold")##ib#netz#ie##off("bold")# ein. Dabei + werden alle augenblicklichen Netzkommunikationen gelöscht. Die Tasks #on("b")##ib#net port#ie# + (k)#off("b")#, wobei #on("b")#k#off("b")# die #ib#Kanalnummer#ie# ist, und #on("b")##ib#net timer#ie##off("b")# werden gelöscht. + + Dieser Aufruf muß vor den Aufrufen von #on("bold")##ib#starte kanal#ie#, #ib#erlaube#ie#, #ib#sperre#ie#, #ib#routen#ie#, + #ib#aktiviere netz#ie# und #ib#list option#ie##off("bold")# erfolgen. + + +- PROC #ib#sperre#ie# (INT CONST a,z) + bewirkt, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# keine Manageraufrufe an Tasks dieser Station + geben dürfen (Genauer gesagt werden sendecodes > 6 nicht weitergeleitet, son + dern ein errornak mit dem Text "#ib(4)#kein Zugriff auf Station#ie(4)#" zurückgeschickt). + + Dieser Aufruf muß vor dem ersten #on("bold")##ib#starte kanal#ie##off("bold")# erfolgen. + + +- PROC #ib#erlaube#ie# (INT CONST a,z) + bewirkt, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# Manageraufrufe an Tasks dieser Station geben + dürfen. + + Dieser Aufruf muß vor dem ersten #on("bold")##ib#starte kanal#ie##off("bold")# erfolgen. + + Beispiel: Alle Stationen außer 8 und 10 sollen #ib#gesperrt#ie# sein: + + #ib#sperre#ie# (1,127); erlaube (8,8); erlaube (10,10) + + Hinweis: 127 ist z.Zt. die maximale #ib#Stationsnummer#ie(1," maximale")#. + + +- PROC #ib#routen#ie# (INT CONST a,z,k) + legt fest, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# an #ib#Kanal#ie# #on("bold")#k#off("bold")# direkt angeschlossen sind. Sen + dungen dieser Stationen werden nur bearbeitet, wenn sie über diesen Kanal her + einkommen (siehe 1.7.). Fehlt für eine Station ein entsprechender Routenaufruf, so + darf sie über einen beliebigen #ib#Netzkanal#ie# angeschlossen sein. Dies wird dann von + #on("bold")##ib#routen aufbauen#ie##off("bold")# ermittelt. + + PROC routen (INT CONST a,z,k,zw) + legt fest, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# indirekt über die #ib#Knotenstation#ie# #on("bold")#zw#off("bold")# angeschlos + sen sind, und #on("b")#zw#off("b")# am Kanal #on("bold")#k#off("bold")# hängt. + + +- PROC #ib#starte kanal#ie# (INT CONST k,m,q) + startet eine #ib#Netztask#ie# am #ib#Kanal#ie# #on("bold")#k#off("bold")# im Modus #on("bold")#m#off("bold")# [4]. Dabei wird mit #on("bold")#q#off("bold")# die Anzahl + paralleler #ib#Empfangsströme#ie# festgelegt. Dadurch kann erreicht werden, daß der + #ib#Empfangspuffer#ie# nicht überläuft, indem nicht mehr als #on("b")#q#off("b")# Ströme quittiert werden. + Bei #ib#V.24#ie#-#ib#Schnittstelle#ie#n gebe man 3 (ohne #ib#Flußkontrolle#ie#) bzw. 10 (mit Flußkon + trolle) an. + + +- PROC #ib#aktiviere netz#ie# + muß als Abschluß in der Datei #on("bold")##ib#netz#ie##off("bold")# aufgerufen werden. Dabei wird die Task vom + Terminal abgekoppelt. Falls es bei #on("bold")##ib#definere netz#ie##off("bold")# den #ib#Datenraum#ie# #on("b")##ib#port intern#ie##off("b")#, der + die #ib#Route#ie#n enthält, nicht gab, wird #on("bold")##ib#routen aufbauen#ie##off("bold")# aufgerufen. + + +- PROC #ib#listoption#ie##goalpage("listop")# + erzeugt eine Task #on("b")##ib#net list#ie##off("b")#, die bei #on("bold")#list#off("bold")# den #ib#Fehlermeldung#ie#sreport und den Zustand + aller Netports liefert. Diese Task ist auch über Netz ansprechbar. In der Regel + sollte man #on("b")#listoption#off("b")# in der Datei #on("b")#netz#off("b")# aufrufen, es sei denn, das System ist sehr + klein. + +#page# + +1.6. #ib#Fehlersuche#ie# im Netz + +#goalpage("1.6")# + +#ib#Fehler#ie# im Netz können sich verschiedenartig auswirken. Im folgenden wird auf einige +Beispiele eingegangen: + +Beispiel: + + Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung '#ib(4)#Station#ie(4, " x antwortet nicht")# 4 antwortet nicht'. + + +#ib#Fehler#ie#möglichkeiten: + + - #ib#Station#ie# 4 ist nicht eingeschaltet. + Abhilfe: Station 4 einschalten. Kommando erneut geben. + + + - #ib#Netztask#ie# an Station 4 ist nicht arbeitsfähig. + Abhilfe: Kommando #on("bold")##ib#start#ie##off ("bold")# in der Task "net" auf Station 4. + + + - Stationsnummern und Boxnummern stimmen nicht überein. + Abhilfe: Mit #on("bold")#define station#off ("bold")# #ib#Stationsnummer#ie#n korrigieren (siehe 3.2). + + + - #ib#Verbindung#ie# Rechner/Box am eigenen Rechner oder an Station 4 fehlt. + Abhilfe: Verbindungen überprüfen. Durch Ansprechen einer dritten Station + kann oft schnell geklärt werden, welche Rechner/Box-Verbindung + defekt sein muß. + + + - Verbindung der Boxen untereinander defekt. + Abhilfe: Fehlende Verbindung, #ib#Masseschluß#ie# und #ib#Dreher#ie# (keine 1:1 Verbin + dung) überprüfen und beheben. + + Hinweis: Liegt z.B. ein Masseschluß vor, so kann es durchaus sein, daß + Boxen, die nicht in der Nähe des Masseschlusses stehen, noch + miteinander arbeiten können. Man kann aus der Tatsache, daß zwei + Boxen miteinander arbeiten können, also nicht schließen, daß man + nicht nach diesem Fehler suchen muß. + + + +Beispiel: + + Auf #on("bold")#list (4/public)#off("bold")# erfolgt keine Reaktion. + + + - Station 4 ist während dieser Sendung zusammengebrochen. + Abhilfe: Station 4 wieder starten. Die Bearbeitung des #on("bold")##ib#list#ie##off ("bold")#-Kommandos wird + automatisch wieder aufgenommen. + + + - PUBLIC auf Station 4 ist nicht im Managerzustand. + Abhilfe: PUBLIC in den Managerzustand versetzen. + + + - #ib#Fehler#ie# in der #ib#Netzhardware#ie#. + Überprüfen Sie, ob + + - die Boxen eingeschaltet sind, + - die Bereitlampe blinkt (wenn nicht: #ib#RESET#ie# an der Box), + - die #ib#V.24#ie#-Kabel richtig stecken, + - die Boxen untereinander verbunden sind (1 zu 1 Verbindungen der 5 poli + gen Diodenbuchsen). + + + - Fehler bei der #ib#Netzinstallation#ie#. + Überprüfen Sie, ob + + - alle Stationen an einem #ib#Strang#ie# gleiche oder kompatible Netzmodi einge + stellt haben [4], + - alle Stationen an einem #ib#Netzstrang#ie# auf die gleiche #ib#Nutzdatenlänge#ie# einge + stellt sind, + - bei der #ib#Kommunikation#ie# über #ib#Knoten#ie# alle Stationen die gleiche Nutzdaten + länge bei indirekten Sendungen eingestellt haben, + - die #ib#Route#ie#n auf allen beteiligten Stationen korrekt eingestellt sind. + + + +Beispiel: + + Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung '#ib(4)##ib#Collectortask#ie# fehlt#ie(4)#'. + + - Das Kommando #on("b")##ib#start#ie##off("b")# (bzw #on("b")##ib#aktiviere netz#ie##off("b")# in der #ib#Datei#ie# #on("b")#netz#off("b")#) wurde nicht gege + ben. Somit existiert #on("b")##ib#net port#ie##off("b")# nicht. + Abhilfe: Kommando #on("bold")#start#off ("bold")# in der Task #on("b")#net#off("b")# geben. + + + - Die #ib#Netzsoftware#ie# ist auf einen nicht vorhergesehenen #ib#Fehler#ie# gelaufen. Dieser + wird im #ib#Report#ie# vermerkt. #on("b")##ib#net port#ie##off("b")# wird dabei gelöscht. + Abhilfe: Geben Sie in der Task #on("bold")#net#off("bold")# das Kommando #on("bold")#start#off("bold")#. Dadurch wird die + Netzsoftware neu gestartet. Alle Netzkommunikationen dieser Station + gehen verloren. + + + +Beispiel: + + Nach #on("bold")##ib#fetch#ie# ("hugo",4/public)#off("bold")# sind Teile der Datei "hugo" verfälscht. + + - Die #ib#V.24#ie#-#ib#Verbindung#ie# zur Box ist nicht in Ordnung. + Abhilfe: Abstand zwischen Rechner und Box verkürzen; #ib#Baud#ie#rate ernie + drigen; durch Wechseln der #ib#V.24#ie#-#ib#Schnittstelle#ie# feststellen, ob diese + defekt ist. + Hinweis: Die Verbindung zwischen den Boxen ist durch #ib#Prüfsummen#ie# abge + sichert (Hardware). + +#page# + +1.7. Sicherheit im Netz + +#goalpage("1.7")# + +Bei Benutzung eines Rechnernetzes tauchen neue #ib#Sicherheitsprobleme#ie# auf. Um sie +verstehen und eingrenzen zu können, muß man sich mit dem #ib#Sicherheitskonzept#ie# des +Betriebssystems EUMEL vertraut machen: + +Eine Task im EUMEL kann nur manipuliert werden, wenn man sie entweder an ein +Terminal koppelt oder ihr Sendungen zustellt. + +Das Ankoppeln kann über #ib#Paßwort#ie# abgesichert werden. Nach dem Ankoppeln kann +die Task außerdem selbst bestimmen, wie sie die dann möglichen Eingaben behan +delt. So kann z.B. noch ein komplizierter Paßalgorithmus zu durchlaufen sein, bis +man auf einer offenen Programmierumgebung landet. + +Sendungen können eine Task auch nur mit ihrem Einverständnis beeinflussen, da +eine Sendung nur zugestellt wird, wenn die Task in der Prozedur #on("b")##ib#wait#ie##off("b")# steht. Insbe +sondere kann die Task den Absender einer Sendung überprüfen und gewisse Opera +tionen nur bei gewissen Absendern zulassen. So lehnt ein #on("b")##ib#global manager#ie##off("b")# z.B. alle +Dateimanagerkommandos ab, die nicht von Nachkommen (z.B. Söhnen) der Task +kommt. #on("b")##ib#free global manager#ie##off("b")# hingegen läßt Operationen wie #on("b")##ib#save#ie##off("b")# oder #on("b")##ib#erase#ie##off("b")# von +beliebigen Tasks, auch von fremden #ib#Station#ie#en, zu. Will man nur bestimmte Fremd +stationen zulassen, kann man z.B. folgendes Schema verwenden: + + PROC my #ib#manager#ie# + (DATASPACE VAR ds, INT CONST code, phase, TASK CONST source): + + IF station (source) = station (myself) OR station (source) = 10 + THEN + free manager (ds, code, phase, source) + ELSE + errorstop ("kein Zugriff") + FI + + END PROC my manager; + + global manager (PROC my manager) +#page# +Hier werden nur #on("b")#save#off("b")# usw. von Tasks der eigenen Station und der Station 10 zuge +lassen. Der Rest erhält die #ib#Fehlermeldung#ie# "kein Zugriff". + +Dieses Verfahren gewährt nur dann Sicherheit, wenn es nicht möglich ist, daß eine +beliebige Station sich als Station 10 ausgibt. + +Damit das Netz diese Sicherheit garantieren kann, müssen natürlich gewisse phy +sische Voraussetzungen erfüllt sein. Wenn z.B. die Station 10 über eine #ib#V.24#ie# ange +schlossen ist, aber jeder die Möglichkeit hat, an diese #ib#Schnittstelle#ie# seinen eigenen +Rechner anzuschliessen, dann kann das Netz natürlich nicht erkennen, ob es mit der +echten Station 10 verkehrt. + +Es muß also sichergestellt sein, daß an Kanälen für das Netz nicht manipuliert werden +kann. Bei einem #ib#Strang#ie# (Anschluß über #ib#Netzbox#ie#en) heißt das für die Boxen, daß sie +nur #ib#Telegramm#ie#e weitervermitteln, die die eingestellte #ib#Quellstationsnummer#ie# enthalten. +Sonst könnte jemand, der an denselben Strang wie #ib#Station#ie# 10 angeschlossen ist, +#ib#Telegramm#ie#e erzeugen, die so aussehen, als kämen sie von 10. + +Die #ib#Netzsoftware#ie# ihrerseits darf nur Telegramme auswerten, die über die richtige +#ib#Route#ie# (#ib#Kanal#ie# und #ib#Knotenstation#ie#) einlaufen. + +Leider hat dies die unangenehme Konsequenz, daß man automatisches Aufbauen und +Ändern von Routen verbieten muß, wodurch die Wartung der #ib#Netzkonfiguration#ie# +erschwert wird. + +Diese Version der #ib#Netzsoftware#ie# bietet den folgenden Kompromiß an: Nur für sicher +heitsrelevante #ib#Stationen#ie(1,", sicherheitsrelevante")# (im Beispiel Station 10) muß in der #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# die Route +angegeben werden. Dies muß in allen Stationen geschehen, für die die Station +sicherheitsrelevant ist, und in allen #ib#Knoten#ie# dazwischen. + +Für nicht sicherheitsrelevante Stationen werden #ib#Routeninformationen#ie# automatisch +aufgebaut und geändert. + +Hinweis: +Man wird oft ohne sicherheitsrelevante Stationen auskommen, indem man auf Ebenen +oberhalb der Netzebene Paßwortkontrollen einführt. So ist es z.B. ja möglich, Dateien +durch Paßworte zu schützen. Ein weiteres Beispiel ist ein #ib#Printerserver#ie#, der nur +ausdruckt, wenn eine mitgegebene Abrechnungskennung stimmt. Dabei ist es sogar +wünschenswert, daß die #ib#Station#ie# irrelevant ist, die den Druckauftrag gibt. +#pagenr ("%",21)##setcount (1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Teil 2 : Arbeitsweise der Netzsoftware +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# +#page# + +Teil 2: Arbeitsweise der Netzsoftware +#goalpage("2")# + + + +2.1. Die Netztask +#goalpage("2.1")# + + +In diesem Kapitel wird beschrieben, wie eine #ib#Netztask#ie# in das System eingebettet ist +und welche Aufgaben sie hat. Unter Einhaltung dieser Konzepte kann die ausgeliefer +te Netzsoftware so geändert werden, daß sie beliebige andere #ib#Netzhardware#ie# unter +stützt. Die Netzsoftware ist so gegliedert, daß i.allg. nur eine hardwareabhängige +Komponente ausgetauscht werden muß (siehe Teil 3). + +Die Kommunikation zwischen Tasks im EUMEL-Betriebssystem basiert auf einem +#ib#Rendezvouskonzept#ie#: Die #ib#Zieltask#ie# einer Sendung muß empfangsbereit sein, wenn die +#ib#Quelltask#ie# sendet. + +Die Kommunikationsprozeduren auf der niedrigsten Ebene sind #on("bold")##ib#send#ie##off ("bold")# (Senden) und +#on("bold")##ib#wait#ie##off ("bold")# (Warten auf Empfang). Bei der Kommunikation werden ein Integer #on("bold")#code#off ("bold")# und ein +#ib#Datenraum#ie# #on("bold")#dr#off ("bold")# übergeben. #on("bold")#code#off ("bold")# muß >= 0 sein, da negative Codes systemintern ver +wandt werden. Ist die empfangende Task an einen #ib#Kanal#ie# gekoppelt (#on("bold")##ib#continue#ie##off ("bold")#), so +führt eine Zeicheneingabe auf diesem Kanal dazu, daß eine Sendung mit dem Code +-4 ankommt. Die Eingabedaten müssen mit den üblichen #ib#Eingabeprozeduren#ie# (#on("bold")##ib#inchar#ie##off ("bold")# +usw.) abgeholt werden. Der übermittelte #ib#Datenraum#ie# und die Absendertask sind dabei +ohne Bedeutung und dürfen nicht interpretiert werden. + +Die Prozedur #on("bold")#send#off ("bold")# hat einen #ib#Rückmeldeparameter#ie#, der besagt, ob die Sendung +übermittelt wurde. Gibt es die Zieltask nicht oder steht sie nicht im #on("bold")#wait#off ("bold")#, so kann die +Sendung nicht übermittelt werden. + +Ein Entwicklungskriterium für das EUMEL-Netz war es, möglichst wenig Unterstüt +zung von der virtuellen EUMEL-Maschine (#ib#EUMEL0#ie#) zu fordern, damit weitgehend in +ELAN programmiert werden kann. Dadurch ist es möglich, eine (privilegierte) Task mit +der Netzabwicklung zu betrauen. +#page# +Zunächst wird auf die #ib#EUMEL0#ie#-Unterstützung eingegangen: + +a) Es gibt die Prozedur #on("bold")##ib#define collector#ie##off ("bold")#, mit der die für das Netz verantwortliche + Task der EUMEL0-Maschine bekannt gemacht wird. Diese Task wird im fol + genden #ib#Collector#ie# genannt. + +b) Es gibt die Prozedur #on("bold")##ib#define station#ie##off ("bold")#, die für den Rechner eine #ib#Stationsnummer#ie# + einstellt. Anhand dieser Nummer werden die Rechner eines Netzes unterschie + den. Das Einstellen bewirkt, daß für alle Tasks die Stationsnummer in ihre + #ib#Task-Id#ie# eingetragen wird (Task-Id's sind die Werte, die der Typ TASK anneh + men kann). + +c) Der Befehl #on("bold")##ib#station#ie# (task)#off ("bold")# liefert die Stationsnummer der #on("bold")#task#off ("bold")#. So liefert z.B. + #on("bold")##ib#station#ie# (myself)#off ("bold")# die #ib#Stationsnummer#ie# des eigenen Rechners. + +d) Eine Sendung, deren #ib#Zieltask#ie# auf einem anderen Rechner liegt (also station (ziel) + <> station (myself)), wird auf die #ib#Collectortask#ie# geleitet. + +e) Es gibt eine Prozedur #on("bold")##ib#collected destination#ie##off ("bold")#, die es dem Collector erlaubt, die + eigentliche Zieltask einer auf ihn geleiteten Sendung zu erfahren. + +f) Es gibt eine Variante der Prozedur #on("bold")##ib#send#ie##off ("bold")#, die es dem Collector gestattet, der + #ib#Zieltask#ie# eine andere Task als Absender vorzutäuschen. + +g) Es gibt eine spezielle #ib#Task-Id#ie# #on("bold")##ib#collector#ie##off ("bold")#, durch die der augenblicklich eingestell + te #ib#Collector#ie# erreicht wird. Diese wird als Zieltask beim Aufruf der Vermittlungs + dienste angegeben (siehe S. #topage("collector")#). Eine Sendung an #on("bold")#collector#off ("bold")# wird von EUMEL0 + an den derzeitig eingestellten Collector geschickt. + +Ein Collector kann also auf drei Wegen von den übrigen Tasks desselben Rechners +Sendungen erhalten: + + 1. Über ein normales #on("b")#send#off("b")# (z.B. bei #on("bold")#list (/"net port")#off ("bold")#, wenn #on("b")#net port#off("b")# der derzeitige + #ib#Collector#ie# ist), + + 2. über ein #on("b")#send#off("b")# an die Task #on("bold")#collector#off ("bold")# (s.u.) und + + 3. als umgeleitete Sendung (z.B. bei #on("bold")#list#off ("bold")# an eine Task auf einem anderen + Rechner). + +Der Collector kann diese Fälle anhand von #on("bold")#collected destination#off ("bold")# unterscheiden. + +Die Punkte d) bis f) dienen dazu, den Collector für über Netz kommunizierende Tasks +unsichtbar zu machen: Der Collector taucht nicht als Ziel oder #ib#Quelle#ie# von Sendungen +auf. Das ist notwendig, damit normale Tasks sich nicht darum kümmern müssen, ob +eine Sendung übers Netz geht oder im eigenen Rechner bleibt. + +Wenn ein #ib#Datenraum#ie# an einen anderen Rechner geschickt wird, muß der gesamte +Inhalt (z. Zt. max. 1 MB) übertragen werden. Dies macht bei der üblichen Netzhard +ware eine Zerlegung in #ib#Paket#ie#e nötig [5]. Bei der Zerlegung eines Datenraumes in +Pakete (#ib#Telegramm#ie#e) gelten folgende Einschränkungen: + + - Ein Paket kann maximal eine #ib#Datenraumseite#ie# als #ib#Nutzdaten#ie# enthalten. + + - Die #ib#Nutzdatenlänge#ie# ist für einen #ib#Übertragungsweg#ie# konstant. + + - Alle Stationen eines #ib#Netzstrang#ie#s senden mit gleicher Nutzdatenlänge (#on("b")##ib#data + length#ie##off("b")#). + + - Bei indirekter #ib#Kommunikation#ie(1,"indirekte")# (über #ib#Knoten#ie#) muß die Nutzdatenlänge für in + direkte Verbindungen (#on("b")##ib#data length via node#ie##off("b")#) auf allen beteiligten Stationen + gleich eingestellt sein. + + +Für Netze stehen spezielle Blockbefehle zur Verfügung: + + +g) #ib#blockin#ie# / #ib#blockout#ie# (dr,seite,512+abstand,anzahl,rest) + + Es werden maximal #on("bold")#anzahl#off ("bold")# Bytes transferiert. In #on("bold")#rest#off ("bold")# wird zurückgemeldet, wie + viele Bytes nicht bearbeitet wurden (z.B. weil der #ib#Kanal#ie# nichts anliefert). Bear + beitet werden die Bytes + + #on("bold")#seite#off ("bold")# * 512 + #on("bold")#abstand#off ("bold")# + + bis maximal + + #on("bold")#seite#off ("bold")# * 512 + #on("bold")#abstand#off ("bold")# + #on("bold")#anzahl#off ("bold")# - 1 + + Der Kanal, an den die Task gekoppelt ist, wird dabei über #ib#Stream-IO#ie# (d.h. + #on("bold")##ib#incharety#ie##off ("bold")#, bei #on("bold")#blockin#off ("bold")# bzw. #on("bold")#out#off ("bold")# bei #on("bold")#blockout#off ("bold")#) angesprochen. + + Hinweis: Die Anforderung darf nicht über #ib#Seitengrenze#ie# gehen, d.h. + + #on("bold")#abstand#off ("bold")# + #on("bold")#anzahl#off ("bold")# <= 512 + + muß erfüllt sein. + + +Eine Netzsendung läuft wie folgt ab: + +Die Task q auf Rechner rq mache ein #on("bold")##ib#send#ie##off ("bold")# an die Task z auf Rechner rz. + +1. Die Prozedur #on("bold")#send#off ("bold")# ist ein #ib#EUMEL0#ie#-Befehl. Die EUMEL0-Ebene erkennt, daß die + Sendung an die #ib#Station#ie# rz geht, da die #ib#Stationsnummer#ie# in der #ib#Task-Id#ie# enthalten + ist. Daher wird die Sendung zum #ib#Collector#ie# umgeleitet, den EUMEL0 wegen der + Einstellung durch #on("bold")##ib#define collector#ie##off ("bold")# kennt, umgeleitet. + +2. Die Task Collector empfängt über #on("bold")##ib#wait#ie##off ("bold")# den #ib#Datenraum#ie#, den #ib#Sendecode#ie# und die + Absendertask q. Die #ib#Zieltask#ie# z erfährt sie durch #on("bold")##ib#collected destination#ie##off ("bold")#. + +3. Der Collector nimmt Kontakt mit dem Collector des Rechners #on("b")#rz#off("b")# auf, dessen Sta + tionsnummer ja #on("bold")##ib#station#ie#(z)#off ("bold")# ist, und übermittelt diesem Sendecode, #ib#Quelltask#ie# (q), + eigentliche Zieltask (z) und den #ib#Datenraum#ie#. Da die Collectoren in ELAN geschrie + ben sind, können sie an beliebige #ib#Netzhardware#ie# und #ib#Protokoll#ie#e angepaßt werden. + +4. Der #ib#Collector#ie# auf Rechner #on("b")#rz#off("b")# verwendet das spezielle #on("bold")#send#off ("bold")#, um der Zieltask die + Sendung zuzustellen. Dadurch erscheint nicht der Collector, sondern die Task #on("b")#q#off("b")# + als Absender der Sendung. + +Zur Abwicklung der #ib#Vermittlungsebene#ie# (siehe S. #topage("vermittlung")#) muß der Collector noch spe +zielle Funktionen beherrschen. Diese sind + + der #on("b")##ib#/#ie#-Operator#off("b")# (Taskname in #ib#Task-Id#ie# wandeln) und + die #on("b")##ib#name#ie##off("b")#-Prozedur (Task-Id in Namen wandeln). + +Der #on("b")#/#off("b")#-Operator macht eine Sendung an den #on("bold")##ib#collector#ie##off ("bold")#, wobei im #ib#Datenraum#ie# der Name +der Task steht und der #ib#Sendecode#ie# gleich der Stationsnummer ist (siehe [6] ). Der +#ib#Collector#ie# setzt sich mit dem Collector dieser Station in Verbindung, damit dieser die +Task-Id ermittelt und zurückschickt. Der eigene Collector schickt dann dem #on("b")#/#off("b")#-Oper +ator als Antwort einen Datenraum, der die #ib#Task-Id#ie# enthält. + +Umgekehrt läuft #on("bold")##ib#name#ie##off ("bold")# ab: Wenn die Task-Id von einer fremden Station ist, schickt +#on("bold")#name#off ("bold")# eine Sendung an den #on("bold")##ib#collector#ie##off ("bold")#, wobei im Datenraum die Task-Id steht und +Sendecode = 256 ist. Der Collector entnimmt die #ib#Stationsnummer#ie# der Task aus der +Task-Id und läßt sich vom entsprechenden Collector den Tasknamen geben. Dieser +wird der #on("bold")#name#off ("bold")#-Prozedur im Antwortdatenraum übergeben. + +Netztasks bauen sich #ib#Routentabellen#ie# auf (#ib#Datei#ie#name #on("b")##ib#port intern#ie##off("b")#). Aufgrund dieser +Tabellen weiß jede #ib#Netztask#ie#, über welchen #ib#Kanal#ie# und welche #ib#Nachbarstation#ie# eine +#ib#Zielstation#ie# erreichbar ist. Wenn der #ib#Collector#ie# einen Sendeauftrag erhält, prüft er, ob +die Zielstation über seinen Kanal erreichbar ist. Wenn nicht, leitet er Parameter und +#ib#Datenraum#ie# der Sendung an die geeignete Netztask weiter. +#page# + +2.2. Ebenen + +#goalpage("2.2")# + +In diesem Kapitel werden die #ib#Protokollebenen#ie# für das Netz beschrieben, wie sie die +ausgelieferte Netzsoftware benutzt und erwartet. Bei anderer Netzhardware als Daten +boxen müssen die Ebenen a) bis c) ausgetauscht werden [4]. Unter Einhaltung der im +vorigen Kapitel beschriebenen Randbedingungen können auch die höheren Ebenen +geändert werden. + + +a) Physikalische Ebene + + - #ib#Station#ie# <--> Box + + #ib#V.24#ie#-#ib#Schnittstelle#ie# mit #ib#RTS/CTS#ie#-Handshake. Vollduplex. + + - Box <--> Box + + #ib#RS422#ie# über 2 verdrillte Leitungspaare (Takt und Daten). + + +b) Verbindungsebene + + - Station <--> Box + + Asynchron + 8 Bit + Even Parity + 2400/4800/9600/19200 #ib#Baud#ie# einstellbar über Lötbrücken) + + - Box <--> Box + + #ib#SDLC#ie# + 400 KBaud +#page# +c) #ib#Netzebene#ie# +#goalpage("quelle")# + + - Station <--> Box + + #ib#Telegrammformat#ie#: #ib#STX#ie#, <n>, <ziel>, <#ib#quelle#ie#>, <(n-4) byte> + + <n> ist #ib#Längenangabe#ie# ( 8 <= n <= 160) + <ziel>, <quelle> sind #ib#Stationsnummer#ie#n. Diese müssen an den jeweiligen + Boxen eingestellt sein. + + Box --> Station: + + Ein #ib#Telegramm#ie# kommt nur bei der #ib#Station#ie# an, bei deren Box die Nummer + <ziel> eingestellt ist. Dadurch ist ein Mithören fremder #ib#Übertragung#ie# nicht + möglich (Datenschutz). + + Zwischen Telegrammen können #ib#Fehlermeldung#ie#en der Box (Klartext) übermittelt + werden (z.B. 'skipped x', wenn ein #ib#STX#ie# von der Box erwartet wurde, aber 'x' + von der Station ankommt). + + Station --> Box: + + Ein Telegramm wird nur abgeschickt, wenn <#ib#quelle#ie#> mit der eingestellten + Nummer übereinstimmt (Datenschutz: Man kann nicht vorschwindeln, eine + beliebige Station zu sein, es sei denn, man hat physischen Zugriff zur Box und + stellt dort die Stationsnummer um). + + - Box <--> Box + + #ib#Telegrammformat#ie#: + FRAME, <ziel>, <#ib#quelle#ie#>, <daten>, <CRC-Code> + + Eine #ib#Längenangabe#ie# ist nicht nötig, da #ib#SDLC#ie# eine Rekonstruktion der Länge + erlaubt. + + Telegramme mit falschen #ib#CRC-Code#ie# werden vernichtet. Auf höheren Ebenen + muß dies durch #ib#Zeitüberwachung#ie# erkannt und behandelt werden. + +#page# +d) Transportebene + + Diese Ebene wickelt das Rendezvous zwischen einer Task, die #on("bold")##ib#send#ie##off ("bold")# macht, und + einer Task, die im #on("bold")##ib#wait#ie##off ("bold")# steht, ab [1]. + + Der im #on("bold")#send#off ("bold")# angegebene #ib#Datenraum#ie# wird als Folge von #ib#Seiten#ie# (im EUMEL- + Sinne: Pagingeinheit und Allokiereinheit) übermittelt, wobei jede Seite ggf. noch in + n Byte große Stücke zerlegt wird. Es werden nur echt allokierte Seiten übermit + telt. Um nicht jedes #ib#Telegramm#ie# voll qualifizieren zu müssen, wird zunächst eine + Art virtuelle #ib#Verbindung#ie# durch ein #ib#OPEN#ie#-Telegramm eröffnet. Danach folgen + variabel viele #ib#DATA#ie#-Telegramme. Beide Sorten werden durch #ib#QUIT#ie#-Tele + gramme quittiert, um folgende Funktionen zu ermöglichen: + + #ib#Flußkontrolle#ie# (z.B. Zielrechner langsam), + Wiederaufsetzen (verlorene Telegramme), + Abbruch (z.B. weil Zieltask inzwischen beendet). + + Ein #ib#CLOSE#ie#-Telegramm ist nicht nötig, da das letzte DATA-Telegramm als + solches erkannt werden kann (siehe unten). +#page# + - #ib#OPEN#ie#-Telegramm + +#clear pos# + 0 1 2 3 4 5 6 7 8 9. Byte ++------+------+------+------+-------------+-------------+-------------------+ +I STX I 24 I Ziel IQuelleI Endziel I Endquelle I Strom I ++------+------+------+------+-------------+-------------+-------------------+ + + 10 11 12 13 14 15 16 17 ++-------------+-------------+---------------------------+ +I Sequenz I Seite I Quelltask I ++-------------+-------------+---------------------------+ + + 18 19 20 21 22 23 ++---------------------------+-------------+ +I Zieltask I Code I ++---------------------------+-------------+ + + + + <#ib#ziel#ie#>, <#ib#quelle#ie#> siehe S. #topage("quelle")# + + <#ib#endziel#ie#> Eigentliche #ib#Zielstation#ie#. Ist <ziel> = <endziel>, so ist + das #ib#Telegramm#ie# angekommen. Andernfalls muß die Station + <ziel> den #ib#Nachbarn#ie# zum Erreichen des <endziel> als + neues <ziel> einsetzen und das Telegramm an diesen + Nachbarn weiterleiten. + + <#ib#endquelle#ie#> Eigentliche #ib#Absenderstation#ie#. <quelle> ist dagegen immer + die Nummer der sendenden #ib#Nachbarstation#ie#. + + <#ib#strom#ie#> Die #ib#Stromnummer#ie# identifiziert die virtuelle #ib#Verbindung#ie#. Sie + muß in den #ib#QUIT#ie#-Telegrammen angegeben werden. + + <#ib#sequenz#ie#> -1 (Kennzeichen für OPEN) + + <#ib#seite#ie#> Nummer der ersten echt allokierten #ib#Seite#ie# des #ib#Datenraum#ie#s + (=-1, falls Nilspace) + + <#ib#quelltask#ie#> #ib#Task-Id#ie# der sendenden Task + + <#ib#zieltask#ie#> Task-Id der empfangenden Task + + <code> Wert des im #on("bold")##ib#send#ie##off ("bold")# angegebenen Codes +#page# + - #ib#DATA#ie#-Telegramm + + + + + + 0 1 2 3 4 5 6 7 8 9. Byte ++------+------+------+------+-------------+-------------+-------------------+ +I STX I LängeI Ziel IQuelleI Endziel I Endquelle I Strom I ++------+------+------+------+-------------+-------------+-------------------+ + + 10 11 12 13 14 ++-------------+-------------+-----------------------------------------------+ +I Sequenz I Seite I n Byte Daten (Länge = 14 + n) I ++-------------+-------------+-----------------------------------------------+ + + + <#ib#laenge#ie#> Gesamtlänge des Telegramms. + #on("b")#laenge#off("b")# = #on("b")##ib#nutzlaenge#ie##off("b")# + 14. + Für #on("b")#nutzlaenge#off("b")# sind nur die Werte 64,128,256 und 512 + zugelassen (siehe 1). #on("b")#laenge#off("b")# wird codiert dargestellt (siehe + Teil 3). + + + <#ib#sequenz#ie#> wird von Telegramm zu Telegramm hochgezählt. Sie dient + der Überwachung bzgl. verlorengegangener Telegramme + bzw. durch #ib#Zeitüberwachung#ie# verdoppelter Telegramme. + + <#ib#seite#ie#> Nummer der x-ten echt allokierten Seite des #ib#Datenraum#ie#s + (x = ((<sequenz> DIV anzahl pakete pro seite) + 2) + + <n byte> #ib#Nutzinformation#ie#. Diese gehört zur #ib#Adresse#ie# a des Daten + raums. + + a = + N (<sequenz> DIV anzahl pakete pro seite + 1) * 512 + + (<sequenz> MOD anzahl pakete pro seite) * n + + wobei N (x) die Nummer der x-ten Seite und + n die #ib#Nutzdatenlänge#ie# ist. + + Aus den Formeln ergibt sich, daß diese Nummer schon in + einem vorhergehenden DATA/OPEN-Telegramm über + mittelt wurde (im Feld <seite>). + + - #ib#QUIT#ie#-Telegramm + + + 0 1 2 3 4 5 6 7 8 9. Byte ++------+------+------+------+-------------+-------------+-------------------+ +I STX I 12 I Ziel IQuelleI Endziel I Endquelle I Strom I ++------+------+------+------+-------------+-------------+-------------------+ + + 10 11 ++-------------+ +I Quit I ++-------------+ + + + + <#ib#strom#ie#> muß die #ib#Stromnummer#ie# sein, die in dem #ib#OPEN#ie#/#ib#DATA#ie# + Telegramm stand, das quittiert wird. + + <quit> 0 : ok. Nächstes Telegramm schicken. + + -1: #ib#Übertragung#ie# neu starten (mit #ib#OPEN#ie#), weil die Emp + fangsstation das OPEN nicht erhalten hat. + + -2: Übertragung ca. 20 Telegramme zurücksetzen. + + -3: Übertragung abbrechen. + + -4: #ib#Quittung#ie# für letztes Telegramm einer Sendung. + + +e) #ib#Vermittlungsebene#ie##goalpage("vermittlung")# #goalpage("collector")# + + Diese Ebene ist dafür zuständig, Namen von Tasks auf anderen Stationen in + #ib#Task-Id#ie#'s (Werte des Typs TASK) zu wandeln und umgekehrt. Hierzu wird im + entsprechenden #ib#OPEN#ie#-Telegramm der Code -6 (bzw. -7) als <code> ein + getragen. Die #ib#Netzempfangstask#ie# erkennt diese #ib#Codes#ie# und wickelt die Aufgaben + selbst ab, so daß es dabei nicht nötig ist, irgendeine Task-Id der #ib#Zielstation#ie# zu + kennen. + + Dieses Verfahren ist möglich, weil im #on("bold")##ib#send#ie##off ("bold")# nur positive Codes erlaubt sind. +#page# +f) #ib#Höhere Ebenen#ie# + + Höhere Ebenen sind nicht mehr netzspezifisch. Sie basieren alle auf dem Send/ + Wait-Konzept des EUMEL. So gibt es z.B. den #on("bold")##ib#global manager#ie##off ("bold")#, der Aufbewah + rung und Zugriff von #ib#Datei#ie#en in einer Task regelt. Dabei darf diese Task (bei der + Variante #on("bold")##ib#free global manager#ie##off ("bold")#) auf einer beliebigen #ib#Station#ie# im Netz liegen. Wegen + des #ib#Rendezvous-Konzept#ie#s können beliebige Sicherheitsstrategien benutzt werden + (z.B.: keine Dateien an Station 11 ausliefern). Von großem Wert ist z.B., daß + man ohne weiteres das Archiv (Floppylaufwerk) einer anderen Station anmelden + und benutzen kann, wodurch eine einfache Konvertierung von Floppyformaten + möglich ist. Dies ist möglich, weil auch die Archiv-Task der Stationen sich an + das Globalmanagerprotokoll halten. + + + + + +Bemerkungen + +#ib#Fehlerbehandlung#ie# besteht bis Ebene c) darin, fehlerhafte #ib#Telegramm#ie#e einfach zu +entfernen. Die Ebene d) überwacht den Netzverkehr sowieso über #ib#Timeout#ie#s, die eine +Wiederholung eines Telegrammes bewirken, wenn die #ib#Quittung#ie# ausbleibt. + +Da bei der sendenden #ib#Station#ie# der ganze #ib#Datenraum#ie# zur Verfügung steht, ist eine +#ib#Fenstertechnik#ie# (wie bei #ib#HDLC#ie#) nicht nötig. Es kann zu jedem Zeitpunkt um beliebig +viele Telegramme zurückgesetzt werden. + +Da im EUMEL eine #ib#Textdatei#ie# ein #ib#Datenraum#ie# mit sehr komplexer Struktur ist (wegen +der Insert/Delete-Möglichkeiten, ohne den Rest der #ib#Datei#ie# zu verschieben), ist es ein +hoher Aufwand, von einem fremden Betriebssytem aus eine Textdatei in das +EUMEL-Netz zu senden. Für solche Zwecke muß noch eine einfachere Dateistruktur +definiert und entsprechende Dateikonverter erstellt werden. +#page# + +2.3. Stand der Netzsoftware + +#goalpage("2.3")# + +Das EUMEL-System wickelt die Prozedur #on("bold")##ib#send#ie##off("bold")# über das Netz ab, wenn die Sta +tionsnummer der #ib#Zieltask#ie# ungleich der eigenen #ib#Stationsnummer#ie# ist. Umgekehrt kann +man der von der Prozedur #on("bold")##ib#wait#ie##off("bold")# gelieferten Absendertask die #ib#Absenderstation#ie# entneh +men (siehe Prozedur #on("bold")##ib#station#ie##off("bold")# in Teil 1). + +Anders als bei einem #on("bold")##ib#send#ie##off("bold")# innerhalb einer Station meldet ein #on("bold")#send#off("bold")# an eine Task einer +fremden Station immer 0 zurück (Task gibt es und Task war im wait), obwohl dies +nicht der Fall sein muß. Ist die Sendung vollständig zur Zielstation übertragen, so +versucht der dortige #ib#Collector#ie# diese hundertmal im Sekundenabstand zuzustellen. +Bleibt das erfolglos, wird die Sendung vernichtet. +#pagenr ("%", 33)##setcount (1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Teil 3 : Netz Hardware Interface +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# +#page# + +Teil 3: Netz-Hardware-Interface + + +#goalpage("3")# + + +3.1. Einführung + + #goalpage("3.1")# + +In diesem Teil der Netzbeschreibung wird die #ib#Schnittstelle#ie# beschrieben, über die +#ib#Netzhardware#ie# (also #ib#Datenbox#ie#en, #ib#Netzbox#ie#en oder Netzkarten) an die EUMEL-Netz +Software angepaßt werden kann. Dieser Teil der Beschreibung ist also nur für Netz +implementatoren wichtig. + +Das EUMEL-Netz wurde dazu konzipiert, zwei oder mehr EUMEL-Rechner über +#ib#V.24#ie#-Leitungen oder Datenboxen miteinander zu vernetzen. Dem heutigen Stand der +Technik entsprechend, werden auf dem Markt eine Reihe von Möglichkeiten ange +boten, um PC's zu vernetzen. Diese Netze unterscheiden sich auch dadurch, daß +unterschiedliche Medien zur Datenübertragung benutzt werden. Das #ib#EUMEL- +Datenboxen-Netz#ie# benutzt Telefonkabel, #ib#Ethernet#ie# beispielsweise Koax-Kabel. Auch +Lichtleiter werden zur Datenübertragung benutzt. Entsprechend gibt es eine ganze +Menge Hardware (#ib#Treiber#ie#, Netzzugangsgeräte, Datenboxen, Anschlußkarten), die die +Kopplung zwischen einem #ib#I/O-Kanal#ie# eines Rechners und dem Übertragungsmedium +(Kabel) übernimmt. Das Netz-Hardware-Interface soll als #ib#Schnittstelle#ie# zwischen der +NetzSoftware und dem Treiber dienen. Damit wird es möglich, mehrere EUMEL- +Rechner über verschiedene (Teil-) Netze (in dieser Beschreibung Stränge genannt) +und unterschiedliche #ib#Netzhardware#ie# (Treiber) miteinander zu verbinden. Für den +EUMEL-Benutzer soll dabei kein Unterschied in der Benutzung des EUMEL-Netzes +feststellbar sein. +#page# +Neben unterschliedlichen Übertragungsmedien und Treibern gibt es weitere Unter +schiede zwischen Netzen: + + - in der Netztopologie (Bus-, Ring- oder Sternnetze), + + - in den Netzzugangsverfahren (Token passing, time slice token, slotting oder + CSMA/CD), + + - in der #ib#Übertragungsgeschwindigkeit#ie#, + + - im Aufbau der einzelnen #ib#Pakete#ie(1,", Aufbau der")# (#ib#Netztelegramm#ie#e). + +Alles, was mit den ersten drei Punkten zusammenhängt, wird von den Netzzugangs +geräten behandelt. + +Der Paketaufbau aber muß zumeist im Rechner geschehen und kann in den seltens +ten Fällen ganz vom Treiber übernommen werden. Ebenso kann der Treiber aus den +empfangenen Paketen nicht immer die Teile herausfiltern, die von der EUMEL- +#ib#Netzsoftware#ie# gebraucht werden. Diese Aufgaben übernimmt das #ib#Netz-Hardware- +Interface#ie#. Das Netz-Hardware-Interface stellt die #ib#Verbindung#ie# zwischen EUMEL- +#ib#Netzsoftware#ie# und den verschiedenen Netzhardwarearten dar. Ähnlich wie bei den +Drucker- und Terminal-Anpassungen wurde ein hardwareabhängiger Teil aus der +Netzsoftware abgetrennt und in einem eigenen #ib#Paket#ie# zusammengefaßt. Beim Start +des Netzes wird durch Angabe des entsprechenden #ib#Netzmodus#ie# für den jeweiligen +#ib#Kanal#ie# die entsprechende Anpassung für den benutzten Treiber ausgewählt. Wenn +andere, neue Treiber angepaßt werden sollen, so müssen lediglich in dem Paket #on("b")##ib#net +hardware interface#ie##off("b")# die entsprechenden Prozeduren hinzugefügt und die #ib#Sprungleisten#ie# +(#ib#SELECT#ie#-Statements) erweitert werden. + +Durch das #ib#Knotenkonzept#ie# in der #ib#Netzsoftware#ie# ist es möglich, über einen #ib#Knoten +rechner#ie# Teilnetze (Stränge), die mit unterschiedlicher #ib#Netzhardware#ie# arbeiten, mitein +ander zu verbinden. Es sind dann beispielsweise Verbindungen zwischen Rechnern, +die über #ib#Ethernet#ie# vernetzt sind, und Rechnern auf dem EUMEL-Datenboxen-Netz +möglich. Es ist auch möglich, mit einem Rechner Zugang zu einem Netz zu erhalten, +für das spezielle #ib#Netzhardware#ie# erforderlich ist (Datenboxen, Ethernet-Anschluß). Man +kann den Rechner über eine Rechner-Rechner-Kopplung (#ib#V.24#ie#) mit einem Rechner +verbinden, der bereits ans Netz angeschlossen ist, und so (allerdings auf Kosten der +Leistung des #ib#Knotenrechner#ie#s) Netzhardware einsparen. +#page# + +3.2. Arbeitsweise des + Netz-Hardware-Interfaces + + + + + + #goalpage("3.2")# + +Grob vereinfacht kann man sich die Arbeitsweise der #ib#EUMEL-Netz-Software#ie# so vor +stellen: + + reset box; + REP + IF zeichen da THEN lies telegramm ein + ELIF telegramm auszugeben THEN gib telegramm aus + FI + PER . + +(Es ist nur der Teil der Software beschrieben, der die Kanalbehandlung betrifft). + + +Das Zusammenspiel zwischen EUMEL-Netz und Netz-Hardware-Interface ge +schieht auf folgende Weise: + + + #on("b")#reset box;#off("b")# + REP + IF zeichen da THEN #on("b")#next packet start#off("b")#; + lies telegramm ein + ELIF telegramm auszugeben THEN gib telegramm aus + FI + PER. + + gib telegramm aus: + #on("b")#transmit header#off("b")#; + gib eumelnetztelegramm aus; + #on("b")#transmit trailer #off("b")#. + +Die fett gedruckten Programmteile werden im Netz-Hardware-Interface realisiert, die +anderen Teile stecken in den darüberliegenden Teilen der EUMEL-Netz-Software. +#page# +Beim Senden eines #ib#Telegramm#ie#s wird von der #ib#Netzsoftware#ie# zuerst der #ib#Vorspann#ie# in +einem #ib#Datenraum#ie# an das Hardware-Interface übergeben (#on("b")##ib#transmit header#ie##off("b")#). Im Hard +ware-Interface können aus dem Vorspann die entsprechenden Informationen (Tele +grammlänge, #ib#Zielstation#ie# usw.) entnommen werden. Dann wird von der Netzsoftware +das Telegramm (inklusive Vorspann) per #on("b")##ib#blockout#ie##off("b")# übergeben. Danach wird #on("b")##ib#transmit +trailer#ie##off("b")# aufgerufen, um dem Hardware-Interface das Ende des Telegramms zu mel +den. Beim Empfang ruft die Netzsoftware zuerst die #ib#I/O Control#ie# #ib#Telegrammfreigabe#ie# +auf [7]. Danach wird das erste #ib#Zeichen#ie# des Telegramms angefordert (#on("b")##ib#next packet +start#ie##off("b")#). Falls ein #ib#STX#ie# geliefert wurde, wird das Telegramm per #on("b")##ib#blockin#ie##off("b")# eingelesen. Falls +#ib#Niltext#ie# zurückgeliefert wird, wird von der Netzsoftware #ib#Timeout#ie# angenommen. Alle +anderen Zeichen werden so interpretiert, als ob Störungen aufgetreten wären. Die +Netzsoftware übernimmt die #ib#Fehlerbehandlung#ie#. Dazu wird u. U. ein Leerlesen des +Puffers vom Hardware-Interface verlangt (#on("b")##ib#flush buffers#ie##off("b")#). + +Bei der Einstellung der #ib#Nutzdatenlänge#ie# (#on("b")##ib#data length#ie##off("b")#) ist zu beachten, daß + +a) alle #ib#Station#ie#en, die an einem #ib#Strang#ie# hängen, auf die gleiche Nutzdatenlänge + eingestellt sein müssen. + +b) Wenn mehrere Stränge über #ib#Knoten#ie# miteinander verbunden sind, muß die Nutz + länge für Sendungen über Knoten (#on("b")##ib#data length via node#ie##off("b")#) auf allen Stationen des + gesamten Netzes gleich eingestellt sein. Die Zusammenfassung oder Aufteilung + von #ib#Telegramm#ie#en in Knoten ist nicht möglich. + +c) Als mögliche Nutzdatenlänge sind folgende Werte erlaubt: + + 64, 128, 256 und 512 Byte. + + Größere Nutzdatenlängen sind zur Zeit nicht möglich. + +d) Je größer die #ib#Nutzdatenlänge#ie# ist, desto geringer ist der Overhead an #ib#Zeichen#ie#, + die auf den Rechnern verarbeitet werden müssen. Allerdings muß der Rechner + leistungsfähig genug sein, die ankommenden Blöcke schnell genung zu verarbei + ten, und die Netztreiber müssen entsprechend große Puffer haben. + + +Alle implementierten Netzanpassungen sollen in einem Netz-Hardware-Interface +zusammengefaßt werden. Dies ist notwendig, um über #ib#Knotenrechner#ie# Netzstränge +verbinden zu können, die mit unterschiedlicher #ib#Netzhardware#ie# arbeiten. So können +zum Beispiel ein #ib#Strang#ie#, der mit Datenboxen aufgebaut ist, und ein #ib#Ethernet#ie#-#ib#Strang#ie# +über einen Knotenrechner miteinander verkoppelt werden. +#page# +Aus diesem Grund wurden #on("b")#Netzmodi#off("b")# eingeführt. Man kann dadurch, daß die Netz +modi, genau wie die #ib#Kanal#ie#angaben, in der #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# niedergelegt sind, ohne Aus +tausch einer Softwarekomponente die Netzhardware wechseln. Es gibt auch die +Möglichkeit, durch verschiedene Netzmodi unterschiedliche Treiber an ein und das +selbe Netz anzuschließen. Beispielsweise gibt es für einige Rechnertypen Steckkarten, +mit denen der Rechner an das Ethernet angeschlossen werden kann. Man kann, +wenn diese Karten angepaßt sind, den #ib#Ethernet#ie#-Zugang über verschiedene Netz +anschlußkarten realisieren. + +Das Netz-Hardware-Interface muß folgende Aufgaben übernehmen: + + Bei der Ausgabe an den Treiber: + + - Generieren und Ausgeben des #ib#Paket#ie#headers, + - Umsetzen von logischen Stationsadressen (#ib#Stationsnummer#ie#n) in phy + sische #ib#Adresse#ie#n, + - Ausgeben der Daten (EUMEL-Netz-#ib#Telegramm#ie#e), + - Generieren und Ausgeben des Trailers und evtl. Auffüllen des Pakets mit + #ib#Füllzeichen#ie#, falls auf dem Netz eine Mindestlänge für Pakete gefordert + wird. + + Bei der Eingabe vom Treiber: + + - Weglesen von #ib#Füllzeichen#ie#, + - Prüfen der #ib#Adresse#ie#n, + - Weglesen von #ib#Paket#ie#teilen, die in der EUMEL-Netz-Software nicht + gebraucht werden. + + Weiterhin können Funktionen wie + + - Reset des Treibers, + - Prüfung, ob Stationsadresse und #ib#Adresse#ie# im Treiber übereinstimmen, + - Statistik und Service + + durch das Netz-Hardware-Interface übernommen werden. + +Dazu wird ein Satz von Prozeduren über die #ib#DEFINES#ie#-#ib#Schnittstelle#ie# des Netz- +Hardware-Interfaces zur Verfügung gestellt. Wenn neue Treiber oder Netzarten +implementiert werden sollen, so muß an diesem Interface nichts geändert werden. Die +herausgereichten Prozeduren realisieren #ib#Sprungleisten#ie# (#ib#SELECT#ie#-Statements), über +die durch Erweiterung (#ib#CASE#ie#) die Prozeduren erreicht werden können, die den ent +sprechenden #ib#Netzmodus#ie# realisieren. Außerdem werden Informationsprozeduren für die +darüberliegenden Programmteile zur Verfügung gestellt. +#page# + +3.3. Netztreiber + + #goalpage("3.3")# +Unter #ib#Netztreiber#ie#n versteht man die Einheiten, die den Anschluß des Rechners an ein +Netz realisieren. Das können #ib#Netzbox#ie#en sein, die mit dem Rechner über eine #ib#V.24#ie#- +Leitung verbunden sind, aber auch Anschlußkarten, die direkt auf den Datenbus des +Rechners gehen. Falls die #ib#Schnittstelle#ie# der Treiber-Hardware eine andere als die +serielle #ib#V.24#ie# ist, muß in der Regel eine Anpassung für die Hardware im #ib#SHard#ie# vorge +nommen werden. + +Falls der Treiber über eine serielle #ib#V.24#ie#-#ib#Schnittstelle#ie# mit dem Rechner verbunden +ist, wie das auch bei der direkten Kopplung oder dem Datenboxennetz der Fall ist, +wird die hohe #ib#Übertragungsgeschwindigkeit#ie# auf dem eigentlichen Netz durch die +relativ geringe Übertragungsgeschwindigkeit auf der #ib#V.24#ie#-#ib#Schnittstelle#ie# zwischen +Rechner und Treiber (Box) gebremst. Über andere Schnittstellen im Rechner, wenn +sie mit #ib#Stream I/O#ie# [7] betrieben werden, kann man dies vermeiden. Diese Schnitt +stellen müssen vom SHard bedient werden. + +Wenn in den Rechner integrierte Netztreiber (Netzanschlußkarten) benutzt werden +sollen, so muß in der Regel die Behandlung dieser Netzanschlußkarte im SHard +durchgeführt werden. + +Um effizient implementieren zu können, sollte darauf geachtet werden, daß möglichst +wenig zusätzliche #ib#Zeichen#ie# von der #ib#Netzsoftware#ie# bzw. dem Netz-Hardware-Inter +face bearbeitet werden müssen. Das Auffüllen von Paketen auf eine Mindestlänge +sollte möglichst vom Treiber gemacht werden, ebenso wie das Weglesen dieser +Zeichen. + +Um einen sicheren und effektiven Netzbetrieb zu garantieren, sollten die Treiber +folgende Eigenschaften haben: + + - Die #ib#Stationsadresse#ie# ist im Treiber festgelegt, sie soll nicht ohne weiteres + verändert werden können (Datenschutz). + - Der Treiber reicht nur #ib#Paket#ie#e mit richtiger #ib#Zieladresse#ie#, keine #ib#Broad- oder + Multicasts#ie# an die Netzsoftware weiter. + - Der Treiber sendet nur #ib#Paket#ie#e mit richtiger #ib#Absenderadresse#ie# bzw. setzt die + Absenderadresse selbst ein. + - Die am Treiber eingestellte #ib#Adresse#ie# kann abgefragt werden, oder es wird, + wenn ein Paket mit falscher #ib#Absenderadresse#ie# vom Rechner kommt, eine + #ib#Fehlermeldung#ie# an den Rechner gegeben. Die Fehlermeldung muß durch das + Netz-Hardware-Interface in den #on("b")##ib#report#ie##off("b")# eingetragen werden. + - Falls Pakete mit #ib#Füllzeichen#ie# aufgefüllt werden müssen, sollten die Füll + zeichen durch den Treiber generiert und beim Empfang wieder entfernt + werden. + - Falls mehrere Betriebsmodi möglich sind, so sollten sie softwaremäßig + einstellbar sein. + - Falls die Treiber über eine serielle #ib#Schnittstelle#ie# an den Rechner angeschlos + sen werden, so sollte der Treiber konfigurierbar sein. In jedem Fall sollte die + serielle Schnittstelle mit #ib#Flußkontrolle#ie# (#ib#RTS/CTS#ie#) implementiert werden. + +Zusätzlich ist ein Transparent-Modus als #ib#Netzmodus#ie# von Vorteil: + + - Der Modus (transparent) kann zu Testzwecken benutzt werden. Beispiels + weise um auch mit Rechnern kommunizieren zu können, die über Netz + erreichbar sind, aber kein EUMEL-Netz-#ib#Protokoll#ie# benutzen. + + Modus n: transparent. + + Ausgabeseitig: Das #ib#Paket#ie# wird unverändert ausgegeben. + #ib#Adresse#ie#n usw. müssen schon im Paket vor + handen sein. Es wird nicht mit #ib#Füllzeichen#ie# + aufgefüllt. + Eingabeseitig: Das Paket wird unverändert an die Netzsoft + ware weitergegeben. + +#page# + +3.4. Prozedurschnittstelle + des EUMEL-Netzes + + + + + + #goalpage("3.4")# +Im PACKET #on("b")##ib#net hardware interface#ie##off("b")# sind folgende Prozeduren untergebracht: + + + + BOOL PROC #ib#blockin#ie# + (DATASPACE VAR ds, INT CONST seite, abstand, länge): + + Versucht, #on("b")#länge#off("b")# Zeichen vom #ib#Kanal#ie# einzulesen. Liefert TRUE, wenn alle + Zeichen eingelesen wurden, FALSE, wenn innerhalb einer bestimmten + Zeit nicht alle #on("b")#länge#off("b")# Zeichen eingelesen werden konnten (z.B. weil der + Kanal nicht mehr Zeichen anliefert). Die eingelesenen Zeichen werden im + #ib#Datenraum#ie# #on("b")#ds#off("b")# in #ib#Seite#ie# #on("b")#seite#off("b")# ab #on("b")#abstand#off("b")# bis #on("b")#abstand#off("b")# + #on("b")#länge#off("b")# - 1 abge + legt. + + #ib#Fehlerfall#ie#: + + #on("b")#blockin Abbruch#off("b")# + + Es werden weniger #ib#Zeichen#ie# innerhalb einer festgelegten Zeitspanne über + den Kanal angeliefert, als mit #on("b")#länge#off("b")# gefordert. + + Passiert z.B., wenn die Kabel während einer Netzübertragung unter + brochen werden, oder wenn die Gegenstelle abgeschaltet wird. Das + #ib#Telegramm#ie# wird vernichtet, die Prozedur liefert FALSE, es wird eine + entsprechende Meldung im #on("b")##ib#report#ie##off("b")# erzeugt. + + PROC #ib#blockout#ie# + (DATASPACE CONST ds, INT CONST seite, abstand, länge): + + Der Inhalt von Seite #on("b")#seite#off("b")# des #ib#Datenraum#ie#s #on("b")#ds#off("b")# wird von #on("b")#abstand#off("b")# bis + #on("b")#abstand#off("b")# + #on("b")#länge#off("b")# - 1 ausgegeben. +#page# + PROC #ib#set net mode#ie# (INT CONST mode): + + Es wird der #ib#Netzmodus#ie# #on("b")#mode#off("b")# eingestellt. Im Netz-Hardware-Interface + müssen alle Initialisierungen und Einstellungen vorgenommen werden, + damit die mit #on("b")#mode#off("b")# geforderte #ib#Netzhardware#ie# unterstützt wird. Diese + Prozedur wird bei jedem #on("b")##ib#start#ie##off("b")#-Kommando in der Netztask aufgerufen. + Kann als Initialisierungsprozedur für dieses PACKET verwendet werden. + Übergibt den in der #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# für diesen #ib#Kanal#ie# verlangten Netzmodus an + das Netz-Hardware-Interface. Nach Aufruf dieser Prozedur müssen die + wertliefernden Prozeduren #on("b")##ib#net mode#ie#, #ib#mode text#ie#, #ib#data length#ie##off("b")# und #on("b")##ib#data + length via node#ie##off("b")# korrekt initialisiert sein. Der Aufruf von #on("b")##ib#net addess#ie##off("b")# muß + die korrekten (physikalischen) #ib#Adresse#ie# der #ib#Station#ie#en liefern. + + TEXT PROC net address (INT CONST stationsnummer): + + Liefert die (Hardware-) Netz-#ib#Adresse#ie#, über die der EUMEL-Rechner + mit der Stationsnummer #on("b")##ib#stationsnummer#ie##off("b")# beim aktuell für diesen Kanal + eingestellten #ib#Netzmodus#ie# erreichbar ist. Auf diese #ib#Adresse#ie# muß der Treiber + des entsprechenden Rechners eingestellt sein. Auch die eigene Netz- + Adresse muß mit der im Treiber eingestellten #ib#Adresse#ie# übereinstimmen. + Insbesondere müssen alle Stationen, die auf dem Netz arbeiten, dieselbe + Netz-Adresse für eine #ib#Stationsnummer#ie# errechnen. + + TEXT PROC #ib#mode text#ie#: + + Liefert den Text (Namen) des eingestellten #ib#Netzmodus#ie#. Wird in #on("b")##ib#net + manager#ie##off("b")# benutzt, um den Netzmodus im #on("b")##ib#report#ie##off("b")# anzugeben. + + TEXT PROC mode text (INT CONST mode): + + Liefert den Text (Namen) zu dem #ib#Netzmodus#ie# #on("b")#mode#off("b")#. + + INT PROC #ib#data length#ie# (INT CONST mode): + + Liefert die #ib#Nutzdatenlänge#ie# (#ib#Länge#ie# der Nettodaten des Eumel- + Telegramms) im Netz. Wird von #on("b")##ib#basic net#ie##off("b")# beim Neustart aufgerufen. Muß + in einem Netz auf allen Stationen eines #ib#Strang#ie#s denselben Wert liefern. + + Erlaubte Werte: 64, 128, 256 und 512. +#page# + INT CONST #ib#data length via node#ie#: + + Liefert die #ib#Nutzdatenlänge#ie# für Sendungen, die über #ib#Knoten#ie# gehen. + Muß auf allen Stationen des Netzes gleich sein. + + Erlaubte Werte: 64, 128, 256 und 512. + + PROC #ib#decode packet length#ie# (INT VAR value): + + Die #ib#Länge#ie# eines Netztelegramms ist im #ib#Telegramm#ie# codiert enthalten. Mit + dieser Prozedur wird aus dem Telegrammkopf die Telegrammlänge ermit + telt: + + Falls beim Aufruf dieser Prozedur in #on("b")#value#off("b")# der Wert des Feldes #on("b")#head#off("b")# aus + der Struktur #on("b")#vorspann#off("b")#, die in #on("b")#ds#off("b")# per #on("b")##ib#transmit header#ie##off("b")# übergeben wurde, + enthalten ist, so wird in #on("b")#value#off("b")# die Länge des EUMEL-Netztelegramms + zurückgeliefert. + + PROC #ib#flush buffers#ie#: + + Liest den Eingabepuffer des #ib#Netzkanal#ie#s leer. Die eingelesenen Zeichen + werden vernichtet. Wird nach Erkennen von #ib#Übertragungsfehler#ie#n aufge + rufen. + + TEXT PROC #ib#next packet start#ie#: + + Liefert genau ein #ib#Zeichen#ie# (in der Regel das erste Zeichen des EUMEL- + Netztelegramms). Wird von der Netzsoftware immer dann aufgerufen, + wenn ein neues #ib#Paket#ie# erwartet wird. + + Bedeutung des gelieferten Zeichens für die #ib#Netzsoftware#ie#: + + #ib#STX#ie#: korrekter #ib#Telegrammanfang#ie# (ist das erste Zeichen des + EUMEL-Netztelegramms). Der Rest des EUMEL-Netztele + gramms steht im Eingabepuffer, ist also über #ib#blockin#ie# lesbar. + Vorher wurden nur Zeichen eingelesen, die zum verwendeten + #ib#Netzprotokoll#ie# gehören (z.B. #ib#Ethernet#ie#-#ib#Adresse#ie#n, #ib#Füllzeichen#ie# + usw.). + niltext: kein neues Telegramm da + + jedes andere Zeichen: + Fehler. Entweder wurden Störzeichen eingelesen oder es + gingen Zeichen verloren. #ib#Fehlerbehandlung#ie# erfolgt durch die + Netzsoftware. +#page# + PROC #ib#transmit header#ie# (DATASPACE CONST ds): + + Wird vor Ausgabe eines jeden #ib#Telegramm#ie#s aufgerufen. In dem #ib#Datenraum#ie# + #on("b")#ds#off("b")# wird von der EUMEL-Netz-Software der #on("b")##ib#Vorspann#ie##off("b")# übergeben. Über + den jeweiligs eingestellten #ib#Netzmodus#ie# kann für jede implementierte Netz + art über eine #ib#Sprungleiste#ie# (#ib#SELECT#ie#) die Prozedur angesprungen werden, + die den #ib#Header#ie# für den eingestellten Netzmodus erstellt und ausgibt. + Struktur des von der EUMEL-Netz-Software benutzten Headers: + + BOUND STRUCT + (INT head, + zwischenziel, + zielrechner, + quellrechner, + strom, + sequenz, + seitennummer ) VAR vorspann. + + Aus dem Inhalt des Feldes #on("b")#head#off("b")# kann mittels #on("b")##ib#decode packet length#ie##off("b")# die + Gesamtlänge des EUMEL-Netztelegramms errechnet werden. + + PROC #ib#transmit trailer#ie#: + + Wird nach Ausgabe eines jeden Telegramms aufgerufen. Evtl. notwendige + Nachspänne können ausgegeben werden. Die notwenigen Informationen + wurden in #on("b")##ib#transmit header#ie##off("b")# übergeben und müssen aufbewahrt werden, + falls sie im Trailer mitgeliefert werden müssen. Kann auch dazu benutzt + werden, den unter diesem Packet liegenden Schichten (#ib#SHard#ie# oder Hard + ware) das Ende des Telegramms mitzuteilen. Notwendige #ib#Füllzeichen#ie# + können in dieser Prozedur in das #ib#Paket#ie# eingebaut werden. + + PROC #ib#reset box#ie# (INT CONST net mode): + + Kann zur Initialisierung der #ib#Netzhardware#ie# benutzt werden. Wird von #on("b")##ib#basic + net#ie##off("b")# beim jedem Neustart aufgerufen. + + INT PROC #ib#max mode#ie#: + + Liefert den Wert des größten erlaubten (implementierten) #ib#Netzmodus#ie#. + + INT PROC #ib#net mode#ie#: + + Liefert den eingestellten Netzmodus. +#page# +#pagenr ("%", 45)##setcount (1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Anhang +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# +#clear pos##lpos(1.0)##rpos(9.5)##goalpage("A")# + +Anhang: Netz-Meldungen#goalpage("A.1")# + +Mit dem Kommando #on("b")##ib#list#ie# (/"net list")#off("b")# (siehe Teil 1) erhalten Sie eine temporäre #ib#Datei#ie# +auf den Bildschirm. Diese Datei könnte ungefähr so aussehen: + +____________________________________________________________________________ + + N e u e r S t a r t 12:44 Stationsnummer : 38 + 01.06.87 12:55 net port 8:20:Nicht zustellbar. . Empfänger: "net dok". Quelle 34 Taskindex: 255 + 02.06.87 06:30 net port 8:1:wdh data. sqnr 7. Absender: "net dok". Ziel 34 Taskindex: 255 + 02.06.87 07:03 net port:20:Sequenzfehler: soll 13 ist 14. Empfänger: "POST". Quelle 33 Taskindex: + 02.06.87 07:03 net port:blockin abbruch + 02.06.87 07:03 net port:20:Sequenzreset von 13 auf 10. Empfänger: "POST". Quelle 33 Taskindex: 29 + 02.06.87 07:36 net port:Call gelöscht."net dok". Strom 1 + 02.06.87 07:43 net port 8:verbotene Route: 34 + 02.06.87 07:50 net port:Header inkorret eingelesen: %0 %2 + 02.06.87 07:50 net port:buffers flushed + 02.06.87 07:52 net port:Weiterleitung nicht möglich für 34 + 02.06.87 07:53 net port 8:skipped0 6 G O 1 0 . 0 %13 %10 2 8 0 6 0 6 G O 1 0 . 0 %13 %10 2 8 0 + 02.06.87 08:14 net port 8:skipped%13 %10 S p e c . R e c e i v e E r r o r C 2 + 02.06.87 08:21 net port:20:Reopen. Empfänger: "WÜFE". Quelle 40 Taskindex: 22 + 02.06.87 09:25 net port:1:etwas rueckgespult. Absender: "-". Ziel 33 Taskindex: 51 + 02.06.87 09:25 net port:1:wdh data. sqnr 20. Absender: "-". Ziel 33 Taskindex: 51 + 02.06.87 09:54 net port:20:Blocknummer falsch, neu: 192, alt : -1. Empfänger: "WÜFE". Quelle 44 + 02.06.87 10:12 net port:Daten ohne Eroeffnung von 40 Sequenznr 7 + 02.06.87 10:23 net port:Header inkorret eingelesen: O X 0 3 8 B O X 0 4 4 E U %2 + 02.06.87 10:23 net port:buffers flushed + 02.06.87 10:49 net port:1:wdh open. Absender: "-". Ziel 33 Taskindex: 255 + 02.06.87 10:49 net port:2:wdh open. Absender: "net dok". Ziel 33 Taskindex: 255 + 02.06.87 10:53 net port:1:Sequenzfehler: soll 2 ist 3. Empfänger: "net dok". Quelle 33 Taskindex: + 02.06.87 10:54 net port:1:Sequenzreset von 8 auf 5. Empfänger: "net dok". Quelle 33 Taskindex: 11 + 02.06.87 10:56 net port:2:etwas rueckgespult. Absender: "-". Ziel 33 Taskindex: 51 + bekannte Stationen: + 1(8,1) 2(8,2) 3(8,3) 4(8,4) 5(8,5) 6(8,6) 7(8,7) 8(8,8) 9(8,9) 10(8,10) + 11(8,11) 12(8,12) 13(8,13) 14(8,14) 15(8,15) 16(8,16) 17(8,17) 18(8,18) + 19(8,19) 20(8,20) 21(8,21) 22(8,22) 23(8,23) 24(8,24) 25(8,25) 26(8,26) + 27(8,27) 28(8,28) 29(8,29) 30(8,30) 31(8,31) 32(8,32) 33(9,33) 34(8,34) + 35(9,35) 36(9,36) 37(9,37) 39(9,39) 40(9,40) 41(9,41) 42(9,42) 43(9,43) + 44(9,44) 45(9,45) 46(9,46) 47(9,47) 48(9,48) + -------- + Eingestellte Netzmodi: + net port 8 haengt an Kanal 8, Modus: (1) EUMEL-Netz 64 Byte + net port haengt an Kanal 9, MODUS: (11) ETHERNET via V.24 512 Byte + + Nutzdatenlänge 512 Byte + Nutzdatenlänge bei indirekter Verbindung: 64 Byte + ******** + Netz-Software vom 23.05.87 + Rechner 38 um 11:11 + net port 8 + + Strom 1 (sqnr7/8) sendet an 34 . Absender ist "net dok". + net port + + Strom 1 (sqnr45/45) empfaengt von 40 . Empfaenger ist "PUBLIC". + +____________________________________________________________________________ +#page# +Die Datei enthält den aktuellen #on("b")##ib#report#ie##off("b")#, in dem #ib#Fehlermeldung#ie#en der einzelnen Tasks +gesammelt werden. Außerdem wird der Zustand aller Verbindungen (Ströme) von allen +#on("b")##ib#net port#ie##off("b")#'s angezeigt. Im #on("b")#report#off("b")#-Teil kann man drei Informationsblöcke unterscheiden: + +a) den Block mit den Fehlermeldungen. Es werden jeweils Datum, Uhrzeit, der Name + des betroffenen #on("b")#net port#off("b")# und, wenn notwendig, die #ib#Stromnummer#ie# angegeben. + Darauf folgt der Meldungstext, der auch Informationen über Absender und Emp + fänger enthalten kann. + + <Datum> <Zeit> <Name der #ib#Kanaltask#ie#> : [<#ib#Stromnummer#ie#> : ] <Meldung> + + +b) den Block mit der Liste der bekannten #ib#Station#ie#en. Ein Eintrag in dieser Liste ent + hält jeweils die Stationsnummer der bekannten Station und in Klammern dahin + ter die Nummer des Kanals auf diesem Rechner, über den die Station erreichbar + ist und die Nummer der nächsten #ib#Zwischenstation#ie#. + + <Zielstation> (<Kanalnr>,<Zwischenstation>) + + Bei direkt erreichbaren Stationen ist Zwischenstation gleich #ib#Zielstation#ie#. + + Hinweis: Auch #ib#gesperrt#ie#e Stationen erscheinen in dieser Liste. + + +c) den Block, der Auskunft über die Netzinstallation gibt. Es werden für jeden Netz + kanal die eingestellten Netzmodi angegeben. Des weiteren werden die beiden + Größen #on("b")##ib#data length#ie##off("b")# (#ib#Nutzdatenlänge#ie#) und #on("b")##ib#data length via node#ie##off("b")# (Nutzdatenlänge bei + indirekter Verbindung) angegeben. Zusätzlich erscheinen noch die #ib#Netzversion#ie# und + die genaue Uhrzeit, zu der dieser #on("b")#report#off("b")# erstellt wurde. + +#page# +Für jeden #on("b")##ib#net port#ie##off("b")# wird pro aktivem #ib#Strom#ie# folgende Meldung generiert: + +Strom <Stromnr> (sqnr<akt Seqnr>/<max Seqnr>) <Zustand> <Partner> + + +<Stromnr> #ib#Stromnummer#ie# + +<akt Seqnr> #ib#Sequenznummer#ie# des gerade bearbeiteten #ib#Telegramm#ie#s + +<max Seqnr> Bei #ib#Sendeströme#ie#n die Nummer der letzten zu übertragenden + #ib#Sequenz#ie#, bei Empfangsströmen in der Regel die Nummer der + letzten Sequenz der gerade übertragenen #ib#Datenraumseite#ie#. + +<#ib#Zustand#ie#> Hier wird die Aktion (senden, empfangen usw.) und die Partner + station angegeben. + +<#ib#Partner#ie#> Der Name der Task mit der kommuniziert wird. + + +Die Meldungen, die in der #ib#Datei#ie# #on("b")##ib#report#ie##off("b")# protokolliert werden, kann man in verschiedene +Gruppen einordnen. Die eine Gruppe beschreibt Störungen durch #ib#Zeichenverluste#ie# +oder verfälschungen, eine andere Gruppe protokolliert besondere Situationen, bei +spielsweise den Abbruch von #ib#Übertragung#ie#en, und die letzte Gruppe befasst sich mit +#ib#Fehlermeldung#ie#en, die ein Eingreifen von aussen notwendig machen. Je nachdem, ob +die Station, auf der die Meldung protokolliert wird, Empfänger oder Absender ist, wird +bei den Meldungen #ib#Stationsnummer#ie# und Taskname des Kommunikationspartners mit +angegeben. + +Zur ersten Gruppe gehören: + +#ib(4)##ib#skipped#ie##ie(4)# + 'skipped' oder skipped mit einem Zusatztext erscheint, wenn Zei + chen eingelesen wurden, die zu keinem gültigen #ib#Telegramm#ie# ge + hören. Dies kann passieren, wenn auf der Leitung zwischen + Rechner und Box #ib#Zeichen#ie# verlorengegangen sind. Auch nach dem + Einschalten oder nach einem Reset auf Box oder Rechner kann + diese Meldung kommen. Mindestens ein Teil der eingelesenen + Daten wird mit ausgegeben, wobei Steuerzeichen durch % und den + Code des Steuerzeichens dargestellt werden. Die einzelnen Zeichen + werden durch ein Blank voneinander getrennt. +#page# +#ib(4)##ib#Sequenzfehler#ie##ie(4)# + Die #ib#Sequenznummer#ie# ist zu groß, es fehlen also Telegramme. Die + Gegenstation wird aufgefordert, ab einem früheren Telegramm zu + wiederholen. + +#ib(4)#wdh data#ie(4)# + Das letzte Telegramm wird erneut geschickt. Passiert, wenn die + #ib#Quittung#ie# für dieses Telegramm nach einer bestimmten Zeit nicht + angekommen ist. + +#ib(4)##ib#Sequenzreset#ie##ie(4)# + Die #ib#Sequenznummer#ie# des empfangenen Telegramms ist kleiner als + die Sequenznummer des vorher empfangenen Telegramms. Die + Verbindung wird bei der zuletzt empfangenen Sequenznummer + fortgesetzt. + +#ib(4)#Blocknummer falsch#ie(4)# + Die #ib#Seitennummer#ie# in dem #ib#Telegramm#ie# ist falsch. + +#ib(4)#etwas rueckgespult#ie(4)# + Auf Anforderung der Gegenseite werden die letzten drei #ib#Datenraum + seite#ie#n erneut übertragen. + +#ib(4)#Daten ohne Eroeffnung#ie(4)# + Es werden Telegramme mit einer #ib#Stromnummer#ie# empfangen, zu der + vorher kein OPEN-Telegramm empfangen wurde. In diesem Fall + wird die Gegenstation aufgefordert, die #ib#Übertragung#ie# von vorn zu + beginnen. Diese Meldung kann auch kommen, wenn das Netz neu + gestartet wurde. + +#ib(4)#wdh open#ie(4)# + Die Übertragung wird mit dem #ib#OPEN#ie#-Telegramm von vorn begon + nen. Passiert auf Aufforderung durch die Gegenstation oder wenn + das erste OPEN-Telegramm nicht quittiert wurde. + +#ib(4)##ib#buffers flushed#ie##ie(4)# + Alle bereits eingelesenen, aber noch nicht bearbeiteten Zeichen + wurden gelöscht (der #ib#Eingabepuffer#ie# wurde komplett gelöscht). Verur + sacht durch schwere Störungen (#ib#Zeichenverluste#ie# oder -verfäl + schungen). +#page# +#ib(4)#blockin abbruch#ie(4)# + Es wurden nicht alle Zeichen eines Telegramms innerhalb eines + bestimmten Zeitraums angeliefert. + +#ib(4)#Header inkorrekt eingelesen#ie(4)# + Es wurde ein Fehler in dem Teil des Netztelegramms gefunden, der + nicht zum EUMEL-Netz gehört. + +#ib(4)#Strom falsch in Quittung#ie(4)#: + In der #ib#Quittung#ie# wurde eine nicht zulässige #ib#Stromnummer#ie# festge + stellt. Zulässig sind Stromnummern zwischen 1 und 20. + +#ib(4)#Neustart#ie(4)# + Die Gegenstation hat die #ib#Verbindung#ie# von vorne begonnen. + +#ib(4)#Falsche Seitennummer#ie(4)# + Die #ib#Seitennummer#ie# in dem empfangenen Telegramm ist falsch. + Einige Telegramme werden wiederholt. + +#ib(4)#Absteigende Seitennummern#ie(4)# + Die Seitennummer in dem empfangenen Telegramm ist kleiner als + die Seitennummer im vorigen #ib#Telegramm#ie#. Es müssen einige Tele + gramme wiederholt werden. + + +Die folgenden Meldungen beschreiben Situationen, die nicht durch #ib#Zeichenverluste#ie# +entstehen, mit denen die #ib#Netzsoftware#ie# selbst fertig wird: + + +#ib(4)#Sendung von Gegenstelle gelöscht#ie(4)# + Die Verbindung wurde von der Gegenstelle abgebrochen. + +#ib(4)#Empfangseintrag freigegeben#ie(4)# + Die Verbindung wurde von der empfangenden #ib#Station#ie# gelöscht, weil + seit dem Eintreffen des letzten Telegramms zuviel Zeit vergangen ist + (#ib#Timeout#ie#). + +#ib(4)#Irrläufer#ie(4)# + Eine #ib#Intertaskkommunikation#ie# innerhalb der eigenen Station wurde + fälschlicherweise über den #on("b")##ib#Collector#ie##off("b")# abgewickelt. Dieser Vorgang + wird abgebrochen. +#page# +#ib(4)#Call-Löschung vorgemerkt#ie(4)# + Sobald der Call abgewickelt ist, wird diese Verbindung gelöscht. + Beispielsweise führt ein vom Benutzer abgebrochenes #on("b")##ib#name#ie##off("b")# zu + dieser Meldung. + +#ib(4)#Call gelöscht#ie(4)# + Die #ib#Verbindung#ie# wurde auf Anforderung durch den Auftraggeber + gelöscht. + +#ib(4)#Quellrechner#ie(4)# + Als #ib#Quellrechnernummer#ie# wurde ein unzulässiger Wert festgestellt. + Zulässig sind Zahlen zwischen 1 und 127. + +#ib(4)#Nicht zustellbar#ie(4)# + Innerhalb eines bestimmten Zeitraums war die #ib#Zieltask#ie# nicht emp + fangsbereit. Die Verbindung wird abgebrochen. + +Bei diesen Meldungen sollten die #ib#Routenanweisungen#ie# überprüft werden: + +#ib(4)#Verbotene Route bei Quittung#ie(4)# + Die #ib#Quittung#ie# kommt auf einer nicht erlaubten #ib#Route#ie# an. Dies kann + bei #ib#Vermaschung#ie# passieren, oder aber, wenn eine Station versucht, + sich für eine andere Station auszugeben. + +#ib(4)#Verbotene Route#ie(4)# + Die danach bezeichnete Station versucht, auf einer anderen Route + mit diesem Rechner zu kommunizieren, als auf der Route, die für + diesen Rechner in der Datei #on("b")##ib#netz#ie##off("b")# festgelegt wurde. + + Abhilfe: + #ib#Routentabellen#ie# der beiden (oder, falls die Meldung auf einer + #ib#Knotenstation#ie# erscheint, auf allen beteiligten) Stationen abgleichen. + +#ib(4)#Weiterleitung nicht möglich#ie(4)# + Die #ib#Routeninformationen#ie# auf dem #ib#Knotenrechner#ie#, wo diese Meldung + erscheint, und der sendenden #ib#Station#ie# stimmen nicht überein. Die + angegebene Station ist von dieser Station aus nicht erreichbar. + + Abhilfe: + #ib#Routentabellen#ie# der Stationen überprüfen. + +#ib(4)#Fremdzugriff#ie(4)# + Eine #ib#gesperrt#ie#e Station hat versucht, auf diesen Rechner mit #ib#Sende + codes#ie# > 6 zuzugreifen. + + +Folgende Meldungen betreffen '#ib#harte Fehler#ie#'. Diese Fehler werden von der Netzsoft +ware nicht abgefangen. In jedem Fall muß das Netz nach einer solchen #ib#Fehler +meldung#ie# neu gestartet werden. + +#ib(4)#++++++#ie(4)# + Meldungen dieser Form sind 'harte' Fehler. Der aufgetretene Fehler + wird mit angegeben. Das Netz muß neu gestartet werden, da die + Task, in welcher der Fehler aufgetreten ist, gelöscht wird. + +#ib(4)#Verbindungsengpaß#ie(4)# + Es sind mehr Verbindungen festgestellt worden, als zulässig sind. + Nach dieser Meldung wurde der entsprechende Netport gelöscht. + + +Literaturverzeichnis + + +#goalpage("A.2")# + +#clear pos# +#lpos(1.0)##lpos(2.5)# +#table# +[1] EUMEL-Systemhandbuch, Teil 5, Intertaskkommunikation + GMD St. Augustin, 1986 +[2] EUMEL-Systemhandbuch, Teil 2, Hardware und ihre Steuerung +[3] EUMEL-Systemhandbuch, Teil 8, Spooler +[4] EUMEL-Netz Installationsanweisung + GMD St. Augustin, 1987 +[5] EUMEL-Systemhandbuch, Teil 4, Blockorientierte Ein/Ausgabe +[6] EUMEL-Quellcode, Packet #on("b")#tasks#off("b")# + GMD St. Augustin, 1986 +[7] EUMEL-Portierungshandbuch 8086, Version 8 + GMD St. Augustin, 1987 + +#table end# + + diff --git a/system/net/1.8.7/doc/netzhandbuch.anhang b/system/net/1.8.7/doc/netzhandbuch.anhang new file mode 100644 index 0000000..17d1ece --- /dev/null +++ b/system/net/1.8.7/doc/netzhandbuch.anhang @@ -0,0 +1,58 @@ +#pagenr ("%", 51)##setcount##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Anhang +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# +#clear pos##lpos(0.0)##rpos(11.0)##fillchar(".")# +Anhang: Netz-Fehlermeldungen + +#table# +++++++ 50 +Absteigende Seitennummern 48 +blockin abbruch 48 +Blocknummer falsch 47 +buffers flushed 47 +Call gelöscht 49 +Call-Löschung vorgemerkt 49 +Collectortask fehlt 8, 18 +Daten ohne Eroeffnung 47 +Empfangseintrag freigegeben 48 +etwas rueckgespult 47 +Falsche Seitennummer 48 +Fremdzugriff 50 +Header inkorrekt eingelesen 48 +Irrläufer 48 +kein Zugriff auf Station 14 +Neustart 48 +Nicht zustellbar 49 +Quellrechner 49 +Sendung von Gegenstelle gelöscht 48 +Sequenzfehler 47 +Sequenzreset 47 +skipped 46 +Station x antwortet nicht 8, 11, 16 +Station x gibt es nicht 9, 11, 13 +Strom falsch in Quittung 48 +Task "..." gibt es nicht 8 +Verbindungsengpaß 50 +Verbotene Route 49 +Verbotene Route bei Quittung 49 +wdh data 47 +wdh open 47 +Weiterleitung nicht möglich 49 +#table end# + diff --git a/system/net/1.8.7/doc/netzhandbuch.index b/system/net/1.8.7/doc/netzhandbuch.index new file mode 100644 index 0000000..01d8a0f --- /dev/null +++ b/system/net/1.8.7/doc/netzhandbuch.index @@ -0,0 +1,259 @@ +#pagenr ("%", 52)##setcount (1)##block##pageblock##count per page# +#headeven# +#center#EUMEL Netzbeschreibung +#center#____________________________________________________________ + +#end# +#headodd# +#center#Anhang +#center#____________________________________________________________ + +#end# +#bottomeven# +#center#____________________________________________________________ +Netz - % #right#GMD +#end# +#bottomodd# +#center#____________________________________________________________ +GMD #right#Netz - % +#end# +#clear pos##lpos(0.0)##rpos(11.0)##fillchar(".")# +Anhang: Index + +#table# +/ 8, 9, 24 +Absenderadresse 39 +Absenderstation 28, 32 +Adresse 29, 37, 39, 41, 42 +aktiviere netz 14, 15, 18 +basic net 41, 43 +Baud 6, 18, 25 +blockin 23, 36, 40, 42 +blockout 23, 36, 40 +Broad- oder Multicasts 38 +buffers flushed 47 +CASE 37 +CLOSE 27 +collected destination 22, 24 +Collector 22, 24, 32, 48 +Collectortask 8, 18, 22 +configurate 6 +continue 7, 21 +CRC-Code 26 +DATA 27, 29, 30 +data length 23, 36, 41, 45 +data length via node 23, 36, 41, 42, 45 +Datei 2, 5, 7, 12, 13, 14, 18, 20, 24, 31, 37, 41, 44, 46 +Datenbox 2, 6, 33 +Datenraum 13, 15, 21, 23, 24, 27, 28, 29, 31, 36, 40, 43 +Datenraumseite 23, 46, 47 +decode packet length 42, 43 +define collector 22, 24 +definere netz 15 +DEFINES 37 +define station 5, 22 +definiere netz 14 +Dreher 16 +Durchsatz 3 +Eingabeprozeduren 21 +Eingabepuffer 47 +Empfangspuffer 15 +Empfangsströme 13, 15 +endquelle 28 +endziel 28 +erase 13, 19 +erlaube 14 +Ethernet 33, 34, 36, 37, 42 +EUMEL0 21, 22, 24 +EUMEL-Datenboxen-Netz 33 +EUMEL-Netz-Software 35 +exists 11 +Fehler 8, 16, 17, 18 +Fehlerbehandlung 31, 36, 42 +Fehlerfälle 8 +Fehlerfall 11, 40 +Fehlermeldung 13, 15, 20, 26, 39, 45, 46, 50 +Fehlersituationen 12 +Fehlersuche 16 +Fenstertechnik 31 +fetch 10, 18 +flush buffers 36, 42 +Flußkontrolle 7, 15, 27, 39 +free global manager 10, 19, 31 +Füllzeichen 37, 39, 42, 43 +gesperrt 13, 14, 45, 50 +global manager 19, 31 +harte Fehler 50 +HDLC 31 +Header 43 +Höhere Ebenen 31 +inchar 21 +incharety 23 +Installation 2 +Installationsanleitung 2 +Intertaskkommunikation 48 +I/O Control 36 +I/O-Kanal 33 +Kanal 3, 6, 7, 12, 14, 15, 20, 21, 23, 24, 34, 37, 40, 41 +Kanalnummer 14 +Kanaltask 45 +Knoten 3, 4, 17, 20, 23, 36, 42 +Knotenkonzept 3, 34 +Knotenrechner 34, 36, 49 +Knotenstation 13, 14, 20, 49 +Kommunikation 17 +Kommunikationindirekte 23 +konfigurieren 6 +Länge 29, 41, 42 +Längenangabe 26 +list 10, 12, 17, 44 +listoption 12, 14, 15 +Löschversuche 13 +Manager 10, 19 +Masseschluß 16 +max mode 43 +mode text 41 +Nachbarn 4, 28 +Nachbarstation 24, 28 +name 11, 24, 49 +net 7, 12, 13 +net addess 41 +net hardware interface 34, 40 +net install 7 +net list 12, 15 +net manager 41 +net mode 41, 43 +net port 7, 8, 12, 13, 18, 45, 46 +net timer 14 +netz 7, 14, 15, 20, 37, 41, 49 +Netzbox 3, 6, 20, 33, 38 +Netzdefinition 14 +Netzebene 26 +Netzempfangstask 30 +Netzhardware 2, 17, 21, 24, 33, 34, 36, 41, 43 +Netz-Hardware-Interface 34 +Netzinstallation 17 +Netzkanal 13, 14, 42 +Netzknoten 3 +Netzkonfiguration 7, 20 +Netzmodus 34, 37, 39, 41, 43 +Netzprotokoll 42 +Netzsoftware 2, 3, 18, 20, 34, 36, 38, 42, 48 +Netzstrang 4, 17, 23 +Netztask 15, 16, 21, 24 +Netztelegramm 34 +Netztreiber 38 +Netzübertragungen 12 +Netzversion 2, 45 +next packet start 36, 42 +niltext 11, 36 +Nutzdaten 23 +Nutzdatenlänge 17, 23, 29, 36, 41, 42, 45 +Nutzinformation 29 +nutzlaenge 29 +OPEN 27, 28, 30, 47 +Paket 23, 34, 37, 38, 39, 42, 43 +Pakete, Aufbau der 34 +Partner 46 +Paßwort 19 +Pin-Belegung 6 +port intern 13, 15, 24 +Printerserver 20 +Protokoll 6, 13, 24, 39 +Protokollebenen 25 +Prüfsummen 18 +Quelle 23, 26, 28 +Quellrechnernummer 49 +Quellstationsnummer 20 +quelltask 21, 24, 28 +Querarchivierungen 10 +QUIT 27, 28, 30 +Quittung 30, 31, 47, 48, 49 +Rechnerkopplung 3 +Rendezvouskonzept 21, 31 +report 8, 12, 18, 39, 40, 41, 45, 46 +reserve 10 +RESET 17 +reset box 43 +Route 13, 15, 17, 20, 49 +routen 14 +Routenanweisungen 49 +routen aufbauen 13, 14, 15 +Routeninformationen 20, 49 +Routentabelle 9, 13 +Routentabellen 24, 49 +router 13 +RS422 25 +RTS/CTS 6, 25, 39 +Rückmeldeparameter 21 +run 13 +save 10, 19 +Schnittstelle 3, 15, 18, 20, 25, 33, 37, 38, 39 +SDLC 25, 26 +seite 28, 29, 40 +Seiten 27 +Seitengrenze 23 +Seitennummer 47, 48 +SELECT 34, 37, 43 +send 21, 22, 24, 27, 28, 30, 32 +Sendecode 24 +Sendecodes 50 +Sendeströme 13, 46 +Sendungskonzept 2 +sequenz 28, 29, 46 +Sequenzfehler 47 +Sequenznummer 46, 47 +Sequenzreset 47 +set net mode 41 +SHard 38, 43 +Sicherheitskonzept 19 +Sicherheitsprobleme 19 +skipped 46 +sperre 14 +Spoolmanager 5 +Sprungleiste 43 +Sprungleisten 34, 37 +start 5, 13, 16, 18, 41 +starte kanal 14, 15 +station 2, 5, 8, 10, 12, 13, 16, 19, 20, 22, 24, 26, 31, 32, 36, 41, 45, 48, 49 +Stationen, sicherheitsrelevante 20 +Stationsadresse 38 +Stationsnummer 5, 10, 16, 22, 24, 26, 32, 37, 41, 46 +Stationsnummer maximale 14 +Strang 3, 17, 20, 36, 41 +Stream I/O 23, 38 +strom 28, 30, 46 +Stromnummer 13, 28, 30, 45, 46, 47, 48 +STX 26, 36, 42 +Task-Id 5, 22, 24, 28, 30 +Telegramm 20, 23, 26, 27, 28, 31, 36, 37, 40, 42, 43, 46, 47, 48 +Telegrammanfang 42 +Telegrammformat 26 +Telegrammfreigabe 36 +Textdatei 31 +Timeout 31, 36, 48 +transmit header 36, 42, 43 +transmit trailer 36, 43 +Treiber 33 +Übertragung 26, 30, 46, 47 +Übertragungsfehler 42 +Übertragungsgeschwindigkeit 34, 38 +Übertragungsweg 23 +V24 3, 4, 15, 17, 18, 20, 25, 33, 34, 38 +Verbindung 3, 6, 16, 18, 27, 28, 34, 48, 49 +Vermaschung 4, 49 +Vermittlungsebene 24, 30 +Vorspann 36, 43 +wait 19, 21, 24, 27, 32 +Worker 5 +Zeichen 36, 38, 40, 42, 46 +Zeichenverluste 46, 47, 48 +Zeitüberwachung 26, 29 +ziel 28 +Zieladresse 38 +Zielstation 4, 8, 24, 28, 30, 36, 45 +Zieltask 21, 22, 24, 28, 32, 49 +Zustand 46 +Zwischenstation 45 +#table end# + diff --git a/system/net/1.8.7/source-disk b/system/net/1.8.7/source-disk new file mode 100644 index 0000000..5a39f6c --- /dev/null +++ b/system/net/1.8.7/source-disk @@ -0,0 +1 @@ +grundpaket/11_austausch.img diff --git a/system/net/1.8.7/src/basic net b/system/net/1.8.7/src/basic net new file mode 100644 index 0000000..c5e9278 --- /dev/null +++ b/system/net/1.8.7/src/basic net @@ -0,0 +1,1148 @@ +PACKET basic net DEFINES (* D. Heinrichs *) + (* Version 10 (!) *) (* 18.02.87 *) + nam, (* 03.06.87 *) + max verbindungsnummer, (* *) + neuer start, + neue routen, + packet eingang, + neue sendung, + zeitueberwachung, + verbindung, + loesche verbindung: + +TEXT PROC nam (TASK CONST t): + IF t = collector THEN name (t) + ELIF station (t) <> station (myself) + THEN "** fremd "+text(station(t))+" **" + ELSE name (t) + FI +END PROC nam; + +INT PROC tasknr (TASK CONST t): + IF t = collector THEN maxtasks + ELSE index (t) + FI +END PROC tasknr; + +LET + maxtasks = 127, + maxstat = 127, + max strom = 20, + max strom 1 = 21, + stx = ""2"", + code stx = 2, + error nak = 2, + seiten groesse = 512, + dr verwaltungslaenge = 8, + dr verwaltungslaenge2=10, + openlaenge = 24, + vorspannlaenge = 14, + ack laenge = 12, + min data length = 64, + (* Codes der Verbindungsebene *) + + task id code = 6, + name code = 7, + task info code = 8, + routen liefern code = 9, + + (* Typen von Kommunikationsströmen *) + + send wait = 0, + zustellung = 1, + call pingpong = 2, + call im wait = 3, + call im abbruch = 4, + call in zustellung = 5, + + (*quittungscodes*) + + ok = 0, + von vorne = 1, + wiederhole = 2, + loesche = 3, + beende = 4; + +LET STEUER = + STRUCT ( + INT head, + zwischenziel, + zielrechner, + quellrechner, + strom, + sequenz, + seitennummer, + TASK quelle,ziel, + INT sende code); + +BOUND STEUER VAR open block; + +BOUND STRUCT (STEUER steuer, INT typ, maxseq) VAR info block; + +BOUND STRUCT ( + INT head, + zwischenziel, + zielrechner, + quellrechner, + strom, + sequenz, + seitennummer) VAR vorspann ; + +LET ACK = STRUCT ( + INT head, + zwischenziel, + zielrechner, + quellrechner, + strom, + code); +BOUND ACK VAR ack packet ; +BOUND ACK VAR transmitted ack packet; + +BOUND STRUCT (ROW maxstat INT port, + ROW maxstat INT zwischen) VAR route; + +INT CONST max verbindungsnummer := max strom; +INT VAR codet,net mode, nutzlaenge := data length, + data len via node := data length via node; + +TEXT VAR buffer first; + +DATASPACE VAR work space := nilspace; +DATASPACE VAR transmitted ack space := nilspace; + + +INT VAR pakete pro seite, + pakete pro seite minus 1, + packets per page via node, + packets per page via node minus 1, + datenpacketlaenge via node, + datenpacketlaenge ; + +INT VAR strom; +INT VAR last data := -1; +INT VAR own:=station (myself) , + quit max := 3, + quit zaehler := 3, + own256 := 256*own; +INT CONST stx open := code stx+256*openlaenge, + stx quit := code stx+256*acklaenge; + + STEUER VAR opti; + ROW maxstrom1 STEUER VAR verbindungen; + ROW maxstrom1 DATASPACE VAR netz dr; + ROW maxstrom1 INT VAR zeit, typ, open try; + FOR strom FROM 1 UPTO maxstrom1 REP vdr := nilspace; forget (vdr) PER; + ROW maxstrom INT VAR dr page ; + ROW maxtasks INT VAR alter call; + +.vx : verbindungen (strom). + +vdr: netz dr (strom). + + via node: + vx.zielrechner <= 0 OR vx.quellrechner <= 0 OR + transmit via node OR receive via node. + + transmit via node: + route.zwischen (vx.zielrechner) <> vx.zielrechner AND vx.zielrechner <> own. + + receive via node: + route.zwischen (vx.quellrechner) <> vx.quellrechner AND vx.quellrechner <> own. + +falsche stromnummer: strom < 1 OR strom > maxstrom. + +zielrechner ok: vorspann.zielrechner > 0 AND vorspann.zielrechner <= maxstat. + +quellrechner ok: vorspann.quellrechner > 0 + AND vorspann.quellrechner <= maxstat. + +call aufruf: typ(strom) >= call pingpong. + +alles raus: vx.seitennummer = -1 AND letztes packet der seite . + +letztes packet der seite : +(vx.sequenz AND packets per page minus 1) = packets per page minus 1. + +neue verbindung: code t = open laenge. + +PROC neue routen: + route := old ("port intern"); +END PROC neue routen; + +PROC neuer start (INT CONST empfangsstroeme, mode): + net mode := mode; + strom := 1; + neue routen; + transmitted ack space := nilspace; + workspace := nilspace; + open block := workspace; + info block := workspace; + nutzlaenge := data length; + data len via node := data length via node; + pakete pro seite:= seitengroesse DIV nutzlaenge; + pakete pro seite minus 1 := pakete pro seite -1; + packets per page via node := seitengroesse DIV data len via node; + packets per page via node minus 1 := packets per page via node - 1; + datenpacketlaenge := vorspannlaenge + nutzlaenge; + datenpacketlaenge via node := vorspannlaenge + data len via node; + vorspann := workspace; + ack packet := workspace; + transmitted ack packet := transmitted ack space; + FOR strom FROM 1 UPTO maxstrom1 REP + vx.strom := 0; forget (vdr) + PER; + INT VAR i; + FOR i FROM 1 UPTO maxtasks REP alter call (i) := 0 PER; + quitmax := empfangsstroeme; + own:=station (myself); + quit zaehler := quit max; + own256 := 256*own; + reset box (net mode); + buffer first := ""; + flush buffers; + INT VAR err; + fehlermeldung ruecksetzen. + + fehlermeldung ruecksetzen: + control (12,0,0,err). + +END PROC neuer start; + +DATASPACE PROC verbindung (INT CONST nr): + INT VAR memory := strom; + strom := nr; + infoblock.steuer := verbindungen (nr); + infoblock.typ := typ (nr); + infoblock.maxseq := dspages (netzdr(nr)) * packets per page; + strom := memory; + workspace +END PROC verbindung; + +PROC neue sendung (TASK CONST q,z, INT CONST cod,z stat, DATASPACE CONST dr): + + naechste verbindung vorbereiten; + forget (vdr); vdr := dr; + sendung starten (q, z, z stat, cod) +END PROC neue sendung; + +PROC zeitueberwachung + (INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr): + snr INCR 1; + FOR strom FROM snr UPTO maxstrom REP zeitkontrolle PER; + snr := 0. + +zeitkontrolle: + IF vx.strom <> 0 AND zeit(strom) > 0 + THEN + zeit(strom) DECR 1; + IF sendung noch nicht zugestellt + THEN + IF zeit(strom) = 0 + THEN + empfangsreport ("Nicht zustellbar. "); + loesche verbindung (strom) + ELSE + snr := strom; + q := vx.quelle; + z := vx.ziel; + ant := vx.sendecode; + dr := vdr; + LEAVE zeitueberwachung + FI + ELIF zeit(strom) = 0 + THEN wiederholen + FI + FI. + +sendung noch nicht zugestellt: + typ (strom) = zustellung. + +wiederholen: + IF sendeeintrag + THEN + sendung wiederholen + ELSE + empfangseintrag freigeben + FI. + +sendeeintrag : vx.quellrechner = own . + +sendung wiederholen: + IF wiederholung noch sinnvoll + THEN + IF frisch + THEN + time out bei open + ELSE + datenteil wiederholen + FI + ELSE + sendung loeschen + FI. + +wiederholung noch sinnvoll: + task noch da AND bei call noch im call. + +task noch da: vx.quelle = collector OR exists (vx.quelle). + +bei call noch im call: + IF call aufruf + THEN + callee (vx.quelle) = vx.ziel + ELSE + TRUE + FI. + +frisch: vx.sequenz = -1. + +time out bei open: + IF vx.sendecode > -4 OR opentry (strom) > 0 + THEN + open wiederholen ; + opentry (strom) DECR 1 + ELSE + nak an quelle senden + FI. + +nak an quelle senden: + dr := nilspace; + BOUND TEXT VAR erm := dr; + erm := "Station "+text(vx.zielrechner)+" antwortet nicht"; + snr := strom; + q := vx.ziel; + z := vx.quelle; + ant := error nak; + sendung loeschen; + LEAVE zeitueberwachung . + +open wiederholen: + sendereport ("wdh open"); + IF opentry (strom) > 0 THEN zeit(strom) := 4 ELSE zeit(strom) := 40 FI; + openblock := vx; + openblock.head := stx open; + ab die post. + +datenteil wiederholen: + sendereport ("wdh data. sqnr "+text (vx.sequenz)); + senden . + +empfangseintrag freigeben: + IF antwort auf call + THEN + weiter warten + ELSE + empfangsreport ("Empfangseintrag freigegeben"); + loesche verbindung (strom) + FI. +antwort auf call: callee (vx.ziel) = vx.quelle. + +weiter warten: zeit (strom) := 400. + +END PROC zeitueberwachung; + +PROC sendereport (TEXT CONST txt): + report (text (strom)+":"+txt+". Absender: """+nam (vx.quelle)+ + """. Ziel "+text(vx.zielrechner) + " Taskindex: " + + text (index (vx.ziel))); +END PROC sendereport; + +PROC empfangsreport (TEXT CONST txt): + report (text (strom)+":"+txt+". Empfänger: """ + +nam (vx.ziel)+""". Quelle "+text (vx.quellrechner) + + " Taskindex: " + text (index (vx.quelle))); +END PROC empfangsreport ; + +PROC sendung loeschen: + strom loeschen (tasknr (vx.quelle)) +END PROC sendung loeschen; + +PROC strom loeschen (INT CONST tasknr): + IF callaufruf CAND alter call (tasknr ) = strom + THEN + alter call (tasknr ) := 0 + FI; + vx.strom := 0; + forget (vdr) +END PROC strom loeschen; + +PROC empfang loeschen: + quit zaehler INCR 1; + strom loeschen (tasknr (vx.ziel)) +END PROC empfang loeschen; + +PROC loesche verbindung (INT CONST nr): + strom := nr; + IF sendeeintrag + THEN + sendung loeschen + ELSE + gegenstelle zum loeschen auffordern; + empfang loeschen + FI. + +gegenstelle zum loeschen auffordern: + IF verbindung aktiv THEN quittieren (-loesche) FI. + +verbindung aktiv: vx.strom > 0. + +sendeeintrag: vx.quellrechner = own . + +END PROC loesche verbindung; + +PROC weiter senden: + IF NOT alles raus + THEN + sequenz zaehlung; + IF neue seite THEN seitennummer eintragen FI; + senden + FI. + +sequenz zaehlung: + vx.sequenz INCR 1. + +neue seite: + IF via node THEN (vx.sequenz AND packets per page via node minus 1) = 0 + ELSE (vx.sequenz AND pakete pro seite minus 1) = 0 + FI. + +seitennummer eintragen: + dr page (strom) := vx.seiten nummer; + vx.seitennummer := next ds page (vdr, dr page (strom)). + + +END PROC weiter senden; + +.packets per page: + + IF via node THEN packets per page via node + ELSE pakete pro seite + FI. + +packets per page minus 1: + IF via node THEN packets per page via node minus 1 + ELSE pakete pro seite minus 1 + FI. + +used length: + + IF via node THEN data len via node + ELSE nutzlaenge + FI. + +PROC senden: + INT VAR nl; + zeit(strom) := 6; + openblock := vx; + nl := used length; + transmit header (workspace); + vorspann senden; + daten senden; + transmit trailer. + +vorspann senden: + blockout (workspace, 1, dr verwaltungslaenge, vorspannlaenge). + +daten senden: + blockout (vdr,dr page (strom),distanz,nl). + +distanz: nl* (vx.sequenz AND packets per page minus 1). + +END PROC senden; + +PROC naechste verbindung vorbereiten: + FOR strom FROM 1 UPTO maxstrom REP + UNTIL vx.strom = 0 PER; + IF vx.strom <> 0 THEN errorstop ("Verbindungsengpass") FI. +END PROC naechste verbindung vorbereiten; + +PROC sendung starten (TASK CONST quelle, ziel, INT CONST code): + sendung starten (quelle,ziel, station(ziel), code) +END PROC sendung starten; + +PROC sendung starten (TASK CONST quelle, ziel, INT CONST ziel station,code): + IF ziel station = own + THEN + report ("Irrläufer: Sendung an eigene Station. Absender:"""+ + nam (quelle)+"""."); + vx.strom := 0; + forget (vdr) + ELSE + openblock.ziel := ziel; + openblock.quelle :=quelle; + openblock.sendecode := code; + openblock.zielrechner:= ziel station; + openblock.quellrechner :=own; + openblock.zwischenziel := route.zwischen (ziel station)+own256; + alten call loeschen (quelle); + IF call oder ping pong + THEN typ (strom) := call pingpong; call merken + ELSE typ (strom) := send wait FI; + sendung neu starten + FI. + +call oder pingpong: openblock.ziel = callee (openblock.quelle). + +call merken: alter call (tasknr (quelle)) := strom. + +END PROC sendung starten; + +PROC encode packet length (INT VAR val): + + IF val < 96 THEN + ELIF val < 160 THEN val DECR 32 + ELIF val < 288 THEN val DECR 128 + ELIF val < 544 THEN val DECR 352 + ELIF val < 1056 THEN val DECR 832 + ELIF val < 2080 THEN val DECR 1824 + FI; + rotate (val, 8) + +ENDPROC encode packet length; + +PROC sendung neu starten: + INT VAR value; + openblock.head:= stx open; + openblock.sequenz := -1; + openblock.seitennummer:= next ds page (vdr,-1); + openblock.strom := strom; + vx := open block; + schnelles nak bei routen liefern; + ab die post; + value := vorspannlaenge + used length; + encode packet length (value); + vx.head:=code stx+value. + +schnelles nak bei routen liefern: + IF openblock.sendecode = -routen liefern code + THEN + openblock.zwischenziel := openblock.zielrechner+own256; + zeit(strom) := 2; + opentry (strom) := 0 + ELSE + zeit (strom) :=8; + opentry (strom) := 2 + FI. + +END PROC sendung neu starten; . + +ab die post: + transmit header (workspace); + block out (work space,1, dr verwaltungslaenge,open laenge); + transmit trailer. + +PROC alten call loeschen (TASK CONST quelle): + IF alter call aktiv + THEN + INT VAR lstrom := strom; + vx:=openblock; + strom := alter call (tasknr (quelle)); + IF in ausfuehrungsphase + THEN + sendereport ("Call-Löschung vorgemerkt"); + loeschung vormerken + ELSE + report ("Call gelöscht."""+nam(quelle)+""". Strom "+text(strom)); + loesche verbindung (strom) + FI; + strom := lstrom; + openblock := vx + FI. + +in ausfuehrungsphase: + typ(strom) = call im wait OR typ (strom) = call in zustellung. + +loeschung vormerken: + typ(strom) := call im abbruch; + alter call (tasknr (quelle)) := 0. + + + alter call aktiv: + alter call (tasknr (quelle)) > 0. + +END PROC alten call loeschen; + +PROC packet eingang + ( INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr): + snr := 0; + fehlertest; + vorspann holen; + IF NOT ring logik THEN daten teil FI. + +ring logik: FALSE. + +fehlertest: +# + INT VAR c12; + control (12,0,0,c12); + IF c12 <> 0 + THEN + flush buffers; + report ("E/A-Fehler "+text (c12)); + control (12,0,0,c12); + LEAVE packet eingang + FI. + + #. + +vorspann holen: + sync; + IF NOT blockin (workspace, 1, dr verwaltungslaenge2, block laenge) + THEN LEAVE packeteingang + FI. + + +blocklaenge: IF code t > min data length + THEN + vorspannlaenge-2 + ELSE + code t -2 + FI. + +sync: + IF NOT packet start already inspected + THEN + TEXT VAR skipped, t:= ""; + skipped := next packet start; + IF skipped = "" THEN LEAVE packet eingang FI; + t := incharety (1); + code t := code (t); + ELSE + skipped := buffer first; + buffer first := ""; + t := incharety (1); + code t := code (t); + FI; + decode packet length; +IF skipped=stx AND laenge ok THEN LEAVE sync FI; + REP + skipped CAT t; + t := incharety (1); (* next character *) + IF t = "" THEN + report ("skipped",skipped); + LEAVE packet eingang + FI ; + codet := code (t); + UNTIL blockanfang OR length (skipped) > 200 PER; + decode packet length; + IF skipped <> stx THEN report ("skipped bei sync:", skipped) FI. + +decode packet length: + +IF code t < 96 THEN + ELIF code t < 128 THEN code t INCR 32 + ELIF code t < 160 THEN code t INCR 128 + ELIF code t < 192 THEN code t INCR 352 + ELIF code t < 224 THEN code t INCR 832 + ELIF code t < 256 THEN code t INCR 1824 +FI. + +packet start already inspected: buffer first <> "". + +blockanfang: + (skipped SUB length(skipped)) = stx AND laenge ok. + +laenge ok: + (codet = datenpacketlaenge OR codet = datenpacketlaenge via node + OR codet = ack laenge OR code t = openlaenge). + +zielnummer: vorspann.zielrechner. + +daten teil: + IF zielnummer = own + THEN + ziel erreicht (openblock,snr,q,z,ant,dr) + ELSE + weiter faedeln + FI. + +weiter faedeln: + INT VAR value; + IF zielrechner ok + THEN + IF neue verbindung + THEN + IF (openblock.sendecode = -routenlieferncode) OR NOT route ok + THEN LEAVE packet eingang + FI + FI; + value := code t; + encode packet length (value); + vorspann.head := code stx + value; + vorspann.zwischenziel := own256 + route.zwischen (vorspann.zielrechner); + nutzdaten einlesen; + dr := workspace; + snr := 1000; + ant := zielnummer + FI. + +nutzdaten einlesen: + IF code t > data len via node + THEN + IF NOT blockin (workspace, 1, drverwaltungslaenge+vorspannlaenge, data len via node) + THEN + LEAVE packeteingang + FI; + IF NOT next packet ok THEN LEAVE packeteingang FI + FI. + +END PROC packet eingang; + +PROC ziel erreicht (STEUER CONST prefix, + INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr): + last data := -1; + IF NOT quellrechner ok + THEN + report ("Quellrechner "+text(prefix.quellrechner)); + LEAVE ziel erreicht + FI; + IF neue verbindung + THEN + IF NOT route ok OR NOT quelltask ok + THEN report ("verbotene Route: " + text (prefix.quellrechner)); + LEAVE ziel erreicht + FI; + verbindung bereitstellen + ELIF quittung + THEN + strom := ack packet.strom; + IF falsche stromnummer THEN report ("Strom falsch in Quittung"); + LEAVE ziel erreicht FI; + IF vx.strom = 0 THEN LEAVE ziel erreicht FI; + IF ackpacket.code >= ok THEN weiter senden + ELIF NOT route ok THEN + sendereport ("verbotene Route bei Quittung"); + LEAVE ziel erreicht + ELIF ackpacket.code = -von vorne THEN + sendereport ("Neustart"); + openblock := vx; + sendung neu starten + ELIF ackpacket.code = -wiederhole THEN back 16 + ELIF ackpacket.code = -loesche THEN fremdloeschung + ELIF ackpacket.code = -beende AND alles raus THEN strom abschliessen + FI + ELIF verbindung festgestellt + THEN + zeit(strom) := 400; + opti := vx; + datenpacket + ELSE + strom := maxstrom1; + vx:=prefix; + report ("Daten ohne Eroeffnung von " +text(prefix.quellrechner) + +" Sequenznr "+text(prefix.sequenz)); + daten entfernen (used length); + IF alles raus THEN quittieren (-beende) ELSE quittieren(-von vorne) FI + FI. + +quelltask ok: + prefix.quelle = collector OR antwort auf routen liefern + OR station (prefix.quelle) = prefix.quellrechner. + +antwort auf routen liefern: prefix.quelle = myself. + +verbindung bereitstellen: + IF (prefix.sendecode < 0 OR station (prefix.ziel) = own) + AND quellrechner ok + THEN + freie verbindungsnummer; + vdr := nilspace; + vx := open block; + zeit(strom) := 30; + quittieren falls genug pufferplatz; + vx.sequenz := 0 ; + opti := vx; + dr page (strom) :=-2; + IF abschluss THEN rueckmeldung FI + FI. + +loeschung vorgemerkt: typ(strom) = call im abbruch. + +strom abschliessen: + IF call aufruf + THEN + wdh data vor ablauf der zustellversuche bei der gegenstation; + ausfuehrungsphase merken + ELSE + wdh data sperren + FI. + +wdh data sperren: + zeit (strom) := 12000. + +wdh data vor ablauf der zustellversuche bei der gegenstation: + zeit (strom) := 80. + +ausfuehrungsphase merken: typ(strom) := call in zustellung. + +back16: + datenraum etwas rueckspulen; + opentry (strom) := 2; + nicht sofort senden (* wegen vagabundierender Quittungen *). + +nicht sofort senden: zeit(strom) := 2. + +datenraum etwas rueckspulen: + INT VAR pps := packets per page ; + sendereport ("etwas rueckgespult"); + INT VAR vs :=-1; + dr page (strom) := -1; + INT VAR i; + FOR i FROM 1 UPTO vx.sequenz DIV pps - etwas REP + vs INCR pps; + dr page (strom) := next ds page (vdr, dr page (strom)) + PER; + vx.seiten nummer := next ds page (vdr, dr page (strom)) ; + vx.sequenz := vs. + +etwas: 3. + +fremdloeschung: + IF fremdrechner ok und sendung + THEN + IF typ (strom) = call in zustellung + THEN + typ (strom) := call im wait + ELSE + IF NOT alles raus + THEN + sendereport ("Sendung von Gegenstelle geloescht") + FI; + sendung loeschen + FI + FI. + +fremdrechner ok und sendung: + ackpacket.quellrechner = vx.zielrechner . + + +quittieren falls genug pufferplatz: + IF quit zaehler > 0 THEN + quit zaehler DECR 1; + open quittieren; + block vorab quittieren + ELSE + quittieren (-wiederhole) + FI. + +open quittieren: quittieren (ok). +block vorab quittieren: + IF prio (myself) < 3 THEN quittieren (ok) FI. + +quittung: code t <= ack laenge. + + +verbindung festgestellt: + FOR strom FROM maxstrom DOWNTO 1 REP + IF bekannter strom + THEN LEAVE verbindung festgestellt WITH TRUE FI + PER; + FALSE. + +bekannter strom: + vx.strom = prefix.strom AND vom selben rechner. + +vom selben rechner: + vx.quellrechner = prefix.quellrechner. + +daten: + IF neue seite da THEN check for valid pagenr; + dr page(strom) := prefix.seitennummer; + ELIF prefix.seitennummer < dr page(strom) + THEN empfangsreport ("Falsche Seitennummer, Soll: " + + text(drpage(strom)) + " ist: " + + text (prefix.seitennummer) + + " bei Sequenznr: " + + text(prefix.sequenz)); + flush buffers; + quittieren (- wiederhole); + LEAVE ziel erreicht + FI; + sequenz zaehlung; + IF neue seite kommt + THEN + vx.seiten nummer := prefix.seiten nummer; + dr page(strom) := prefix.seitennummer; + FI; + quittieren(ok); + IF NOT blockin (vdr, opti.seiten nummer, distanz, nl) + COR NOT next packet ok + THEN quittieren (-wiederhole); + LEAVE ziel erreicht + FI; + last data := strom. + +check for valid pagenr: + IF prefix.seitennummer < dr page(strom) AND prefix.seitennummer > -1 + THEN report ("Absteigende Seitennummern, alt: " + text(drpage(strom))+ + " neu: "+ text(prefix.seitennummer) + " Seq.nr: " + + text(vx.sequenz) ) ; + flush buffers; + quittieren (- von vorne); + LEAVE ziel erreicht; + FI. + +datenpacket: + INT VAR nl := used length; + INT VAR pps1 := packets per page minus 1; + IF sendung wartet auf zustellung THEN auffrischen ELSE daten holen FI. + +sendung wartet auf zustellung: typ (strom) = zustellung. + +auffrischen: zeit (strom) := 200; daten entfernen (nl). + +daten holen: + IF opti.sequenz >= prefix.sequenz AND opti.sequenz < prefix.sequenz+100 + AND prefix.sequenz >= 0 + THEN + IF opti.sequenz <> prefix.sequenz + THEN empfangsreport ("Sequenzreset von "+text(opti.sequenz)+" auf "+ + text (prefix.sequenz)); + vx.sequenz := prefix.sequenz; + IF pagenumber ok + THEN dr page (strom) := prefix.seitennummer + ELSE empfangsreport ("Blocknummer falsch, neu: "+ + text (prefix.seitennummer) + ", alt : " + + text (drpage(strom)) ); + FI; + vorabquittung regenerieren + FI; + daten ; + IF abschluss THEN rueckmeldung FI; + ELSE + empfangsreport ("Sequenzfehler: soll "+text(vx.sequenz)+" ist "+ + text(prefix.sequenz)); + quittieren (-wiederhole); + daten entfernen (nl) + FI. + +pagenumber ok: + dr page (strom) >= prefix.seitennummer . + +rueckmeldung: + snr := strom; + q := vx.quelle; + z := vx.ziel; + ant := vx.sendecode; + dr := vdr; + LEAVE ziel erreicht. + +vorabquittung regenerieren: + IF prio (myself) < 3 + THEN + quittieren (ok) + FI. + +distanz: (opti.sequenz AND pps1 ) * nl. + +sequenz zaehlung: + vx.sequenz INCR 1. + +neue seite da: + neue seite kommt. + +neue seite kommt: +(vx.sequenz AND pps1) = 0. + +freie verbindungsnummer: + INT VAR h strom :=maxstrom1, cstrom := 0; + FOR strom FROM 1 UPTO maxstrom REP + IF vx.strom = 0 THEN h strom := strom ; + typ(strom) := send wait + ELIF bekannter strom + THEN empfangsreport ("Reopen"); + quit zaehler INCR 1; + IF typ (strom) = zustellung THEN typ (strom) := send wait FI; + forget (vdr); + LEAVE freie verbindungsnummer + ELIF antwort auf call + THEN + IF loeschung vorgemerkt + THEN + vx := prefix; + loesche verbindung (strom); + LEAVE ziel erreicht + FI; + cstrom := strom; + typ (strom) := call pingpong; + forget (vdr); + FI + PER; + IF cstrom > 0 THEN strom := cstrom ELSE strom := h strom FI; + IF strom = maxstrom1 THEN + vx:=prefix; + empfangsreport ("Verbindungsengpass"); + quittieren (-wiederhole); + LEAVE ziel erreicht + FI. + +antwort auf call: + prefix.sendecode >= 0 AND + call aufruf AND vx.quelle = prefix.ziel AND vx.ziel = prefix.quelle. + +END PROC ziel erreicht; + +PROC daten entfernen (INT CONST wieviel): + BOOL VAR dummy ; + dummy:=blockin (workspace, 2, 0, wieviel) +END PROC daten entfernen; + +BOOL PROC route ok: + INT VAR zwischenquelle := vorspann.zwischenziel DIV 256, + endquelle := vorspann.quellrechner; + zwischenquelle abgleichen; + endquelle abgleichen; + TRUE. + +zwischenquelle abgleichen: + IF NOT zwischenroute gleich + THEN + IF NOT zwischenabgleich erlaubt THEN LEAVE route ok WITH FALSE FI; + route.port (zwischenquelle) := channel; + route.zwischen (zwischenquelle) := zwischenquelle; + abgleich (zwischenquelle, zwischenquelle) + FI. + +zwischenabgleich erlaubt: route.port (zwischenquelle) < 256. + +endquelle abgleichen: + IF NOT endroute gleich + THEN + IF NOT endabgleich erlaubt THEN LEAVE route ok WITH FALSE FI; + route.port (endquelle) := channel; + route.zwischen (endquelle) := zwischenquelle; + abgleich (endquelle, zwischenquelle) + FI. + +endabgleich erlaubt: route.port (endquelle) < 256. + +zwischenroute gleich: + (route.port (zwischenquelle) AND 255) = channel + AND + route.zwischen (zwischenquelle) = zwischenquelle. + +endroute gleich: + (route.port (endquelle) AND 255) = channel + AND + route.zwischen (endquelle) = zwischenquelle. + +END PROC route ok; + +BOOL PROC abschluss: + + last data := -1; + IF neue seite kommt AND vx.seiten nummer = -1 + THEN + quittieren (-beende); + an ziel weitergeben + ELSE + FALSE + FI. +neue seite kommt: +(vx.sequenz AND packets per page minus 1) = 0. + +an ziel weitergeben: + IF tasknummerfrage THEN taskfrage beantworten ;pufferplatz ; FALSE + ELIF tasknamenfrage THEN name senden ;pufferplatz ; FALSE + ELIF taskinfofrage THEN task info senden;pufferplatz ; FALSE + ELIF routenfrage THEN routen senden; pufferplatz; FALSE + ELSE senden ; TRUE + FI. + +pufferplatz : quitzaehler INCR 1 . + +senden: + IF callaufruf + THEN + ein versuch (* bei Antwort auf Call muß ein Zustellversuch reichen *) + ELSE + max 100 versuche; + typ (strom) := zustellung + FI. + +tasknummerfrage:opti.sendecode = -taskid code. + +tasknamenfrage: opti.sendecode = -name code. + +taskinfofrage: opti.sendecode = -task info code. + +routenfrage: opti.sendecode = -routen liefern code. + +max 100 versuche: zeit(strom) := 100. + +ein versuch: zeit (strom) := 1. + +taskfrage beantworten: + disable stop; + BOUND TEXT VAR tsk := vdr; + TEXT VAR save tsk := tsk; + forget (vdr); vdr := nilspace; + BOUND TASK VAR task id := vdr; + task id := task(save tsk); + IF is error THEN + clear error; enable stop; + forget (vdr); vdr := nilspace; + BOUND TEXT VAR errtxt := vdr; + errtxt := text(own)+"/"""+save tsk+""" gibt es nicht"; + sendung starten (collector, opti.quelle, 2) + ELSE + enable stop; + sendung starten (collector, opti.quelle, 0) + FI. + +name senden: + quittieren (-loesche); + forget (vdr); vdr := nilspace; + tsk := vdr; + tsk := nam (opti.ziel); + sendung starten (collector, opti.quelle, 0). + +routen senden: + forget (vdr); vdr := old ("port intern"); + sendung starten (opti.ziel, opti.quelle, 0). + +task info senden: + disable stop; + BOUND INT VAR ti code := vdr; + INT VAR ti cd := ti code; + forget (vdr); vdr := nilspace; + FILE VAR task inf := sequential file (output,vdr); + head line (task inf,"Station "+text(own)); + task info (ti cd, task inf); + IF is error + THEN + forget (vdr); vdr := nilspace; + errtxt := vdr; + errtxt := errormessage; + clear error; + sendung starten (collector, opti.quelle, 2) + ELSE + sendung starten (collector,opti.quelle,0) + FI; + enable stop +END PROC abschluss ; + +PROC quittieren(INT CONST code) : + INT VAR quell := vx.quellrechner ; + transmitted ackpacket := ACK:(stx quit, route.zwischen (quell)+own256, quell, own, + vx.strom, code); + transmit header (transmitted ack space); + blockout (transmitted ack space,1,dr verwaltungslaenge, ack laenge); + transmit trailer; +END PROC quittieren; + +BOOL PROC next packet ok: + buffer first := next packet start; + buffer first = "" COR normal packet start. + +normal packet start: + IF buffer first = stx + THEN + TRUE + ELSE + buffer first := ""; flush buffers; FALSE + FI. + +END PROC next packet ok; +END PACKET basic net; + + diff --git a/system/net/1.8.7/src/net files-M b/system/net/1.8.7/src/net files-M new file mode 100644 index 0000000..ae6f9f3 --- /dev/null +++ b/system/net/1.8.7/src/net files-M @@ -0,0 +1,5 @@ +net report +net hardware interface +basic net +net manager + diff --git a/system/net/1.8.7/src/net hardware interface b/system/net/1.8.7/src/net hardware interface new file mode 100644 index 0000000..4e3466a --- /dev/null +++ b/system/net/1.8.7/src/net hardware interface @@ -0,0 +1,389 @@ +PACKET net hardware + +(************************************************************************) +(**** Netzprotokoll Anpassung *) +(**** Komplette Version mit BUS Anpassung 10.06.87 *) +(**** mit I/0 Controls fuer integrierte Karten *) +(**** Verschiedene Nutztelegrammgrössen *) +(**** Version: GMD 2.0 A.Reichpietsch *) +(************************************************************************) + + DEFINES + blockin, + blockout, + set net mode, + net address, + mode text, + data length, + data length via node, + decode packet length, + next packet start, + flush buffers, + transmit header, + transmit trailer, + version, + reset box, + max mode, + net mode: + + + + + LET eak prefix laenge = 6, + packet length before stx = 14 (*eth header =14 *), + maximum mode nr = 12, + stx = ""2"", + niltext = "", + null = "0", + hex null = ""0"", + blank = " ", + eak prefix = ""0""0""0""0"", + typefield = "EU", + prefix adresse = "BOX", + second prefix adresse = ""0"BOX", + second address type bound = 90; + + INT CONST data length via node :: 64; + TEXT CONST version :: "GMD 2.0 (10.6.87)"; + + + TEXT VAR own address; + INT VAR paketlaenge, eumel paket laenge, mode, rahmenlaenge, actual data length; + +BOOL PROC blockin (DATASPACE VAR ds, INT CONST seite, abstand, laenge): + INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512; + REAL VAR time out := clock (1) + 10.0; + REP + blockin (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge); + UNTIL hilfslaenge = 0 OR clock (1) > time out PER ; + IF hilfslaenge <> 0 + THEN report ("blockin abbruch, fehlende Zeichen: "+text(hilfslaenge)); + FI; + hilfslaenge = 0 +END PROC blockin; + +PROC blockout (DATASPACE CONST ds, INT CONST seite, abstand, laenge): + INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512; + REP + blockout (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge); + UNTIL hilfslaenge = 0 PER +END PROC blockout; + +PROC set net mode (INT CONST new mode): + mode := new mode ; + own address := net address (station(myself)); + SELECT mode OF + CASE 1,3 : set data length (64); + CASE 2 : std framelength; set data length (64) + CASE 4,6 : set data length (128) + CASE 5 : std framelength; set data length (128) + CASE 7,9 : set data length (256) + CASE 8 : std framelength; set data length (256) + CASE 10,12 : set data length (512) + CASE 11 : std framelength; set data length (512); + + OTHERWISE + END SELECT. + + std framelength: + rahmenlaenge := eak prefix laenge + packet length before stx. + +ENDPROC set net mode; + +INT PROC max mode: + maximum mode nr +ENDPROC max mode; + +INT PROC net mode: + mode +ENDPROC net mode; + +TEXT PROC mode text: + mode text (mode) +ENDPROC mode text; + +TEXT PROC mode text (INT CONST act mode): + SELECT act mode OF + CASE 1: "Modus: (1) EUMEL-Netz 64 Byte" + CASE 2: "Modus: (2) ETHERNET via V.24 64 Byte" + CASE 3: "Modus: (3) ETHERNET integrated 64 Byte" + CASE 4: "Modus: (4) EUMEL-Netz 128 Byte" + CASE 5: "Modus: (5) ETHERNET via V.24 128 Byte" + CASE 6: "Modus: (6) ETHERNET integrated 128 Byte" + CASE 7: "MODUS: (7) EUMEL-Netz 256 Byte" + CASE 8: "MODUS: (8) ETHERNET via V.24 256 Byte" + CASE 9: "MODUS: (9) ETHERNET integrated 256 Byte" + CASE 10: "MODUS: (10) EUMEL-Netz 512 Byte" + CASE 11: "MODUS: (11) ETHERNET via V.24 512 Byte" + CASE 12: "MODUS: (12) ETHERNET integrated 512 Byte" + OTHERWISE errorstop ("Modus " + text(mode) + " gibt es nicht"); + error message + END SELECT + +ENDPROC mode text; + +PROC set data length (INT CONST new data length): + actual data length := new data length +ENDPROC set data length; + +INT PROC data length: + actual data length +ENDPROC data length; + +PROC reset box (INT CONST net mode): + SELECT net mode OF + CASE 1,4,7,10 : eumel net box reset + CASE 2,5,8,11 : eak reset + OTHERWISE controler reset + END SELECT. + + eumel net box reset: + out (90*""4""); + REP UNTIL incharety (1) = niltext PER. + + eak reset: + out ("E0"13"E0"13""). + + controler reset: + INT VAR dummy; + control (-35, 0,0,dummy); + control (22,0,0,dummy). + +ENDPROC reset box; + +PROC remove frame + (TEXT VAR erstes zeichen vom eumel telegramm, BOOL VAR kein telegramm da): + kein telegramm da := FALSE; + SELECT net mode OF + CASE 2,5,8,11 : remove ethernet frame + (erstes zeichen vom eumel telegramm, kein telegramm da) + OTHERWISE + END SELECT; +ENDPROC remove frame; + +PROC remove ethernet frame (TEXT VAR string, BOOL VAR schrott): + TEXT VAR speicher, t; + INT VAR lg; + + t := string; + speicher := niltext; + WHILE kein stx da REP + lies zeichen ein; + teste auf timeout; + UNTIL textoverflow PER; + melde eingelesene zeichen. + + lies zeichen ein: + speicher CAT t; + t := incharety (1). + + teste auf timeout: + IF t = niltext THEN schrott := (speicher <> niltext) + CAND not only fill characters; + string := niltext; + LEAVE remove ethernet frame + FI. + + not only fill characters: + pos (speicher, ""1"", ""254"",1) <> 0. + + kein stx da : + t <> stx. + + textoverflow: + length (speicher) > 1000. + + melde eingelesene zeichen: + IF kein stx da + THEN kein eumeltelegrammanfang + ELSE untersuche ethernet header + FI. + + kein eumeltelegrammanfang: + report ("skipped ,fehlendes <STX> ,letztes Zeichen:", t); + string := t; + schrott := TRUE. + + untersuche ethernet header: + string := t; + IF ethernet header inkorrekt + THEN melde fehler + FI. + + ethernet header inkorrekt: + lg := length (speicher); + packet zu kurz COR adresse falsch. + + packet zu kurz: + lg < packet length before stx. + + adresse falsch: + INT VAR adrpos := pos (speicher, own address); + zieladresse falsch COR adresse nicht an der richtigen pos . + + zieladresse falsch: + adrpos < 1. + + adresse nicht an der richtigen pos: + adrpos <> lg - packet length before stx + 1. + + melde fehler: + report ("Header inkorrekt eingelesen: ", speicher + t); + string := t; + schrott := TRUE. + +ENDPROC remove ethernet frame; + +TEXT PROC next packet start: + + TEXT VAR t := niltext; + BOOL VAR schrott := FALSE; + + t:= incharety (1); + IF t = niltext THEN LEAVE next packet start WITH niltext + ELSE remove frame (t, schrott) + FI; + IF schrott THEN no stx or niltext + ELSE t + FI. + + no stx or niltext: + IF t = stx THEN "2" + ELIF t = niltext THEN "0" + ELSE t + FI. + +ENDPROC next packet start; + +PROC flush buffers: + REP UNTIL incharety (5) = niltext PER; + report ("buffers flushed"); +ENDPROC flush buffers; + +PROC transmit header (DATASPACE CONST w): + BOUND INT VAR laengeninformation := w; + eumel paket laenge := laengeninformation ; + decode packet length (eumel paket laenge); + SELECT net mode OF + CASE 1,4,7,10 : + CASE 2,5,8,11 : eak und eth header senden (w) + OTHERWISE : telegrammanfang melden; + std ethernet header senden (w) + END SELECT; + +ENDPROC transmit header; + +PROC decode packet length (INT VAR decoded length): + + decoded length DECR 2; + rotate (decoded length, 8); + + IF decoded length < 96 THEN + ELIF decoded length < 128 THEN decoded length INCR 32 + ELIF decoded length < 160 THEN decoded length INCR 128 + ELIF decoded length < 192 THEN decoded length INCR 352 + ELIF decoded length < 224 THEN decoded length INCR 832 + ELIF decoded length < 256 THEN decoded length INCR 1824 + FI; + +ENDPROC decode packet length; + +PROC transmit trailer: + INT VAR dummy; + SELECT net mode OF + CASE 3,6,9,12 : control (21,0,0,dummy) + OTHERWISE + END SELECT. + +ENDPROC transmit trailer; + +PROC std ethernet header senden (DATASPACE CONST x): + TEXT VAR eth adresse, ethernet kopf := niltext; + INT VAR adresse; + BOUND STRUCT (INT head, zwischennummern) VAR header := x; + zieladresse holen; + zieladresse senden; + quelladresse senden; + typfeld senden; + ausgeben. + + zieladresse holen: + adresse := header.zwischennummern AND 255; + eth adresse := net address (adresse). + + zieladresse senden: + ethernetkopf CAT eth adresse. + + quelladresse senden: + ethernetkopf CAT own address. + + typfeld senden: + ethernetkopf CAT typefield. + + ausgeben: + out (ethernetkopf). + +ENDPROC std ethernet header senden; + +PROC telegrammanfang melden: + INT VAR dummy; + control (20,eumel paket laenge + packet length before stx,0, dummy). + +ENDPROC telegrammanfang melden; + +PROC eak und eth header senden (DATASPACE CONST x): + TEXT VAR res:= niltext; + + neue laenge berechnen; + eak kopf senden; + std ethernet header senden (x). + + neue laenge berechnen: + paket laenge := rahmenlaenge + eumel paket laenge. + + eak kopf senden: + res := code (paket laenge DIV 256); + res CAT (code (paket laenge AND 255)); + res CAT eak prefix; + out(res). + +ENDPROC eak und eth header senden; + +TEXT PROC net address (INT CONST eumel address): + TEXT VAR res ; + INT VAR low byte; + +SELECT mode OF + CASE 1,4,7,10 : eumel net address + OTHERWISE ethernet address +END SELECT. + +eumel net address: + text(eumel address). + +ethernet address: + IF second adress kind THEN second eth header + ELSE first eth header + FI; + res. + + second adress kind: + eumel address = 34 COR + eumel address > second address type bound. + + second eth header: + low byte := eumel address AND 255; + res := second prefix adresse + code (low byte); + res CAT hex null. + + first eth header: + res := prefix adresse + text (eumel address, 3); + changeall (res, blank, null). + +ENDPROC net address; + +ENDPACKET net hardware; + + + + diff --git a/system/net/1.8.7/src/net inserter b/system/net/1.8.7/src/net inserter new file mode 100644 index 0000000..c89d0f0 --- /dev/null +++ b/system/net/1.8.7/src/net inserter @@ -0,0 +1,145 @@ +(*************************************************************************) +(*** Insertiert alle notwendigen Pakete, die zum Betrieb des Netzes ***) +(*** notwendig sind. ***) +(*** Berücksichtigt nur EUMEL - Versionen ab 1.8.1, sowie ***) +(*** Multi-User-Version ***) +(*** ***) +(*** ***) +(*** 23.05.87 ar ***) +(*************************************************************************) + +LET netfile = "netz", + multi files = "net files/M"; + + +INT CONST version :: id (0); +THESAURUS VAR tesa; + +head; +IF no privileged task + THEN errorstop (name (myself) + " ist nicht privilegiert!") + ELIF station number wrong + THEN errorstop ("'define station' vergessen ") +FI; + +IF version < 181 THEN versionsnummer zu klein + ELSE install net +FI. + +no privileged task: + NOT (myself < supervisor). + +station number wrong: + station (myself) < 1. + +install net : + IF NOT exists (netfile) + THEN errorstop ("Datei " + netfile +" existiert nicht") + FI; + IF is multi THEN insert multi net + ELSE errorstop ("Diese Netzversion ist nur für Multi-user Versionen freigegeben") + FI; + forget ("net install", quiet); + net start. + +net start : + say line (" "); + do ("start"); + do ("global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) + net manager)"). + +is multi : + (pcb(9) AND 255) > 1. + +insert multi net : + hole dateien vom archiv; + insert say and forget (tesa). + +hole dateien vom archiv : + fetch if necessary (multi files); + tesa := ALL (multi files); + forget (multi files, quiet); + fetch if necessary (tesa - all); + say line (" "); + say line ("Archiv-Floppy kann entnommen werden."); + release (archive). + + +head : + IF online THEN page; + put center (" E U M E L - Netz wird installiert."); + line; + put center ("----------------------------------------"); + line (2) + FI. + +versionsnummer zu klein : + errorstop ("Netzsoftware erst ab Version 1.8.1 insertierbar !"). + +PROC fetch if necessary (TEXT CONST datei) : + IF NOT exists (datei) THEN say line ("Loading """ + datei + """..."); + fetch (datei, archive) + FI. +END PROC fetch if necessary; + +PROC fetch if necessary (THESAURUS CONST tes) : + do (PROC (TEXT CONST) fetch if necessary, tes) +END PROC fetch if necessary; + +PROC insert say and forget (TEXT CONST name of packet): + IF online THEN INT VAR cx, cy; + put ("Inserting """ + name of packet + """..."); + get cursor (cx, cy) + FI; + insert (name of packet); + IF online THEN cl eop (cx, cy); line FI; + forget (name of packet, quiet) +END PROC insert say and forget; + +PROC insert say and forget (THESAURUS CONST tes): + do (PROC (TEXT CONST) insert say and forget, tes) +END PROC insert say and forget; + +PROC put center (TEXT CONST t): + put center (t, xsize); +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t): + put center (zeile, t, xsize); +END PROC put center; + +PROC put center (TEXT CONST t, INT CONST gesamtbreite): + INT VAR cy; + get cursor (cy, cy); + put center (cy, t, gesamtbreite) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite): + cursor ((gesamtbreite - length (t)) DIV 2, zeile); + put (t). +END PROC put center; + +PROC cl eol: + out (""5"") +END PROC cl eol; + +PROC cl eop: + out (""4"") +END PROC cl eop; + +PROC cl eol (INT CONST cx, cy): + cursor (cx, cy); + cl eol +END PROC cl eol; + +PROC cl eop (INT CONST cx, cy): + cursor (cx, cy); + cl eop +END PROC cl eop; + +PROC say line (TEXT CONST t): + IF online THEN put line (t) FI +ENDPROC say line; + + + diff --git a/system/net/1.8.7/src/net manager b/system/net/1.8.7/src/net manager new file mode 100644 index 0000000..05f530e --- /dev/null +++ b/system/net/1.8.7/src/net manager @@ -0,0 +1,797 @@ +PACKET net manager DEFINES stop,net manager,frei, routen aufbauen, + (* 175 net manager 8 (!) *) + start, + definiere netz, + aktiviere netz, + list option, + erlaube, sperre, starte kanal, routen: + +TEXT VAR stand := "Netzsoftware vom 10.06.87 "; + (*Heinrichs *) +LET + maxstat = 127, + ack = 0, +(* nak = 1, *) + error nak = 2, +(* zeichen eingang = 4, *) + list code = 15, +(* fetch code = 11, *) + freigabecode = 29, + tabellencode = 500, + continue code = 100, + erase code = 14, + report code = 99, + abgleichcode = 98, + neue routen code = 97, + dr verwaltungslaenge = 8, + + (* Codes der Verbindungsebene *) + + task id code = 6, + name code = 7, + task info code = 8, + routen liefern code = 9, + + (* Weitergabecodes für Netzknoten *) + + route code = 1001, + out code = 1003, + + (* Typen von Kommunikationsströmen *) + + zustellung = 1, + call im wait = 3, + call im abbruch = 4, + call in zustellung = 5; + +LET STEUER = + STRUCT ( + INT head, + zwischenziel, + zielrechner, + quellrechner, + strom, + INT sequenz, + seiten nummer, + TASK quelle,ziel, + INT sende code); + +LET INFO = STRUCT (STEUER steuer, INT typ,maxseq); + +LET PARA = STRUCT (TASK quelle, ziel, INT sendecode, zielstation); + + +TASK VAR sohn; +INT VAR strom,c,kanalmode, rzaehler := 20; +BOUND STRUCT (ROW maxstat INT port, + ROW maxstat INT zwischen) VAR route; + + +TASK PROC netport (INT CONST ziel): + INT VAR kan := route.port (ziel) AND 255; + IF kan < 1 OR kan > 15 + THEN + niltask + ELSE + IF NOT exists (nettask (kan)) + THEN + access catalogue; + nettask (kan) := task (kan); + IF NOT (nettask (kan) < father) THEN nettask (kan) := niltask FI; + FI; + nettask (kan) + FI +END PROC netport; + +PROC frei (INT CONST stat,lvl): + DATASPACE VAR ds := nilspace; + BOUND STRUCT (INT x,y) VAR msg := ds; + msg.x := stat; msg.y := lvl; + INT VAR return; + call (netport (stat), freigabecode, ds, return) ; + forget (ds) +END PROC frei; + +PROC net manager (DATASPACE VAR ds, INT CONST order, phase, TASK CONST + ordertask): + + IF order = report code AND ordertask < myself + THEN + IF storage (old("report")) > 20 THEN forget ("report", quiet) FI; + FILE VAR rp := sequential file (output, "report"); + BOUND TEXT VAR rpt := ds; + putline (rp, rpt); + send (ordertask, ack, ds) + ELIF order = abgleichcode AND ordertask < myself + THEN + BOUND STRUCT (INT ende, zwischen) VAR x := ds; + route.port (x.ende) := channel (ordertask); + route.zwischen (x.ende) := x.zwischen; + send (ordertask, ack, ds) + ELIF order = neue routen code AND ordertask < myself + THEN + forget ("port intern"); + copy (ds,"port intern"); + route := old ("port intern"); + send (ordertask, ack, ds) + ELIF station (ordertask) = station (myself) + THEN + IF ordertask < myself + OR order = list code + OR order > continue code + THEN + IF order = list code + THEN + enable stop; + forget (ds); ds := old ("report"); + FILE VAR ff := sequential file (output,ds); + putline (ff,"bekannte Stationen:"); + stationen; line (ff); putline (ff,"--------"); + putline (ff,"Eingestellte Netzmodi:"); + kanaele ; + paketgroessen; + line (ff); putline (ff,"********"); + putline (ff,stand); + putline (ff,"Rechner "+text(station(myself))+" um "+time of day); + send (ordertask, ack, ds) + ELSE + free manager (ds,order,phase,order task) + FI + ELSE + errorstop ("nur 'list' ist erlaubt") + FI + FI . + +stationen: +INT VAR stat; +INT VAR mystation := station (myself); +FOR stat FROM 1 UPTO maxstat REP + IF route.port (stat) > 0 AND stat <> mystation + THEN + put (ff,text(stat)+"("+text (route.port (stat) AND 255)+","+ + text(route.zwischen(stat))+")") + FI +PER. + +paketgroessen: + + line(ff); + put (ff, "Nutzlaenge bei indirekter Verbindung "+ + text (data length via node) + " Byte "); line (ff). + +kanaele: + INT VAR portnummer; + TASK VAR tsk; + FOR portnummer FROM 1 UPTO 15 REP + tsk := task (portnummer); + IF tsk < myself THEN beschreibe kanal FI; + PER. + +beschreibe kanal: + putline (ff, name (tsk) + " haengt an Kanal " + text (channel (tsk)) + + ", " + mode text (netz mode (portnummer))). + +END PROC net manager; + +TASK VAR cd,stask; +ROW maxstat INT VAR erlaubt; + +PROC communicate: + enable stop; + INT VAR scode, merken :=0; + DATASPACE VAR dr := nilspace; + neuer start (quit max, kanalmode); +REP + forget (dr); + telegrammfreigabe; + wait (dr, scode, stask); + cd := collected destination; + IF weiterleitung steht noch aus + THEN + send (netport (merken), out code, mds, reply); + IF reply <> -2 THEN forget (mds); merken := 0 FI + FI; + IF zeichen da OR zeit abgelaufen + THEN + packet + ELIF cd = myself + THEN + netz info und steuerung + ELSE + sendung untersuchen (stask, cd, scode, dr) + FI +PER. + +telegrammfreigabe: + INT VAR dummy; + control (22,0,0,dummy). + +zeichen da: scode < 0 . + +zeit abgelaufen: scode = ack AND cd = myself. + +packet: + INT VAR snr, ant,err; + TASK VAR quelle, ziel; + snr := 0; + IF NOT zeichen da THEN routen erneuern FI; + REP + IF NOT zeichen da + THEN + forget (dr); + zeitueberwachung (snr, quelle, ziel, ant, dr); + ELIF NOT weiterleitung steht noch aus + THEN + packet eingang (snr, quelle, ziel, ant, dr); + FI; + IF snr = 1000 + THEN + packet weiterleiten + ELIF snr > 0 + THEN + IF ant > 6 AND erlaubt(station (quelle)) < 0 + THEN unerlaubt + ELSE + send (quelle,ziel,ant,dr,err); + fehlerbehandlung ; + FI + FI + UNTIL snr = 0 OR zeichen da PER. + +routen erneuern: + rzaehler DECR 1; + IF rzaehler = 0 + THEN + rzaehler := 20; + neue routen holen + FI. + +weiterleitung steht noch aus: merken <> 0. + +packet weiterleiten: + INT VAR reply; + IF NOT ((route.port (ant) AND 255) = channel OR route.port (ant) < 0) + THEN + send (netport (ant), out code, dr, reply); + IF reply = -2 + THEN + merken := ant; + DATASPACE VAR mds := dr + FI + ELSE + report ("Weiterleitung nicht möglich für "+text(ant)) + FI. + +fehlerbehandlung: + IF ok oder ziel nicht da THEN loesche verbindung (snr) FI. + +ok oder ziel nicht da: err=0 OR err=-1. + +netz info und steuerung: + IF scode = list code THEN list status + ELIF scode = erase code THEN strom beenden + ELIF scode = freigabe code AND stask = father THEN freigabelevel + ELIF scode >= route code THEN weitergaben + ELIF scode > tabellencode THEN routen ausliefern + ELSE forget (dr); ablehnen ("nicht möglich") + FI. + +weitergaben: + IF stask < father + THEN + IF scode = out code + THEN + BOUND INT VAR stx lng := dr; + INT VAR decoded lng := stx lng; + decode packet length (decoded lng); + transmit header (dr); + blockout (dr,1,drverwaltungslaenge,decoded lng); + transmit trailer + ELIF scode = route code + THEN + BOUND PARA VAR parah := dr; + PARA VAR para := parah; + pingpong (stask, ack, dr, reply); + neue sendung (para.quelle, para.ziel, para.sendecode, + para.zielstation, dr); + forget (dr); dr := nilspace; + send (stask, ack, dr) + FI + ELSE + forget (dr); + ablehnen ("nicht Sohn von "+name(father)) + FI. + +routen ausliefern: + neue sendung (stask, myself, -routen liefern code, scode-tabellencode,dr). + +freigabelevel: + BOUND STRUCT (INT stat,lvl) VAR lv := dr; + IF lv.stat > 0 AND lv.stat <= maxstat THEN erlaubt (lv.stat) := lv.lvl FI; + send (stask,ack,dr). + +unerlaubt: + report ("Fremdzugriff von "+text(station (quelle))+" auf "+nam(ziel) + +" code "+text(ant)); + loesche verbindung (snr); + forget (dr); dr := nilspace; + BOUND TEXT VAR errtxt := dr; + errtxt:="Kein Zugriff auf Station "+text (station (myself)); + neue sendung (ziel, quelle, error nak, station (quelle), dr). + +strom beenden: + BOUND TEXT VAR stromtext := dr; + INT VAR erase strom := int (stromtext); + forget (dr); + strom := erase strom; + IF falsche stromnummer THEN ablehnen ("Strom gibt es nicht") + ELSE + BOUND INFO VAR v := verbindung (strom); + IF + stask < supervisor OR stask = vx.quelle OR stask = vx.ziel + THEN + loeschen + ELSE ablehnen ("Nur Empfänger/Absender darf löschen") + FI + FI. + +loeschen: + IF sendeeintrag THEN + IF callee (vx.quelle) = vx.ziel THEN absender warnen FI; + loesche verbindung (strom) + ELSE + IF callee (vx.ziel) = vx.quelle THEN warnen FI; + loesche verbindung (strom) + FI; + dr := nilspace; + send (stask,ack,dr). + +absender warnen: + dr := nilspace; + send(vx.ziel,vx.quelle,1,dr,err) . + +warnen: + dr := nilspace; +errtxt := dr; errtxt:= "Station antwortet nicht"; +send (vx.quelle,vx.ziel,error nak, dr, err). + +falsche stromnummer: strom < 1 OR strom > max verbindungsnummer. +sendeeintrag: vx.quellrechner = station (myself). +vx: v.steuer. +END PROC communicate; + +PROC list option: + begin ("net list",PROC list net, sohn) +END PROC list option; + +PROC list net: + disable stop; + DATASPACE VAR ds ; + INT VAR scode; + REP + wait (ds, scode, stask); + forget (ds); ds := nilspace; + FILE VAR f := sequential file (output, ds); + list (f, father); + list netports; + IF is error THEN clear error; + forget(ds); + ds := nilspace; + f := sequential file (output, ds); + output (f); putline (f,errormessage); + clear error + FI; + send (stask, ack, ds) + PER. + +list netports: + INT VAR k; + FOR k FROM 1 UPTO 15 REP + TASK VAR tsk := task (k); + IF tsk < father + THEN + putline (f, name (tsk)); + list (f,tsk) + FI + PER. + +END PROC list net; + +PROC neue routen holen: + forget ("port intern", quiet); + fetch ("port intern"); + route := old ("port intern"); + neue routen +END PROC neue routen holen; + +PROC sendung untersuchen (TASK CONST q, z, INT CONST cod, DATASPACE VAR dr): + IF z = collector + THEN + verbindungsebene + ELIF station (z) <> 0 + THEN + sendung (q,z,cod,station (z),dr) + ELSE + ablehnen ("Station 0") + FI. + +verbindungsebene: + IF cod = 256 THEN name von fremdstation + ELIF cod > 256 + THEN + taskinfo fremd + ELIF callee (q) = z (* gegen errornak an collector *) + THEN + task id von fremd + FI. + +taskinfo fremd: sendung (q, collector, -task info code,cod-256,dr). + +task id von fremd: sendung (q, collector, -task id code, zielstation, dr) . + +name von fremdstation: + BOUND TASK VAR tsk := dr; + TASK VAR tsk1 := tsk; + forget (dr); + dr := nilspace; + sendung (q, tsk1, -name code, station (tsk1), dr). + +zielstation: cod. +END PROC sendung untersuchen; + +PROC sendung (TASK CONST q, z, INT CONST code, z stat, DATASPACE VAR dr): + IF z stat < 1 OR z stat > maxstat + THEN + ablehnen ("ungültige Stationsnummer"); + LEAVE sendung + FI; + INT VAR reply; + INT VAR rp := route.port (z stat) AND 255; + IF rp = 255 THEN neue routen holen ;rp := route.port (z stat) AND 255 FI; + IF rp = channel + THEN + sendung selbst betreiben + ELIF rp > 0 AND rp < 16 + THEN + sendung weitergeben + ELSE + ablehnen ("Station "+text(z stat)+" gibt es nicht") + FI. + +sendung selbst betreiben: + neue sendung (q, z, code, z stat, dr). + +sendung weitergeben: + DATASPACE VAR ds := nilspace; + BOUND PARA VAR p := ds; + p.quelle := q; + p.ziel := z; + p.zielstation := z stat; + p.sendecode := code; + call (netport (z stat), route code, ds, reply); + forget (ds); + pingpong (netport (z stat), 0, dr, reply); + forget (dr); + IF reply < 0 THEN ablehnen ("netport "+text(route.port(zstat)AND255) + + " fehlt") FI +END PROC sendung; + +PROC ablehnen (TEXT CONST t): + DATASPACE VAR vdr := nilspace; + BOUND TEXT VAR errtxt := vdr; + INT VAR err; + errtxt := t; + send (cd,stask, error nak, vdr,err); + forget (vdr). +END PROC ablehnen; + +PROC stop: + access catalogue; + IF exists task ("net timer") + THEN + TASK VAR nets := father (/"net timer"); + ELSE + nets := myself + FI; + nets := son (nets); + WHILE NOT (nets = niltask) REP + IF text (name (nets),3) = "net" OR name (nets) = "router" + THEN + end (nets) + FI; + nets := brother (nets) + PER +END PROC stop; + +PROC list status: + + DATASPACE VAR ds := nilspace; + FILE VAR f:=sequential file (output, ds); + line(f); + FOR strom FROM 1 UPTO max verbindungsnummer REP + IF strom > 0 THEN + BOUND INFO VAR v := verbindung (strom); + IF vx.strom <> 0 THEN info FI + FI; + PER; + send (stask, ack, ds). + +info: + put (f,"Strom "+text(strom)); + put (f,"(sqnr"+text(vx.sequenz)+"/"+text (v.maxseq)+")"); + IF sendeeintrag THEN sendeinfo ELSE empfangsinfo FI; + line (f). + +sendeeintrag: vx.quellrechner = station(myself) . + +sendeinfo: + IF v.typ = call im wait THEN put (f,"erwartet Antwort von") + ELIF v.typ = call in zustellung THEN put (f,"Ziel busy. Zielstation:") + ELIF v.typ = call im abbruch THEN put (f,"wird gelöscht bei Antwort von") + ELSE put (f,"sendet an") + FI; + put (f,vx.zielrechner); + put (f,". Absender ist """+nam (vx.quelle)+"""."). + +empfangsinfo: + IF v.typ = zustellung THEN + put (f,"Sendung noch nicht zustellbar") + ELSE + put (f,"empfängt von"); + put (f,vx.quellrechner); + FI; + put (f,". Empfaenger ist """+nam (vx.ziel)+"""."). + +vx: v.steuer. +END PROC list status; + +INT VAR quitmax := 3; + +ROW 15 TASK VAR net task; +ROW 15 INT VAR netz mode; + +PROC erlaube (INT CONST von, bis): + IF ein kanal gestartet + THEN + putline ("Warnung: 'erlaube' muß vor 'starte kanal'") + FI; + test (von); test (bis); + INT VAR i; + FOR i FROM von UPTO bis REP erlaubt (i) := 0 PER +END PROC erlaube; + +PROC sperre (INT CONST von, bis): + IF ein kanal gestartet + THEN + putline ("Warnung: 'sperre' muß vor 'starte kanal'") + FI; + test (von); test (bis); + INT VAR i; + FOR i FROM von UPTO bis REP erlaubt (i) :=-1 PER +END PROC sperre ; + +BOOL VAR alte routen, ein kanal gestartet; + +PROC definiere netz: + stop; + INT VAR i; + FOR i FROM 1 UPTO 15 REP net task (i) := niltask PER; + ein kanal gestartet := FALSE; + FILE VAR s := sequential file (output,"report"); + putline (s," N e u e r S t a r t " + date + " " + time of day ); + alte routen := exists ("port intern"); + IF alte routen + THEN + route := old ("port intern") + ELSE + route := new ("port intern"); + initialize routes + FI. + + initialize routes: + FOR i FROM 1 UPTO maxstat REP + route.zwischen(i) := i + PER. + +END PROC definiere netz; + +PROC starte kanal (INT CONST k,modus,stroeme): + ein kanal gestartet := TRUE; + IF exists (canal (k)) THEN end (canal (k)) FI; + IF stroeme <= 0 THEN errorstop ("3.Parameter negativ") FI; + quitmax := stroeme; + c := k; + IF c < 1 OR c > 15 THEN errorstop ("unzulässiger Kanal:"+text(c)) FI; + kanalmode := modus; + IF kanalmode < 1 OR kanalmode > max mode + THEN errorstop ("unzulässiger Netzbetriebsmodus:"+text(kanalmode)) + ELSE netz mode (c) := kanalmode + FI; + IF NOT exists task ("net port") + THEN + begin ("net port",PROC net io, net task (c)); + define collector (/"net port") + ELSE + begin ("net port "+text (c),PROC net io, net task (c)) + FI. +END PROC starte kanal; + +PROC routen (INT CONST von, bis, kanal, zw): + INT VAR i; + IF kanal < 0 OR kanal > 15 THEN errorstop ("Kanal unzulässig") FI; + test (von); test (bis); + FOR i FROM von UPTO bis REP + route.port (i) := kanal+256; + IF zw=0 + THEN + route.zwischen (i) := i + ELSE + test (zw); + route.zwischen (i) := zw + FI + PER. +END PROC routen; + +PROC routen (INT CONST von, bis, kanal): + routen (von, bis, kanal, 0) +END PROC routen; + +PROC test (INT CONST station): + IF station < 1 OR station > maxstat + THEN + errorstop (text (station) + " als Stationsnummer unzulässig") + FI +END PROC test; + +PROC aktiviere netz: +vorgegebene routen pruefen; +IF existstask ("net timer") THEN end (/"net timer") FI; +begin ("net timer",PROC timer,sohn); +IF NOT alte routen +THEN + routen aufbauen +ELSE + IF online THEN break FI +FI. + +vorgegebene routen pruefen: + INT VAR i; + FOR i FROM 1 UPTO maxstat REP + INT VAR s := route.port (i) AND 255; + IF s > 0 AND s <= 15 CAND nettask (s) = niltask + THEN + errorstop ("Kanal "+text(s)+" nicht gestartet, steht aber in Routen") + FI + PER. +END PROC aktiviere netz; + + +PROC routen aufbauen: + alte routen := TRUE; + c := channel; + break (quiet); + begin ("router", PROC rout0, sohn). +END PROC routen aufbauen; + +PROC rout0: + disable stop; + rout; + IF is error + THEN + put error + FI; + end (myself) +END PROC rout0; + +PROC rout: + IF c>0 THEN continue (c) FI; + clear error; enable stop; + fetch ("port intern"); + route := old ("port intern"); + routen aufbauen; + ds := old ("port intern"); + call (father, neue routen code, ds, reply). + +routen aufbauen: + access catalogue; + TASK VAR port := brother (myself); + WHILE NOT (port = niltask) REP + IF text (name (port),8) = "net port" THEN nachbarn FI; + port := brother (port) + PER; + IF online THEN putline ("Fertig. Weiter mit SV !") FI. + +aenderbar: route.port (st) < 256. + +nachbarn: + INT VAR st,reply; + FOR st FROM 1 UPTO maxstat REP + IF erlaubt (st) >= 0 AND st <> station (myself) AND aenderbar + THEN + IF online THEN put (name (port)); put (st) FI; + DATASPACE VAR ds := nilspace; + call (port, tabellencode+st, ds, reply); + IF reply = ack + THEN + BOUND STRUCT (ROW maxstat INT port, + ROW maxstat INT zwischen) VAR fremd := ds; + route.port (st) := channel(port); + route.zwischen (st) := st; + indirekte ziele + ELIF reply < 0 + THEN + errorstop ("netz läuft nicht (Kanalnummer falsch)") + ELSE + BOUND TEXT VAR xt := ds; + IF online THEN put (xt) FI; + FI; + IF online THEN line FI; + forget (ds) + FI + PER. + +indirekte ziele: + INT VAR kanal := fremd.port (station (myself)) AND 255; + INT VAR ind; + FOR ind FROM 1 UPTO maxstat REP + IF ind bei st bekannt AND NOT ((fremd.port (ind) AND 255) = kanal) + AND route.port (ind) < 256 + THEN + route.port (ind) := channel (port); + route.zwischen (ind) := st + FI + PER. + +ind bei st bekannt: NOT (fremd.port (ind) = -1). + +END PROC rout; + + +PROC timer: + disable stop; + access catalogue; + INT VAR old session := 1; + REP + IF session <> old session + THEN + define collector (/"net port"); + old session := session + FI; + clear error; + pause (30); + sende tick an alle ports + PER. + +sende tick an alle ports : + TASK VAR fb := son (father); + REP + IF NOT exists (fb) THEN access catalogue;LEAVE sende tick an alle portsFI; + IF channel (fb) > 0 + THEN + DATASPACE VAR ds := nilspace; + send (fb, ack, ds); + pause (10) + FI; + fb := brother (fb) + UNTIL fb = niltask PER. + +END PROC timer; + +PROC net io: + disable stop; + set net mode (kanalmode); + fetch ("port intern"); + route := old ("port intern"); + commanddialogue (FALSE); + continue (c); + communicate; + TEXT VAR emsg := "++++++ "+error message +" Zeile "+text(errorline); + clear error; + report (emsg); + end (myself) +END PROC net io; + +PROC start: run ("netz") END PROC start; + +END PACKET net manager; + diff --git a/system/net/1.8.7/src/net report b/system/net/1.8.7/src/net report new file mode 100644 index 0000000..ddc19d2 --- /dev/null +++ b/system/net/1.8.7/src/net report @@ -0,0 +1,41 @@ +PACKET net report DEFINES report, abgleich: +(* Version 3 (!) *) + +LET reportcode = 99, abgleichcode = 98; + +PROC abgleich (INT CONST ende, zwischen): + DATASPACE VAR ds := nilspace; + BOUND STRUCT (INT ende, zwischen) VAR x := ds; + x.ende := ende; + x.zwischen := zwischen; + call (father, abgleichcode, ds, rep); + INT VAR rep; + forget (ds) +END PROC abgleich; + +PROC report (TEXT CONST x): + report(x,"") +END PROC report; + +PROC report (TEXT CONST txt, info): + DATASPACE VAR net report := nilspace; + BOUND TEXT VAR rinfo := net report; + rinfo := date; + rinfo CAT " "+time of day +" "; + rinfo CAT name(myself)+":"; + rinfo CAT txt; + INT VAR i; + FOR i FROM 1 UPTO length (info) REP + INT VAR z := code (infoSUBi) ; + IF z < 32 OR z > 126 + THEN rinfo CAT "%"+text(z)+" " + ELSE rinfo CAT (infoSUBi)+" " + FI + PER; + call (father, report code , net report, reply); + INT VAR reply; + forget (net report); +END PROC report; + +END PACKET net report; + diff --git a/system/net/1.8.7/src/netz b/system/net/1.8.7/src/netz new file mode 100644 index 0000000..c237ba2 --- /dev/null +++ b/system/net/1.8.7/src/netz @@ -0,0 +1,20 @@ +IF exists ("port intern") THEN forget ("port intern") FI; +definiere netz; +list option; +erlaube(1,127); +sperre (1,9); +sperre (15,32); +sperre (37,37); +sperre (42,42); +sperre (46,47); +sperre (49,127); +routen (1, 32,8); +routen (33,43, 9); +routen (34,34,8); +routen (35,48,9); +starte kanal (9,11,10); +starte kanal (8,1,10); +aktiviere netz; + + + diff --git a/system/net/1.8.7/src/port server b/system/net/1.8.7/src/port server new file mode 100644 index 0000000..46c647f --- /dev/null +++ b/system/net/1.8.7/src/port server @@ -0,0 +1,164 @@ +PACKET port server: (* Autor : R. Ruland *) + (* Stand : 21.03.86 *) + +INT VAR port station; +TEXT VAR port := "PRINTER"; + +put ("gib Name des Zielspools : "); editget (port); line; +put ("gib Stationsnummer des Zielspools : "); get (port station); + +server channel (15); +spool duty ("Verwalter fuer Task """ + port + + """ auf Station " + text (port station)); + +LET max counter = 10 , + time slice = 300 , + + ack = 0 , + fetch code = 11 , + param fetch code = 21 , + file save code = 22 , + file type = 1003 , + + begin char = ""0"", + end char = ""1""; + + +INT VAR reply, old heap size; +TEXT VAR file name, write pass, read pass, sendername, buffer; +FILE VAR file; + +DATASPACE VAR ds, file ds, send ds; + +BOUND STRUCT (TEXT file name, write pass, read pass, sendername, INT station) VAR msg; +BOUND TEXT VAR error msg ; + +spool manager (PROC save file); + +PROC save file : + + disable stop ; + command dialogue (FALSE); + ds := nilspace; file ds := nilspace; send ds := nil space; + old heap size := heap size; + + REP + execute save file; + + IF is error THEN save error (error message) FI; + + IF heap size > old heap size + 4 + THEN collect heap garbage ; + old heap size := heap size + FI; + + PER + +ENDPROC save file; + + +PROC execute save file : + +enable stop; +forget (file ds) ; file ds := nilspace; +call (father, fetch code, file ds, reply); +IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE save file ds +FI; + +. save file ds : + IF type (file ds) = file type + THEN get file params; + insert file params; + call station (port station, port, file save code, file ds); + ELSE errorstop ("Datenraum hat falschen Typ") + FI; + +. get file params : + forget (ds); ds := nilspace; + call (father, param fetch code, ds, reply); + IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE msg := ds; + file name := msg. file name; + write pass := msg. write pass; + read pass := msg. read pass; + sendername := msg. sender name; + FI; + +. insert file params : + buffer := ""; + in headline (filename); + in headline (write pass); + in headline (read pass); + in headline (sendername); + file := sequential file (input, file ds) ; + headline (file, buffer); + +END PROC execute save file; + + +PROC call station (INT CONST order task station, TEXT CONST order task name, + INT CONST order code, DATASPACE VAR order ds) : + + INT VAR counter := 0; + TASK VAR order task; + disable stop; + REP order task := order task station // order task name; + IF is error CAND pos (error message, "antwortet nicht") > 0 + THEN clear error; + counter := min (max counter, counter + 1); + pause (counter * time slice); + ELSE enable stop; + forget (send ds); send ds := order ds; + call (order task, order code, send ds, reply); + disable stop; + IF reply = ack + THEN forget (order ds); order ds := send ds; + forget (send ds); + LEAVE call station + ELSE error msg := send ds; + errorstop (error msg); + FI; + FI; + PER; + +END PROC call station; + + +TASK OP // (INT CONST station, TEXT CONST name) : + + enable stop; + station / name + +END OP //; + + +PROC in headline (TEXT CONST information) : + IF pos (information, begin char) <> 0 + OR pos (information, end char) <> 0 + THEN errorstop ("Name darf nicht Code 0 oder Code 1 enthalten") FI; + buffer CAT begin char; + buffer CAT information; + buffer CAT end char; +END PROC in headline; + + +PROC save error (TEXT CONST message) : + clear error; + file name CAT "."; + file name CAT sender name; + file name CAT ".ERROR"; + file := sequential file (output, file name); + putline (file, " "); + putline (file, "Uebertragung nicht korrekt beendet "); + putline (file, " "); + put (file, "ERROR :"); put (file, message); + save (file name, public); + clear error; + forget(file name, quiet); +END PROC save error; + +ENDPACKET port server; + diff --git a/system/net/1.8.7/src/printer server b/system/net/1.8.7/src/printer server new file mode 100644 index 0000000..b1a30bc --- /dev/null +++ b/system/net/1.8.7/src/printer server @@ -0,0 +1,99 @@ +PACKET multi user printer : (* Autor : Rudolf Ruland *) + (* Stand : 24.03.86 *) + +INT VAR c; +put ("gib Druckerkanal : "); get (c); + + server channel (c); + station only (FALSE) ; + spool duty ("Ausgabe mit dem Drucker"); + spool control task (myself); + +LET ack = 0 , + + fetch code = 11 , + param fetch code = 21 , + file type = 1003 ; + +INT VAR reply, old heap size, sender station; +TEXT VAR file name, userid, password, sendername; +FILE VAR file ; + +DATASPACE VAR ds, file ds; + +BOUND STRUCT (TEXT file name, userid, password, sendername, INT station) VAR msg; +BOUND TEXT VAR error msg ; + +spool manager (PROC printer); + +PROC printer : + + disable stop ; + command dialogue (FALSE); + ds := nilspace; file ds := nilspace; + continue (server channel) ; + check error ("Kanal belegt"); + + old heap size := heap size ; + REP + execute print ; + + IF is error + THEN put error; + clear error; + FI ; + + IF heap size > old heap size + 4 + THEN collect heap garbage ; + old heap size := heap size + FI + PER + +ENDPROC printer ; + + +PROC execute print : + + enable stop ; + forget (file ds) ; file ds := nilspace ; + call (father, fetch code, file ds, reply) ; + IF reply = ack CAND type (file ds) = file type + THEN get file params; + print file + FI ; + +. get file params : + forget (ds); ds := nilspace; + call (father, param fetch code, ds, reply); + IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE msg := ds; + file name := msg. file name; + userid := msg. userid; + password := msg. password; + sendername := msg. sender name; + sender station := msg. station; + FI; + +. print file : + file := sequential file (input, file ds); + print (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); + +ENDPROC execute print ; + + +PROC check error (TEXT CONST message) : + IF is error + THEN clear error; + rename myself (message); + IF is error THEN clear error; end (myself) FI; + pause (18000); + end (myself); + FI; +END PROC check error; + +ENDPACKET multi user printer ; + diff --git a/system/net/1.8.7/src/spool cmd b/system/net/1.8.7/src/spool cmd new file mode 100644 index 0000000..b44e799 --- /dev/null +++ b/system/net/1.8.7/src/spool cmd @@ -0,0 +1,112 @@ +PACKET spool cmd (* Autor: R. Ruland *) + (* Stand: 01.04.86 *) + DEFINES killer, + first, + start, + stop, + halt, + wait for halt : + +LET error nak = 2 , + + entry line code = 23 , + killer code = 24 , + first code = 25 , + start code = 26 , + stop code = 27 , + halt code = 28 , + wait for halt code = 29 ; + +DATASPACE VAR ds; + +BOUND STRUCT (TEXT entry line, INT index) VAR control msg; +BOUND TEXT VAR error msg ; + +INT VAR reply; + +INITFLAG VAR in this task := FALSE; + + +PROC control spool (TASK CONST spool, INT CONST control code, + TEXT CONST question, BOOL CONST leave) : + + enable stop; + initialize control msg; + WHILE valid spool entry + REP IF control question THEN control spool entry FI PER; + + . initialize control msg : + IF NOT initialized (in this task) THEN ds := nilspace FI; + forget (ds); ds := nilspace; control msg := ds; + control msg. entry line := ""; + control msg. index := 0; + say (""13""10""); + + . valid spool entry : + call (spool, entry line code, ds, reply); + IF reply = error nak + THEN error msg := ds; + errorstop (error msg); + FI; + control msg. index <> 0 + + . control question : + say (control msg. entry line); + yes (question) + + . control spool entry : + call (spool, control code, ds, reply); + IF reply = error nak + THEN error msg := ds; + errorstop (error msg); + FI; + IF leave THEN LEAVE control spool FI; + +END PROC control spool; + + +PROC killer (TASK CONST spool) : + + control spool (spool, killer code, " loeschen", FALSE) + +END PROC killer; + + +PROC first (TASK CONST spool) : + + control spool (spool, first code, " als erstes", TRUE) + +END PROC first; + + +PROC start (TASK CONST spool) : + + call (stop code, "", spool); + call (start code, "", spool); + +END PROC start; + + +PROC stop (TASK CONST spool) : + + call (stop code, "", spool); + +END PROC stop; + + +PROC halt (TASK CONST spool) : + + call (halt code, "", spool); + +END PROC halt; + + +PROC wait for halt (TASK CONST spool) : + + call (wait for halt code, "", spool); + +END PROC wait for halt; + + +END PACKET spool cmd; + diff --git a/system/net/1.8.7/src/spool manager b/system/net/1.8.7/src/spool manager new file mode 100644 index 0000000..e711ab4 --- /dev/null +++ b/system/net/1.8.7/src/spool manager @@ -0,0 +1,915 @@ +PACKET spool manager DEFINES (* Autor: J. Liedtke *) + (* R. Nolting *) + (* R. Ruland *) + (* Stand: 22.07.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 , + false code = 6 , + + fetch code = 11 , + save code = 12 , + exists code = 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 : new file que entry + CASE exists code : exists 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; + +. + exists que entry : + msg := ds ; + order task name := name (order task); + order task station := station (order task); + to first que entry; + WHILE next que entry found + REP IF is entry from order task (msg. name) + THEN send ack; + LEAVE exists que entry + FI; + PER ; + forget (ds); ds := nilspace; + send (order task, false code, ds) + +. + 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 := entry station text; + 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)"; + + . entry station text : + IF last entry. ds params. station = 0 + THEN " " + ELSE text (last entry. ds params. station, 3) + FI + + . 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, station text + "/""" + name (myself) + """"); + put spool duty; + put current job; + put spool que; + + . station text : + IF station(myself) = 0 + THEN "" + ELSE text (station(myself)) + FI + + . 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/net/unknown/doc/EUMEL Netz b/system/net/unknown/doc/EUMEL Netz new file mode 100644 index 0000000..941e2ea --- /dev/null +++ b/system/net/unknown/doc/EUMEL Netz @@ -0,0 +1,829 @@ +#type ("trium8")##limit (11.0)# +#start(2.5,1.5)##pagelength (17.4)# +#block# +#headeven# + +% EUMEL-Netzbeschreibung + + +#end# +#headodd# + +#center#Inhalt#right#% + + +#end# + +#type ("triumb12")# +1. Einleitung + + +Teil 1: Netz einrichten und benutzen +#type ("trium8")# + +1. Benutzung des Netzes + +2. Hardwarevoraussetzungen + +3. Einrichten des Netzes + +4. Informationsmöglichkeiten + +5. Eingriffsmöglichkeiten + +6. Fehlerbehebung im Netz + +#type ("triumb12")# + +Teil 2: Arbeitsweise der Netzsoftware +#type ("trium8")# + +1. Die Netztask + +2. Protokollebenen + +3. Stand der Netzsoftware + +#page# +#headodd# + +#center#Einleitung#right#% + + +#end# + +#type("triumb12")# +1. Einleitung #type("trium8")# + + +Das EUMEL-Netz dient dazu mehrere EUMEL-Rechner (sog. Stationen) mit +einander zu koppeln. Diese Kopplung wird von Betriebsystem dazu benutzt, das +Sendungskonzept (siehe Systemhandbuch 1.7, Intertaskkommunikation) so auszu +dehnen, daß Tasks verschiedener Stationen einander Datenräume zusenden +können. Auf dem Sendungskonzept aufbauende Konzepte nutzen daher automa +tisch das Netz aus: So ist es z.B. möglich + +- von einer Station aus auf einer anderen zu Drucken, + +- in PUBLIC einer anderen Station Dateien zu sichern (save), vorausgesetzt, daß + PUBLIC dort ein free global manager ist, + +- auf einer anderen Station zu archivieren (z.B. wenn das eigene Archivlaufwerk + defekt ist oder ein anderes Format hat). + +Das Netz kann ab EUMEL-Version 1.7.3 eingesetzt werden. + + +#type("triumb12")# +Teil 1: Netz einrichten und benutzen + +1. Benutzung des Netzes #type("trium8")# +#headodd# + +#center#Teil 1: Netz einrichten und benutzen#right#% + + +#end# + + Zur Benutzung des Netzes stehen folgende Operatoren und Prozeduren zur + Verfügung: + + +1.1 + + TASK OP / (INT CONST station, TEXT CONST taskname) + + liefert die Task #on("bold")#taskname#off("bold")# von der Station #on("bold")#station#off("bold")#. + + Wenn die Station #on("bold")#station#off("bold")# nicht am Netz ist oder nicht eingeschaltet ist, wird + solange gewartet, bis das der Fall ist. + + Fehlerfälle: + + - task "..." gibt es nicht + + Die angeforderte Task gibt es in der Zielstation nicht. + + - Collectortask fehlt + + Das Kommando #on("bold")#define collector#off("bold")# wurde nicht gegeben (siehe 4.2). + + - Station x antwortet nicht + + Eine nicht vorhandene oder abgeschaltete Station wurde angesprochen. + Hinweis: Dieser Fehler wird angenommen, wenn eine Überwachungszeit + von ca. 30 Sekunden verschrichen ist, ohne daß Station x die + Taskidentifikation angeliefert hat. + + Beispiel: + + list (5/"PUBLIC") + + Dateiliste von PUBLIC auf Station 5 wird angefordert. + +1.2 + + TASK OP / (INT CONST station, TASK CONST task) + + liefert + + station / name (task) . + + + Beispiel: + + list (4/archive) + + +1.3 + + INT PROC station (TASK CONST task) + + liefert die Stationsnummer der Task #on("bold")#task#off("bold")#. + + Beispiel: + + put (station (myself)) + + gibt die eigene Stationsnummer aus. + + +1.4 + + PROC archive (TEXT CONST archivename, INT CONST station) + + dient dazu das Archiv auf der Station #on("bold")#station#off("bold")# anzumelden. + + Beispiel: + + archive ("std", 4); list (4/archive) + + gibt das Inhaltsverzeichnis der Archivfloppy im Laufwerk der Station 4 aus. + Hinweis: Vergessen Sie bei solchen Querarchivierungen nicht die Stations + angabe bei jedem einzelnen Archivkommando (z.B fetch ("xxx", #on("bold")#4/#off("bold")# + archive). + Hinweis: Querarchivieren ist langsam. Verwenden Sie es nur, wenn Sie Flop + pyformate umsetzen wollen. + + +1.5 + + PROC free global manager + + dient dazu, die eigene Task über das Netz ansprechbar zu machen. Jede + andere Task im Netz kann dann die üblichen Manageraufrufe ('save', 'fetch', + u.s.w.) an die eigene Task machen, sofern diese nicht an ein Terminal gekop + pelt ist. + + Die Task wird (wie bei 'break') abgekoppelt und meldet sich in Zukunft mit + 'maintenance' statt mit 'gib kommando'. + + Beispiel: + + An Station 4 ruft man in der Task 'hugo' das Kommando #on("bold")#free global manager#off("bold")# + auf. Anschließend kann man von jeder Station aus z.B. 'list (4/"hugo")' u.s.w. + machen. + + +1.6 + + TEXT PROC name (TASK CONST t) + + Diese (schon immer vorhandene) Prozedur wurde dahingehend erweitert, daß der + Name einer Task einer anderen Station über Netz angefordert wird. + + Fehlerfall: + + Station x antwortet nicht + + + + +#type("triumb12")#2. Hardwarevoraussetzungen#type("trium8")# + +2.1 Zwei Stationen + + Sie können zwei Stationen miteinander Vernetzen, wenn Sie dafür an jeder + Station eine V24-Schnittstelle zur Verfügung stellen. + + Diese beiden Schnittstellen verbinden Sie mit einem Kabel zur Rechner + kopplung (siehe Systemhandbuch 1.7 Teil 2). + +2.2 Mehrere Stationen + + Wenn Sie mehr als zwei Stationen vernetzen wollen, brauchen neben je + einer V24 an jeder Station noch je eine Netzanschlußbox. + + Jede Box besitzt eine V24-Schnittstelle zum Anschluß an die V24- + Schnittstelle der zugeorneten Station und eine weitere Schnittstelle zur + Verbindung der Boxen untereinander. + + +#type("triumb12")#3. Einrichten des Netzes #type("trium8")# + +Hinweis: Dieses Kapitel ist nur für Systembetreuer wichtig. + +3.1 Legen Sie Stationsnummern für die am Netz beteiligten Rechner fest (von 1 an + aufsteigend). + + Die Boxen haben ebenfalls Stationsnummern. Die Stationsnummern der Box + und des zugeordneten Rechners müssen übereinstimmen. + + +3.2 Holen Sie an jeder Station die Task #on("bold")#configurator#off("bold")# an ein Terminal und geben Sie + das Kommando #on("bold")#define collector ("net port")#off("bold")#. Geben Sie außerdem das + Kommando #on("bold")#define station (x)#off("bold")#, wobei #on("bold")#x#off("bold")# die gewählte Stationsnummer ist. + + Hinweis: Taskkommunikationen, die zu dem Zeitpunkt laufen, führen zu feh + lerhaften Verhalten. Dies liegt daran, daß durch #on("bold")#define station#off("bold")# alle + Task-Id's geändert werden müssen, weil eine Task-Id u.a. die + Stationsnummer der eigenen Station enthält (siehe 2.3). TASK- + Variable, die noch Task-Id's mit keiner oder falscher Stationsnum + mer enthalten, können nicht mehr zum Ansprechen einer Task + verwendet werden. + + Beispiel: Der Spoolmanager (siehe Benutzerhandbuch 1.7 Teil 12) richtet + beim Kommando #on("bold")#start#off("bold")# einen Worker ein und merkt sich dessen + Task-Id in einer TASK-Variablen, um sicherzustellen, daß nur der + Worker Dateien zum Drucken abholt. Wird jetzt das Kommando #on("bold")# + define station#off("bold")# gegeben, kann der Spoolmanager seinen Worker + nicht mehr identifizieren, weil der Worker eine neue Task-Id er + halten hat. Man muß daher den Worker löschen und mit dem + Kommando #on("bold")#start#off("bold")# im Spoolmanager wieder neu einrichten. + + + Sinnvollerweise gibt man #on("bold")#define station#off("bold")# sofort nach den Laden eines + frischen Systems von Archiv. + + Konfigurieren Sie mit dem Kommando #on("bold")#configurate#off("bold")# den für das Netz vorgese + henen Kanal auf + + - transparent + - 9600 Baud (Standardeinstellung der Boxen) + - RTS/CTS-Protokoll + - großen Puffer + - 8 bit + - even parity + - 1 stopbit. + + Falls diese Einstellungen nicht alle angeboten werden, klären Sie mit Ihrem + Rechnerlieferanten, ob und wie diese Einstellungen erreicht werden können. + Hinweis: Notfalls kann auf das RTS/CTS-Protokoll verzichtet werden, wenn + der Eingabepuffer der Station groß genug ist. Die Anzahl simultan + laufender Netzkommunikationen ist dann auf + + puffergröße DIV 150 + + begrenzt (bei Z80, 8086: 3; bei M20: 10). + Hinweis: Es können auch andere Baudraten (2400, 4800, 19200) an der Box + eingestellt werden. + +3.3 Achten Sie bei der Verbindung von der Station zur Netzbox (bzw. zur Gegen + station bei einem Zweistationennetz ohne Boxen) darauf, daß neben den + Empfangs- und Sendeleitungen auch die Leitungen RTS und CTS verdrahtet + werden, also ein 5 poliges Kabel verwendet wird (siehe Systemhandbuch 1.7 + Teil 2). Die Pin-Belegung der Boxen entspricht den dortigen Angaben. + + Beispiel: + + Verbindung eines CSK-Systems mit der Box: + + Stecker Stecker + Pin Pin + + 2 <---------> 3 + 3 <---------> 2 + 4 <---------> 5 + 5 <---------> 4 + 7 <---------> 7 + + +3.4 Richten Sie eine Task #on("bold")#net#off("bold")# unter #on("bold")#SYSUR#off("bold")# ein und insertieren Sie dort die Datei +en + + net report/M + basic net + net manager/M. + + Beantworten Sie die Frage nach dem Kanal für das Netz und nach der Fluß + kontrolle (RTS/CTS). + + +#type("triumb12")#4. Informationsmöglichkeiten #type("trium8")# + + In der Task #on("bold")#net#off("bold")# wird eine Datei #on("bold")#report#off("bold")# geführt in der Fehlersituationen des + Netzes verzeichnet werden. Diese Datei kann in jeder anderen Task mit #on("bold")#list + (/"net")#off("bold")# angezeigt werden. + + In jeder Task kann durch das Kommando #on("bold")#list (/"net port")#off("bold")# eine Übersicht über + die momentan laufenden Netzübertragungen der eigenen Station erhalten + werden. + + +#type("triumb12")#5. Eingriffsmöglichkeiten #type("trium8")# +#headodd# + +#center#Eingriffsmöglichkeiten#right#% + + +#end# + +5.1 Jede Task kann Sende- und Empfangsströme, die bei #on("bold")#list (/"net port")#off("bold")# gemel + det worden sind und die eigene Task betreffen, abbrechen. Hierzu ist das + Kommando #on("bold")#erase ("x",/"net port")#off ("bold")# zu geben, wobei x die Stromnummer (aus + dem 'list') ist. + + Unberechtigte Löschversuche werden abgewiesen. + + Von der Task 'net' aus können jedoch damit beliebige Ströme abgebrochen + werden. + +5.2 Durch das Kommando #on("bold")#start#off("bold")# kann von der Task 'net' aus das Netz neu gestartet + werden. Dabei werden alle augenblicklichen Netzkommunikationen gelöscht. + Die Tasks 'net port' und 'net timer' werden dabei gelöscht und neu eingerich + tet. + + #on("bold")#start (kanal, quit)#off("bold")# wirkt wie #on("bold")#start#off("bold")#. Zustzlich wird als Netzkanal 'kanal' eingestellt + und maximal 'quit' Empfangsströme zugelassen. 'quit' ist auf 3 zu setzen, + wenn der Kanal ohne RTS/CTS angeschlossen ist (siehe 3.2). + + +#type("triumb12")#6. Fehlersuche im Netz #type("trium8")# + + Fehler im Netz können sich verschiedenartig auswirken. Im Folgenden wird auf + einige Beispiele eingegangen: + + Beispiel: + + Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Station 4 antwortet nicht'. + + Fehlermöglichkeiten: + + - Station 4 gibt es nicht am Netz. + Abhilfe: Richtige Station angeben. + + - Station 4 ist nicht eingeschaltet. + Abhilfe: Station 4 einschalten. Kommando erneut geben. + + - Netztask an Station 4 ist nicht arbeitsfähig. + Abhilfe: Kommando 'start' in der Task 'net'. + + - Stationsnummern und Boxnummern stimmen nicht überein. + Abhilfe: Mit 'define station' Stationsnummern korrigieren (siehe 3.2). + + - Verbindung Rechner/Box am eigenen Rechner oder an Station 4 fehlt. + Abhilfe: Verbindungen überprüfen. Durch Ansprechen einer dritten Station + kann oft schnell geklärt werden, welche Rechner/Box-Verbindung + defekt sein muß. + + - Verbindung der Boxen untereinander defekt. + Abhilfe: Fehlende Verbindung, Masseschluß und Dreher (keine 1:1 Ver + bindung) überprüfen und beheben. + Hinweis: Liegt z.B. ein Masseschluß vor, so kann es durchaus sein, daß + Boxen, die nicht in der Nähe des Masseschluß stehen noch mitei + nander arbeiten können. Man kann aus der Tatsache, daß zwei + Boxen miteinander arbeiten können, also nicht schließen, daß man + nicht nach diesem Fehler suchen muß. + + + Beispiel: + + Auf #on("bold")#list (4/public)#off("bold")# erfolgt keine Reaktion. + + + - Station 4 ist während dieser Sendung zusammengebrochen. + Abhilfe: Station 4 wieder starten. Die Bearbeitung des 'list'-Kommandos + wird automatisch wieder aufgenommen. + + - PUBLIC auf Station 4 ist nicht im Managerzustand. + Abhilfe: PUBLIC in den Managerzustand versetzen. + + + Hinweis: Das Netz hat nocht nicht die volle Sendungslogik des EUMEL. So + wird nur ca. 10 Minuten lang versucht, eine Sendung zuzustellen. + Danach wird die Sendung gelöscht. Ist dies eingetreten, so muß + das list-Kommando erneut gegeben werden. + + - Fehler in der Netzhardware. + Überprüfen Sie, ob + + - die Boxen eingeschaltet sind, + - die Bereitlampe blinkt (wenn nicht: RESET an der Box) + - die V24-Kabel richtig stecken, + - die Boxen untereinander verbunden sind (1 zu 1 Verbindungen der 5 + poligen Diodenbuchsen). + + + - Die Netzsoftware ist auf einen nicht vorhergesehenen Fehler gelaufen. + Dieser wird im Report vermerkt. + Abhilfe: Geben Sie in der Task #on("bold")#net#off("bold")# das Kommando #on("bold")#start#off("bold")#. Dadurch wird die + Netzsoftware neu gestartet. Alle Netzkommunikationen dieser + Station gehen verloren. + + + Beispiel: + + Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Collectortask fehlt'. + + - In der Task 'configurator' wurde das Kommando 'define collector' (siehe 3.2) + nicht gegeben. + + - Die Task 'net port' existiert nicht mehr. + Abhilfe: Kommando 'start' in der Task 'net'. + + + Beispiel: + + Nach #on("bold")#fetch ("hugo",4/public)#off("bold")# sind Teile von der Datei "hugo" verfälscht. + + - Die V24-Verbindung zur Box ist nicht in Ordnung. + Abhilfe: Abstand zwischen Rechner und Box verkürzen; Baudrate ernie + drigen; Durch Wechseln der V24-Schnittstelle feststellen, ob + diese defekt ist. + Hinweis: Die Verbindung zwischen den Boxen ist durch Prüfsummen abge + sichert (Hardware). + +#headodd# + +#center#Teil 2: Arbeitsweise der Netzsoftware#right#% + + +#end# +#page# +#type("triumb12")# + +Teil 2: Arbeitsweise der Netzsoftware + + +1. Die Netztask #type ("trium8")# + +In diesem Kapitel wird beschrieben, wie eine Netztask in das System +eingebettet ist und welche Aufgaben sie hat. Unter Einhaltung dieser +Konzepte kann die ausgelieferte Netztask so geändert werden, daß sie +beliebige andere Netzhardware unterstützt. Z.Zt. ist die Netzsoftware noch +nicht so gegliedert, daß nur eine hardwareabhängige Komponente ausgetauscht +werden muß. + +Die Kommunikation zwischen Tasks im EUMEL-Betriebssystem basiert auf einem +Rendevouskonzept: Die Zieltask einer Sendung muß empfangsbereit sein, wenn die +Quelltask sendet. + +Die Kommunikationsprozeduren auf der niedrigsten Ebene sind 'send' (Senden) +und 'wait' (Warten auf Empfang). Bei der Kommunikation werden eine Integer +'code' und ein Datenraum 'dr' übergeben. 'code' muß >= 0 sein, da negative +Codes systemintern verwandt werden. Ist die empfangende Task an einen Kanal +gekoppelt ('continue'), so führt eine Zeicheneingabe auf diesem Kanal dazu, +daß eine +Sendung mit dem Code -4 ankommt. Die Eingabedaten müssen mit den üblichen +Eingabeprozeduren ('inchar' u.s.w.) abgeholt werden. Der übermittelte Datenraum +und die Absendertask sind dabei ohne Bedeutung und dürfen nicht interpretiert +werden. + +Die Prozedur 'send' hat einen Rückmeldeparameter, der besagt, ob die Sendung +übermittelt wurde. Gibt es die Zieltask nicht oder steht sie nicht im 'wait', so kann +die Sendung nicht übermittelt werden. + + +Ein Entwicklungskriterium für das EUMEL-Netz war es, möglichst wenig Unter +stützung von der virtuellen EUMEL-Maschine (EUMEL0) zu fordern, damit weit +gehend in ELAN programmiert werden kann. Dadurch ist es möglich eine (privili +gierte) Task mit der Netzabwicklung zu betrauen. + +Zunächst wird auf die EUMEL0-Unterstützung eingegangen: + +1.1. Es gibt die Prozedur 'define collector', mit der die für das Netz verantwort + liche Task der EUMEL0-Maschine bekannt gemacht wird. Diese Task wird im + folgenden Collector genannt. + +1.2. Es gibt die Prozedur 'define station', die für den Rechner eine Stationsnum + mer einstellt. Anhand dieser Nummer werden die Rechner eines Netzes un + terschieden. Das Einstellen bewirkt, daß für alle Tasks die Stationsnummer in + ihre Task-Id eingetragen wird (Task-Id's sind die Werte, die der Typ TASK + annehmen kann). + +1.3. Der Befehl 'station (task)' liefert die Stationsnummer der 'task'. So liefert z.B. + 'station (myself)' die Stationsnummer des eigenen Rechners. + +1.4. Eine Sendung, deren Zieltask in einem anderen Rechner liegt (also station + (ziel) <> station (myself)), wird auf die Collectortask geleitet. + +1.5. Es gibt eine Prozedur 'collected destination', die es dem Collector erlaubt, die + eigentliche Zieltask einer auf ihn geleiteten Sendung zu erfahren. + +1.6. Es gibt eine Variante der Prozedur 'send', die es dem Collector gestattet, der + Zieltask eine beliebige andere Task als Absender vorzumachen. + +1.7. Es gibt eine spezielle Task-Id 'collector', durch die der augenblicklich ein + gestellte Collector erreicht wird. Diese wird als Zieltask beim Aufruf der Ver + mittlungsdienste angegeben (siehe 2.5). Eine Sendung an 'collector' wird von + EUMEL0 an den derzeitigen Collector geschickt. + +Ein Collector kann also auf drei Wegen von den übrigen Tasks desselben Rechners +Sendungen erhalten: + + 1. Über ein normales Send (z.B. bei 'list (/"net port")', wenn "net port" der der + zeitige Collector ist), + + 2. über ein Send an die Task 'collector' (s.u.) und + + 3. als umgeleitete Sendung (z.B. bei 'list' an eine Task auf einem anderen + Rechner). + +Der Collector kann diese Fälle anhand von 'collected destination' unterscheiden. + +Die Punkte 1.4...1.6 dienen dazu, den Collector für über Netz kommunizierende +Task unsichtbar zu machen: Der Collector taucht nicht als Ziel oder Quelle von +Sendungen auf. Das ist notwendig, damit normale Tasks sich nicht darum kümmern +müssen, ob eine Sendung übers Netz geht oder im eigenen Rechner bleibt. + +Wenn ein Datenraum an einen anderen Rechner geschickt wird, muß der gesamte +Inhalt (z. Zt. max. 1 MB) übertragen werden. Dies macht bei der üblichen Netz +hardware eine Zerlegung in Packete nötig (siehe Systemhandbuch 173, Teil 4, +Punkt 5). Für Netze über V24-Kanäle stehen spezielle Blockbefehle zur verfü +gung: + +1.8. blockin / blockout (dr,seite,512+abstand,anzahl,rest) + + Es werden maximal 'anzahl' Bytes transferiert. In 'rest' wird zurückgemeldet, + wieviel Bytes nicht bearbeitet wurden (z.B. weil der Kanal nichts anliefert). + Bearbeitet werden die Bytes + + 'seite' * 512 + 'abstand' + + bis maximal + + 'seite' * 512 + 'abstand' + 'anzahl' - 1 + + Der Kanal, an den die Task gekoppelt ist, wird dabei über Stream-IO (d.h. + 'incharety' bei 'blockin' bzw. 'out' bei 'blockout') angesprochen. + + Hinweis: Die Anforderung darf nicht über Seitengrenze gehen, d.h. + + 'abstand' + 'anzahl' <= 512 + + muß erfüllt sein. + + +Eine Netzsendung läuft wie folgt ab: + +Die Task q auf Rechner rq mache ein 'send' an die Task z auf Rechner rz. + +1. Die Prozedur send ist ein EUMEL0-Befehl. Die EUMEL0-Ebene erkennt, daß + die Sendung an die Station rz geht, da die Stationsnummer in der Task-Id + enthalten ist. Daher wird die Sendung zum Collector, den EUMEL0 wegen 'de + fine collector' kennt, umgeleitet. + +2. Die Task Collector empfängt über 'wait' den Datenraum, den Sendecode und + die Absendertask q. Die Zieltask z erfährt sie durch 'collected destination'. + +3. Der Collector nimmt Kontakt mit dem Collector des Rechner rz, dessen Sta + tionsnummer ja 'station(z)' ist, auf und Übermittelt diesem Sendecode, Quelltask + (q), eigentliche Zieltask (z) und den Datenraum. Da die Collectoren in ELAN + geschrieben sind, können sie an beliebige Netzhardware und Protokolle ange + paßt werden. + +4. Der Collector auf Rechner rz verwendet das spezielle 'send', um der Zieltask die + Sendung zuzustellen. Dadurch erscheint nicht der Collector sondern die Task q + als Absender der Sendung. + +Zur Abwicklung der Vermittlungsebene (Teil 1: 2.4) muß der Collector noch +spezielle Funktionen beherrschen. Diese sind + + der /-Operator (Taskname in Task-Id wandeln) und + die name-Prozedur (Task-Id in Namen wandeln). + +Der /-Operator macht eine Sendung an den 'collector', wobei im Datenraum der +Name der Task steht und der Sendecode gleich der Stationsnummer ist (siehe +Quellcode 173, Packet tasks). Der Collector setzt sich mit dem Collector dieser Sta +tion in Verbindung, damit dieser die Task-Id ermittelt und zurückschickt. Der +eigene Collector schickt dann dem /-Operator als Antwort einen Datenraum, der +die Task-Id enthält. + +Umgekehrt läuft 'name' ab: Wenn die Task-Id von einer fremden Station ist, +schickt 'name' eine Sendung an den 'collector', wobei im Datenraum die Task-Id +steht und Sendecode = 256 ist. Der Collector entnimmt die Stationnummer der +Task aus der Task-Id und läßt sich vom entsprechenden Collector den Tasknamen +geben. Dieser wird der 'name'-Prozedur im Antwortdatenraum übergeben. + +#type ("triumb12")#2. Ebenen #type("trium8")# + +In diesem Kapitel werden die Protokollebenen für das Netz beschrieben, wie +sie die ausgelieferte Netzsoftware benutzt und erwartet. Bei anderer +Netzhardware müssen die Ebenen 1 bis 3 ausgetauscht werden. Unter Einhaltung +der im vorigen Kapitel beschriebenen Randbedingungen können auch die höheren +Ebenen geändert werden. + + +2.1 Physikalische Ebene + + 2.1.1 Station <--> Box + + V24-Schnittstelle mit RTS/CTS-Handshake. Vollduplex. + + 2.1.2 Box <--> Box + + RS422 über 2 verdrillte Leitungspaare (Takt und Daten). + +2.2 Verbindungsebene + + 2.2.1 Station <--> Box + + Asynchron + 8 Bit + Even Parity + 2400/4800/9600/19200 Baud (einstellbar über Lötbrücken) + + 2.2.2 Box <--> Box + + SDLC + 400 KBaud + +2.3 Netzebene + + 2.3.1 Station <--> Box + + Telegrammformat: STX, <n>, <ziel>, <quelle>, <(n-4) byte> + + <n> ist Längenangabe ( 8 <= n <= 160) + <ziel>, <quelle> sind Stationsnummern. Diese müssen an den je + weiligen Boxen über Lötbrücken eingestellt sein. + + Box --> Station: + + Ein Telegramm kommt nur bei der Station an, bei deren Box die + Nummer <ziel> eingestellt ist. Dadurch ist ein Mithören fremder + Übertragungen nicht möglich (Datenschutz). + + Zwischen Telegrammen können Fehlermeldungen der Box (Klartext) + übermittelt werden (z.B. 'skipped x', wenn ein STX von der Box er + wartet wurde, aber 'x' von der Station ankommt). + + Station --> Box: + + Ein Telegramm wird nur abgeschickt, wenn <quelle> mit der einge + stellten Nummer übereinstimmt (Datenschutz: Man kann nicht eine + beliebige Station zu sein vorschwindeln, es sei denn man hat physi + schen Zugriff zur Box und stellt dort die Stationsnummer um). + + 2.3.2 Box <--> Box + + Telegrammformat: FRAME, <ziel>, <quelle>, <daten> , + <CRC-Code> + + Eine Längenangabe ist nicht nötig, da SDLC eine Rekonstruktion der + Länge erlaubt. + + Telegramme mit falschen CRC-Code werden vernichtet. Auf höheren + Ebenen muß dies durch Zeitüberwachung erkannt und behandelt + werden. + + +2.4 Transportebene + + Diese Ebene wickelt das Rendevous zwischen einer Task, die 'send' macht, + und einer Task, die im 'wait' steht, ab (siehe: EUMEL-Systemhandbuch). + + Der im 'send' angegebene Datenraum wird als Folge von Seiten (im + EUMEL-Sinne: Pagingeinheit und Allokiereinheit) übermittelt, wobei jede Seite + noch in 64 Byte große Stücke zerlegt wird. Es werden nur echt allokierte Seiten + übermittelt. Um nicht jedes Telegramm voll qualifizieren zu müssen, wird + zunächst eine Art virtuelle Verbindung durch ein OPEN-Telegramm eröffnet. + Danach folgen variable viele DATA-Telegramme. Beide Sorten werden durch + QUIT-Telegramme quittiert, um folgende Funktionen zu ermöglichen: + + Flußkontrolle (z.B. Zielrechner langsam) + Wiederaufsetzen (verlorene Telegramme) + Abbruch (z.B. weil Zieltask inzwischen beendet). + + Ein CLOSE-Telegramm ist nicht nötig, da das letzte DATA-Telegramm als + solches erkannt werden kann (siehe unten). + + 2.4.1 OPEN-Telegramm + + STX, 20, <ziel>, <quelle>, <strom>, <sequenz>, <seite>, + <quelltask>, <zieltask>, <code> + + <ziel>, <quelle> siehe 2.3.1 + + <strom> Die Stromnummer identifiziert die virtuelle Verbindung. + Sie muß in den QUIT-Telegrammen angegeben wer + den. + + <sequenz> -1 (Kennzeichen für OPEN) + + <seite> Nummer der ersten echt allokierten Seite des Datenra + ums (=-1, falls Nilspace) + + <quelltask> Taskid der sendenden Task + + <zieltask> Taskid der empfangenden Task + + <code> Wert des im 'send' angegebenen Codes. + + 2.4.2 DATA-Telegramm + + STX, 74, <ziel>, <quelle>, <sequenz>, <seite>, <64 byte> + + <sequenz> wird von Telegramm zu Telegramm hochgezählt. Dient + der Überwachung gegen verlorengegangene Telegramme + bzw. durch Zeitüberwachung verdoppelter Telegramme. + + <seite> Nummer der x.ten echt allokierten Seite des Datenra + ums. (x = (<sequenz>+16) DIV 8). + + <64 byte> Nutzinformation. Diese gehört zur Adresse a des Daten + raums. + + a = N (<sequenz> DIV 8 + 1) * 512 + + (<sequenz> MOD 8) * 64 + + wobei N (x) die Nummer der x.ten Seite ist. + + Aus den Formeln ergibt sich, daß diese Nummer schon in + einem vorhergehenden DATA/OPEN-Telegramm über + mittelt wurde (im Feld <seite>). + + 2.4.3 QUIT-Telegramm + + STX, 8, <ziel>, <quelle>, <strom>, <quit> + + <strom> muß die Stromnummer sein, die in dem OPEN/DATA- + Telegramm stand, das quittiert wird. + + <quit> 0 : ok. Nächstes Telegramm schicken. + + -1: Übertragung neu starten (mit OPEN), weil die + Empfangsstation das OPEN nicht erhalten hat. + + -2: Übertragung ca. 20 Telegramme zurücksetzen. + + -3: Übertragung abbrechen. + + +2.5 Vermittlungsebene + + Diese Ebene ist dafür zuständig, Tasknamen von Task auf anderen Stationen + in Taskids (Werte des Typs TASK) zu wandeln und umgekehrt. Hierzu wird im + entsprechenden OPEN-Telegramm der Code -6 (bzw. -7) als <code> + eingetragen. Die Netzempfangstask erkennt diese Codes und wickelt die + Aufgaben selbst ab, sodaß es dabei nicht nötig ist, irgendeine Taskid der + Zielstation zu kennen. + + Dieses Verfahren ist möglich, weil im 'send' nur positive Codes erlaubt sind. + +2.6 Höhere Ebenen + + Höhere Ebenen sind nicht mehr netzspezifisch. Sie basieren alle auf dem + Send/Wait-Konzept des EUMEL. So gibt es z.B. den 'global manager', der + Aufbewahrung und Zugriff von Dateien in einer Task regelt. Dabei darf diese + Task (bei der Variante 'free global manager') auf einer beliebigen Station im + Netz liegen. Wegen des Rendevous-Konzepts können beliebige Sicherheit + strategien benutzt werden (z.B.: Keine Dateien an Station 11 ausliefern). Von + großen Wert ist z.B., daß man ohne weiteres das Archiv (Floppylaufwerk) einen + anderen Station anmelden und benuzten kann, wodurch eine einfache Kon + vertierung von Floppyformaten möglich ist. Dies ist möglich, weil auch die Ar + chiv-Task der Stationen sich an das Globalmanagerprotokoll halten. + + +#type("triumb12")# +Bemerkungen#type("trium8")# + +Fehlerbehandlung besteht bis Ebene 3 darin, fehlerhafte Telegramme einfach zu +entfernen. Die Ebene 4 überwacht den Netzverkehr sowieso über Timeouts, die +eine Wiederhohlung eines Telegrammes bewirken, wenn die Quittung ausbleibt. + +Da bei der sendenden Station der ganze Datenraum zur Verfügung steht, ist eine +Fenstertechnik (wie bei HDLC) nicht nötig. Es kann zu jedem Zeitpunkt um beliebig +viele Telegramme zurückgesetzt werden. + +Da im EUMEL eine Textdatei ein Datenraum mit sehr komplexer Struktur ist (wegen +der Insert/Delete-Möglichkeiten, ohne den Rest der Datei zu schieben), ist es ein +hoher Aufwand, von einem fremden Betriebssytem her Textdateien ins EUMEL- +Netz zu senden. Für solche Zwecke muß noch eine einfachere Dateistruktur defi +niert werden und entsprechende Dateikonverter erstellt werden. + + + +#type("triumb12")#3. Stand der Netzsoftware #type("trium8")# + +Das EUMEL-System wickelt die Prozedur #on("bold")#send#off("bold")# über das Netz ab, wenn die +Stationsnummer der Zieltask ungleich der eigenen Stationsnummer ist. Umge +kehrt kann man der von der Prozedur #on("bold")#wait#off("bold")# gelieferten Absendertask die Absen +derstation entnehmen (siehe Prozedur #on("bold")#station#off("bold")# in Abschnitt 3). + +Nicht unterstützt wird z.Zt. die Logik der Prozeduren #on("bold")#call#off("bold")# und #on("bold")#pingpong#off("bold")#. Diese +funktionieren nur in der gewohnten Weise, wenn die Zieltask in #on("bold")#wait#off("bold")# steht. Ist +die Zieltask länger als ca. 10 Minuten #on("bold")#busy#off("bold")# oder nicht mehr vorhanden, geht die +Sendung einfach verloren (Gefordert ist: bei #on("bold")#call#off("bold")#: immer wieder versuchen; bei #on("bold")# +pingpong#off("bold")#: Rückmeldung -2). + +Wegen dieser Einschränkung kann man z.B. ein sicheres Drucken von Station a +auf einen Drucker der Station b nur durch einen eigenen Spoolmanager auf +Station a verwirklichen. Die Einrichtung eines solchen Managers ist allerdings +sowieso sinnvoll, damit man + +- das normale 'print'-Kommando verwenden kann (statt z.B. save ("xxx", +4/printer);) und +- nicht zu warten braucht, bis die Datei übers Netz gesendet ist. + + diff --git a/system/printer-24nadel/0.9/doc/readme b/system/printer-24nadel/0.9/doc/readme new file mode 100644 index 0000000..d526aa3 --- /dev/null +++ b/system/printer-24nadel/0.9/doc/readme @@ -0,0 +1,320 @@ +#type("nlq10")##limit(18.0)##start(1.5,1.0)# +#head# +Treiber-Installations-Programm #right#Seite % +für 24-Nadel-Matrixdrucker #right#23.12.1988 + + +#end# +#on("u")#Dokumentation zum Treiber-Installations-Programm für 24-Nadel- +Matrixdrucker#off("u")# + +#on("u")#Inhalt:#off("u")# + +1. Installations- und Gebrauchsanleitung +2. Druckertreiber-Auswahl +3. Steuerungsmöglichkeiten und Spezialfeatures +4. Weitere Hinweise + + +#on("b")#1. Installations- und Gebrauchsanleitung#off("b")# + +#on("u")#Einrichten#off("u")# +So wird das Treiber-Installationsprogramm eingerichtet: + + SV drücken + + nach 'gib supervisor kommando:' + + begin("PRINTER","SYSUR") + + in der Task "PRINTER" (nach 'gib kommando'): + + archive ("std.printer") + fetch ("printer.24.nadel",archive) + check off + insert ("printer.24.nadel") + +Das Programm wird dann insertiert. + +#on("u")#Druckerkanal#off("u")# +Hiernach wird die Kanalnummer des Druckers erfragt. Wenn der Drucker +über Parallelschnittstelle betrieben wird, ist die Kanalnummer +meistens 15. + +#on("u")#Menüsystem#off("u")# +Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern. +Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste +der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier +den passenden Typ aus! +Das Installationsprogramm zeigt nun einige Informationen zu dem ange +wählten Drucker. Besonders zu beachten sind hierbei #on("u")#Angaben zur Konfi +guration des Druckers#off("u")# (z.B. DIP-Schalter). Der Drucker muß unbedingt +wie angegeben konfiguriert werden, wenn er mit dem ausgewählten Trei +ber betrieben werden soll. + +Hinweise zu Konfigurationsangaben: +1. Die Angabe 'egal' bedeutet, daß die Einstellung für die Funktion + des Treibers keine Bedeutung hat. Dennoch solte der Anwender darauf + achten, welche Funktion die Schalter haben (Druckerhandbuch!). So + ist es zum Beispiel immer empfehlenswert, den Papierende-Sensor zu + aktivieren, damit der Drucker nach Papierende nicht auf der Walze + weiterdruckt. +2. Die Konfigurationsangaben beziehen sich immer auf genau den ausge + wählten Druckertyp. Wenn Sie den Treiber mit einem anderen Drucker + als den ausgewählten verwenden, dann beachten Sie folgende Regeln + für die Konfiguration: + - Der Drucker muß auf eine passende Emulation konfiguriert werden. + - Der Drucker darf bei einem Carriage Return (Code 13) keinen Zei + lenvorschub durchführen. + - Der Drucker darf die Perforation #on("u")#nicht#off("u")# automatisch überspringen. + + - Auf Seitenlängen und internationale Zeichensätze müssen Sie nicht + achten. + +(Hinweise zur Auswahl des richtigen Treibers gibt Abschnitt 2) + +Nach den Konfigurationsangaben werden Steuerungsmöglichkeiten des +ausgewählten Treibers angezeigt. (Siehe hierzu Abschnitt 3) + +Falls der Treiber bestimmte grundsätzliche Betriebsmöglichkeiten er +laubt (z.B. DRAFT/NLQ, Einzelblatteinzug), werden Sie danach gefragt, +welche Möglichkeit standardmäßig gewählt werden soll. diese Vorein +stellungen können nachträglich in der Task "PRINTER" mit den entspre +chenden Steuerprozeduren neu gesetzt werden. Außerdem können bestimmte +Einstellungen noch für jedes einzelne Dokument (d.h. für jede Druck +datei) gewählt ('material'-Anweisung) oder sogar innerhalb eines Doku +ments verändert werden (direkte Druckeranweisung \#"..."\#). +Über die Steuerungsmöglichkeiten informiert Abschnitt 3 ausführlicher. + + +#on("b")#2. Druckertreiber-Auswahl#off("b")# + +#on("u")#Verwendung nicht im Menü enthaltener Drucker#off("u")# +Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, soll +ten Sie zunächst versuchen, ob ein Treiber für einen anderen Drucker +des gleichen Herstellers mit Ihrem Drucker korrekt arbeitet. +Falls dies nicht funktioniert oder der Hersteller überhaupt nicht im +Menü erscheint, müssen Sie herausfinden (Druckerhandbuch, -händler!), +welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist. +(Viele Drucker verfügen über EPSON LQ-1000 oder IBM Grafikdrucker bzw. +Proprinter-Eumulationen.) +Eine der beiden Anpassungen 'EPSON LQ-1050' oder 'OKI ML-393 +IBM-kompatibel' müßte immer einen (Minimal-) Betrieb ermöglichen (wobei die +Verwendung der Proportionalschrift bzw. der doppelt hohen Schriften u. U. +nicht funktioniert). + + +#on("b")#3. Steuerungsmöglichkeiten und Spezialfeatures#off("b")# + +Einige Treiber bieten bestimmte Einstellungsmöglichkeiten (z.B. +DRAFT/NLQ) und/oder Spezialfeatures (z.B. Farbdruck). +Die Einstellungen können über +- Steuerprozeduren +- Materialanweisungen bzw. +- direkte Druckeranweisungen +vorgenommen werden. + +#on("u")#Steuerprozeduren#off("u")# +setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten +sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER") +aufgerufen werden. #on("b")#Gültig werden die Änderungen erst, wenn danach in +der Druckspooltask das Kommando 'start' gegeben wird!#off("b")# + +PROC papersize (REAL CONST breite, länge) + Dient zur Einstellung der Größe der physikalisch beschreibbaren + Fläche. + Beispiel: papersize (20.32, 30.48) + (Standardeinstellung für Endlospapier 8 Zoll breit und + 12 Zoll lang) + +PROC papersize + Informationsprozedur + +PROC top margin (REAL CONST margin) + Falls der Drucker es nicht erlaubt, direkt am Blattanfang zu druk + ken (zum Beispiel wegen eines Einzelblatteinzugs), muß mit dieser + Prozedur die Länge des oberen Randes, den der Drucker nicht be + drucken kann, in cm angegeben werden. + Beispiel: top margin (2.0) + (Teilt dem Druckertreiber mit, daß die ersten 2 cm + nicht bedruckbar sind.) + +REAL PROC top margin + Informationsprozedur + +PROC std speed (TEXT CONST speed) + Parameter: slow, fast + Wahl zwischen Positionierung in Mikroschritten (slow) oder in + Blanks (fast). + Beispiel: std speed ("slow") + +TEXR PROC std speed + Informationsprozedur + +PROC std quality (TEXT CONST quality) + übliche Parameter: draft, nlq + Wahl zwischen Datenverarbeitungs-Qualität und Schönschrift- + Qualität + Beispiel: std quality ("draft") + +TEXT PROC std quality + Informationsprozedur + +PROC std typeface (TEXT CONST typeface) + übliche Parameter: roman, sansserif, courier + Wahl zwischen verschiedenen NLQ-Schriftarten (nur sichtbar im + NLQ-Modus, das heißt 'std typeface' schaltet nicht auf NLQ). + Beispiel: std typeface ("roman") + +TEXT PROC std typeface + Informationsprozedur + +PROC paper feed (TEXT CONST name) + übliche Parameter: tractor, sheet, schacht1, schacht2 + Wählt Endlospapier oder Einzelblatteinzug und ggf. Schachtnummer. + Beispiel: paper feed ("sheet") + +TEXT PROC paper feed + Informationsprozedur + + +#on("u")#Materialanweisungen \#material("...")\##off("u")# +müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und +setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben +für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge +stellten Standardwerten. Diese werden durch die Materialanweisung aber +nicht geändert.) + +Beispiel: \#material("nlq")\# + sorgt bei entsprechendem Treiber dafür, daß das gesamte + Dokument in Schönschrift-Qualität ausgedruckt wird, egal + wie 'std quality' eingestellt ist. + +#on("b")#Es darf in einer Datei nur eine Materialanweisung stehen!#off("b")# Sollen meh +rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung +erscheinen. Beispiel: \#material("sheet;draft")\# + + +#on("u")#direkte Druckeranweisungen \#"..."\##off("u")# +gelten ab der Position, an der sie in der Datei auftreten. Sie haben +(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und +Materialeinstellungen. + +Beispiel: \#"draft"\# + schaltet (bei entsprechendem Treiber) auf Datenverar + beitungs-Qualität, egal welche Standardeinstellung vorliegt + und welche Materialanweisung gegeben wurde. + +#on("b")#In einer Druckeranweisung darf nur eine Einstellung vorgenommen +werden.#off("b")# Also: \#"nlq"\#\#"sansserif"\# + + +#on("u")#Wichtig#off("u")# +- Achten Sie bei Materialanweisungen und direkten Druckeranweisungen + besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben + berücksichtigt! Also: \#"nlq"\# und keinesfalls \#"NLQ"\#!!! +- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und + nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann + daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse + erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen + Reihenfolge an den Drucker sendet, als er in der Datei steht, die + mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B. + für beide Spalten) unerwünscht erhalten bleibt. + + +#on("u")#Tabelle#off("u")# +Die Tabelle soll einen Anhaltspunkt dafür geben, wie welche Einstel +lungen erfolgen können. + +#type("17")# + Steuerprozeduren Materialanweisungen direkte Druckeranweisungen + +#on("u")# #off("u")# + +Positionierung std speed slow, fast ------ + slow, fast + +Qualität std quality z.B. draft, nlq z.B. draft, nlq + z.B. draft, nlq + +Schriftart std typeface z.B. roman, z.B. roman, +(nur bei NLQ) z.B. roman, sansserif, courier sansserif, courier + sansserif, courier + +Einzelblatt- paper feed z.B. schacht1, z.B. schacht1, +einzug z.B. tractor, schacht2 schacht2 + sheet, + schacht1, schacht2 + +Farbdruck ------ ------ z.B. schwarz, + rot, blau, + violett, gelb + orange, grün + + + +#type("nlq10")##on("b")#4. Weitere Hinweise#off("b")# + +#on("u")#Zeichensatzänderungen gegenüber früheren Versionen#off("u")# +In den Fonttabellen früherer Druckertreiber-Versionen wurden oberhalb +des Codes 127 einige internationale Zeichen zur Verfügung gestellt +(und zwar in Anlehnung an den Agfa-Laserdrucker-Zeichensatz). +Bei den Treibern der vorliegenden Version gilt folgendes: +- Wie bisher wird der volle im Benutzerhandbuch festgelegte EUMEL- + Zeichensatz (sofern möglich) unterstützt. +- Der Code 252 liefert das Paragraphzeichen. +- Alle übrigen (vom EUMEL-Zeichensatz nicht definierten) Zeichencodes + oberhalb 127 liefern, sofern möglich, die entsprechenden Zeichen des + IBM-Grafikzeichensatzes. + + +#on("u")#Hinweis zu Proportionalschriften#off("u")# +Bei Proportionalschriften kann die Modifikation \#on("i")\# zu Problemen +führen (z.B. beim Blocksatz), wenn die kursiven Zeichen andere +Proportionalbreiten haben. + +#on("u")#Hinweis zur Modifikation on/off("b") bzw. on/off("r")#off("u")# +Die meisten 24-Nadel Drucker verfügen sowohl über einen horizontalen als +auch über einen vertikalen Schattendruck. Diese beiden Druckarten können +mit der Modifikation on("b") (bold) bzw. on("r") (eigentlich für reverse +gedacht) eingeschaltet werden. + +#on("u")#Hinweis zur Benutzung von Einzelblatteinzügen#off("u")# +Bei der Benutzung von Einzelblatteinzügen müssen folgende Einstel +lungen vorgenommen werden (vgl. auch Abschnitt 3!): + + Am Drucker: +1. Sie müssen Ihren Drucker auf die Option Einzelblatteinzug + schalten (siehe Druckerhandbuch!). + + In der Druckspooltask (meist 'PRINTER'): +2. Falls der Druckertreiber die Steuerprozedur 'paper feed' zur Verfü + gung stellt, müssen Sie mit 'paperfeed ("sheet")' oder (für + 2-Schacht-Einzüge) mit 'paperfeed ("schacht1")' bzw. 'paperfeed + ("schacht2")' den Druckertreiber auf Einzelblatteinzug umschalten. +3. Falls Sie eine andere Papierlänge als 12 Zoll (=30.48 cm) verwen + den, müssen Sie die neuen Papiermaße mit 'papersize' in cm einstel + len. + Beispiel: papersize (21.0, 29.7) + (für DIN A4-Blätter) +4. Falls der Drucker mit dem Einzelblatteinzug nicht direkt am Blatt + anfang drucken kann, sondern ein gewisser oberer Rand bleibt, muß + mit 'top margin' die Länge des nicht bedruckbaren Randes in cm dem + Druckertreiber mitgeteilt werden. + Beispiel: top margin (1.5) + (Wie groß der obere Rand ist, kann festgestellt werden, indem eine + Datei mit \#start(0.0,0.0)\# ausgedruckt wird.) + + Wurde mit 'top margin' dem Treiber die Größe der nicht bedruckbaren + Fläche mitgeteilt, so ist darauf zu achten, daß in den Druckdateien + ein genügend großer y-Wert für die Startposition eingestellt wird + ('start'-Anweisung). Andernfalls kommt es bei der Ausgabe in der + ersten Zeile zu Überschreibungen. + + +#on("b")#5. Die Änderungen, die Sie in der Druckspooltask vorgenommen haben + werden erst wirksam, wenn das Spool-Kommando 'start' gegeben wird.#off("b")# + + + + diff --git a/system/printer-24nadel/0.9/source-disk b/system/printer-24nadel/0.9/source-disk new file mode 100644 index 0000000..2ed06c0 --- /dev/null +++ b/system/printer-24nadel/0.9/source-disk @@ -0,0 +1,3 @@ +grundpaket/07_std.printer_24_nadel.img +187_ergos/05_std.printer_24nadel.img +187_ergos/06_std.printer_24nadel.img diff --git a/system/printer-24nadel/0.9/src/beschreibungen24 b/system/printer-24nadel/0.9/src/beschreibungen24 new file mode 100644 index 0000000..e3d2fa9 --- /dev/null +++ b/system/printer-24nadel/0.9/src/beschreibungen24 @@ -0,0 +1,62 @@ + +(*************************************************************************) +(* Stand : 3. 1.89 *) +(* Beschreibungen-Datei für 24-Nadel-Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +$necp5p7$ +begin;headnecp5p7;declarations;feed; +open;opendoch;opendocp5p7;openpagep5-7;close;closepage; +execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end + +$necp6$ +begin;headnecp6;declarations;feed; +open;opendoch;opendocp6;openpagep5-7;close;closepage; +execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end + +$necp6+$ +begin;headnecp6+;declarations;speed;topmargin;typefacep6+;feed; +open;opendoch;initspeed;opendocp6+;openpage;close;closepage; +execute;cmdp6+;crs;move;stdmove;onoff;typep6+;end + +$epsonlq850$ +begin;headlq850;declarations;speed;topmargin;typefacelq850;feed; +open;opendoch;initspeed;opendoclq850;openpage;close;closepage; +execute;cmdlq850;crs;move;stdmove;onoff;typeplq850;end + +$epsonlq1500$ +printerlq1500;end + +$oki390/391$ +begin;headoki390/391;declarations;speed;topmargin;typefaceoki;feedschacht; +open;opendoch;initspeed;opendocokieps;openpage;close;closepage; +execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end + +$oki393/393Ceps$ +begin;headoki393/393Ceps;declarations;speed;topmargin;typefaceoki;feedschacht; +open;opendoch;initspeed;opendocokieps;openpage;close;closepage; +execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end + +$oki393/393Cibm$ +begin;headoki393/393Cibm;declarations;speed;topmargin;typefaceoki;feedschacht; +open;opendoch;initspeed;opendocokiibm;openpage;close;closepage; +execute;cmdoki;crs;move;stdmove;onoff;typeokiibm;end + +$toshp321$ +begin;headtoshp321;declarations;speed;feed; +open;opendochtosh;initspeed;opendoctosh;openpagetosh;close;closepagetosh; +execute;cmdtosh;crs;move;stdmove;onoff;typetosh;end + +$starnb24$ +begin;headstarnb24;declarations;speed;topmargin;typefacestar;feedschacht; +open;opendoch;initspeed;opendocstar;openpage;close;closepage; +execute;cmdstar;crs;move;stdmove;onoff;typestar;end + +$brotherm1724l$ +begin;headbrotherm1724l;declarations;speed;topmargin;feed; +open;opendoch;initspeed;opendocbrother;openpage;close;closepage; +execute;cmdtosh;crs;move;stdmove;onoff;typebrother;end + + + diff --git a/system/printer-24nadel/0.9/src/fonttab.brother b/system/printer-24nadel/0.9/src/fonttab.brother Binary files differnew file mode 100644 index 0000000..2251e18 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.brother diff --git a/system/printer-24nadel/0.9/src/fonttab.epson.lq1500 b/system/printer-24nadel/0.9/src/fonttab.epson.lq1500 Binary files differnew file mode 100644 index 0000000..1b4c6a6 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.epson.lq1500 diff --git a/system/printer-24nadel/0.9/src/fonttab.epson.lq850 b/system/printer-24nadel/0.9/src/fonttab.epson.lq850 Binary files differnew file mode 100644 index 0000000..7a6d2f0 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.epson.lq850 diff --git a/system/printer-24nadel/0.9/src/fonttab.nec.p5 b/system/printer-24nadel/0.9/src/fonttab.nec.p5 Binary files differnew file mode 100644 index 0000000..9910da6 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.nec.p5 diff --git a/system/printer-24nadel/0.9/src/fonttab.nec.p5.new b/system/printer-24nadel/0.9/src/fonttab.nec.p5.new Binary files differnew file mode 100644 index 0000000..9804bd5 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.nec.p5.new diff --git a/system/printer-24nadel/0.9/src/fonttab.nec.p6+ b/system/printer-24nadel/0.9/src/fonttab.nec.p6+ Binary files differnew file mode 100644 index 0000000..b209e81 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.nec.p6+ diff --git a/system/printer-24nadel/0.9/src/fonttab.oki b/system/printer-24nadel/0.9/src/fonttab.oki Binary files differnew file mode 100644 index 0000000..2251e18 --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.oki diff --git a/system/printer-24nadel/0.9/src/fonttab.toshiba.p321 b/system/printer-24nadel/0.9/src/fonttab.toshiba.p321 Binary files differnew file mode 100644 index 0000000..452afca --- /dev/null +++ b/system/printer-24nadel/0.9/src/fonttab.toshiba.p321 diff --git a/system/printer-24nadel/0.9/src/inserter b/system/printer-24nadel/0.9/src/inserter new file mode 100644 index 0000000..442075d --- /dev/null +++ b/system/printer-24nadel/0.9/src/inserter @@ -0,0 +1,793 @@ + +(*************************************************************************) +(* Installationsprogramm für Stand : 3. 1.89 *) +(* 24-Nadel Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +PACKET driver inst 24 + + + DEFINES treiber einrichten: + + +LET up = ""3""13""5"", + + generator name = "printer.24.nadel", + + description file name = "beschreibungen24", + module file name = "module24"; + + +INT VAR pr channel, + quality, + paper format number, + service option; +TEXT VAR fonttab name :: "", + driver name :: ""; +TEXT VAR inp; +BOOL VAR was esc; + +treiber einrichten + +PROC treiber einrichten: + + treiber einrichten (0) +END PROC treiber einrichten; + +PROC treiber einrichten (INT CONST service opt): + + ask for print channel; + main menu; + IF installed + THEN generate printer spool + ELSE inform about restart + FI. + + ask for printchannel: + inits; + page; + headline ("Druckerkanal - Einstellung"); + cursor (1, 15); + putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit"); + putline (" 'serverchannel (Kanalnummer)' in der Task """ + + name (myself) + """"); + putline (" verändert werden."); + REP + cursor (1, 10); + put (""5"EUMEL-Kanalnummer des Druckerkanals:"); + get (pr channel); + disable stop; + serverchannel (pr channel); + BOOL VAR no error :: NOT is error; + clear error; + no error := no error CAND + (pr channel <> channel (myself)) CAND + (pr channel > 1) CAND + (pr channel < 17); + + IF NOT no error + THEN cursor (1, 7); + put error; + putline ("Eingabe korrigiert wiederholen!") + FI; + enable stop + UNTIL no error PER; + IF exists task ("canal " + text (pr channel)) + THEN end (/ ("canal " + text (pr channel))); + FI; + +. inits: + line; + IF single task + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") + FI; + command dialogue (TRUE); + IF name (myself) <> "PRINTER" + THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ + + name (myself) + """ !"); + IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?") + THEN rename myself ("PRINTER") + FI + FI; + INT VAR choice; + service option := service opt. + + single task: (pcb (9) AND 255) = 1. + + main menu: + BOOL VAR installed :: FALSE; + REP + show main menu; + get choice; + treat choice + UNTIL was esc OR installed PER. + + show main menu: + page; + headline("Hauptmenü 24-Nadel-Drucker"); + putline (" 1. Brother"); + putline (" 2. Epson"); + putline (" 3. NEC"); + putline (" 4. OKI"); + putline (" 5. Toshiba"). + + get choice: + cursor (1,24); + put ("CR: Eingabe ESC: Installation abbrechen"); + ask user (5). + + treat choice: + SELECT int (inp) OF + CASE 1: brother menu + CASE 2: epson menu + CASE 3: nec menu + CASE 4: oki menu + CASE 5: toshiba menu + END SELECT. + + + brother menu: + page; + headline ("brother - Menü"); + putline (" 1. M-1724 L"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + brother m1724l inst + FI. + + brother m1724l inst: + putline ("brother M-1724 L"); + line; + putline ("Wählen Sie folgende DIP-Schalter Optionen:"); + putline ("Emulationsmodus IBM Proprinter XL "); + putline ("Automatischer Zeilenvorschub Nein "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.brother"); + generate ("brotherm1724l"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + toshiba menu: + page; + headline ("TOSHIBA - Menü"); + putline (" 1. P 321"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + toshiba p321 inst + FI. + + toshiba p321 inst: + putline ("TOSHIBA P 321"); + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S3-8 S3-7 S3-5 übrige Schalter"); + putline ("OFF OFF *) egal "); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std speed, paper feed"); + show material options("slow, fast"); + show command options ("nlq, draft"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.toshiba.p321"); + generate ("toshp321"); + adjust papersize; + adjust quality; + do ("papersize(21.0,30.48)"); + installed := TRUE; + FI. + + + epson menu: + page; + headline ("Epson - Menü"); + putline (" 1. LQ 850"); + putline (" 2. LQ 1050"); + putline (" 3. LQ 1500"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (3); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : lq850 inst + CASE 2 : lq850 inst + CASE 3 : lq1500 inst + END SELECT + FI. + + lq850 inst: + IF choice = 1 + THEN putline ("Epson LQ 850") + ELSE putline ("Epson LQ 1050") + FI; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8"); + putline ("egal egal egal egal egal egal *1) OFF "); + putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line; + putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8"); + putline ("egal egal *2) OFF OFF"); + putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle "); + putline (" gesetzt werden (Druckerhandbuch)"); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, roman, sansserif"); + show command options ("draft, nlq, roman, sansserif"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.epson.lq850"); + generate ("epsonlq850"); + adjust quality; + adjust papersize; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + lq1500 inst: + putline ("EPSON LQ-1500"); + show control options (""); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + IF all right + THEN get fonttable ("fonttab.epson.lq1500"); + generate ("epsonlq1500"); + adjust quality; + installed := TRUE + FI. + + nec menu: + page; + headline ("NEC - Menü"); + putline (" 1. PINWRITER P5 "); + putline (" 2. PINWRITER P6 "); + putline (" 3. PINWRITER P7 "); + putline (" 4. PINWRITER P6 PLUS"); + putline (" 5. PINWRITER P7 PLUS"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (5); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : necp5p7 inst + CASE 2 : necp6 inst + CASE 3 : necp5p7 inst + CASE 4 : necp6plus inst + CASE 5 : necp6plus inst + END SELECT + FI. + + necp5p7 inst: + IF choice = 1 + THEN putline ("NEC PINWRITER P5") + ELSE putline ("NEC PINWRITER P7") + FI; + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp5p7"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6 inst: + putline ("NEC PINWRITER P6 "); + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp6"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6plus inst: + IF choice = 4 + THEN putline ("NEC PINWRITER P6 PLUS") + ELSE putline ("NEC PINWRITER P7 PLUS") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("CR FUNCTION CR ONLY "); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, courier, souvenir"); + show command options ("draft, nlq, courier, souvenir"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.nec.p6+"); + generate ("necp6+"); + adjust papersize; + adjust quality; + installed := TRUE; + IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI; + FI. + + oki menu: + page; + headline ("OKI - Menü"); + putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel"); + putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel"); + putline (" 3. MICROLINE 393/393C EPSON-kompatibel"); + putline (" 4. MICROLINE 393/393C IBM-kompatibel"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (4); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : oki ml390 inst + CASE 2 : oki ml390 inst + CASE 3 : oki ml393eps inst + CASE 4 : oki ml393ibm inst + END SELECT + FI. + + oki ml390 inst: + IF choice = 1 + THEN putline ("OKI Microline 390") ; + ELSE putline ("OKI Microline 391") ; + FI; + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE EPSON LQ "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki390/391"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + oki ml393eps inst: + putline ("OKI Microline 393 EPSON-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Ceps"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + oki ml393ibm inst: + putline ("OKI Microline 393 IBM-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE ASCII "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Cibm"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + + +generate printer spool: + IF service opt = 0 + THEN forget (generator name, quiet); + forget (driver name, quiet) + FI; + eumel must advertise; + cursor (1, 10); +(* putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (2); + putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer"); + putline (" Drucker eingesetzt werden soll."); + line (2); +*) +(* put ("Generierung beendet, weiter mit 'SV'"); + break (quiet); +*) + putline (" Generierung beendet."); + putline (" Weiter: Bitte Taste drücken"); + WHILE incharety <> "" REP ENDREP; + REP UNTIL incharety <> "" ENDREP; + break; + do ("spool manager (PROC printer)"). + + inform about restart: + page; + putline ("Es ist kein Druckertreiber installiert worden!"); + line; + putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline ("mit 'treiber einrichten' erneut aufgerufen werden."); + line; + pause(50); + break. + +END PROC treiber einrichten; + +PROC headline (TEXT CONST header): + + cursor (13,1); + putline ("E U M E L - Druckertreiber - Installations - Programm"); + cursor (40 - LENGTH header DIV 2, 2); + put (header); + line (2) +END PROC headline; + +PROC ask user (INT CONST max choice): + + TEXT VAR exit; + inp := ""; + REP + cursor (1,23); + IF inp = "" + THEN put ("Ihre Wahl (Nummer eingeben):") + ELSE put ("FEHLER! Eingabe korrigieren:") + FI; + editget (inp, ""27"", "", exit); + was esc := exit = ""27""; + UNTIL was esc OR ok PER. + + ok: + int (inp) > 0 AND int (inp) <= max choice AND last conversion ok. +END PROC ask user; + +PROC show control options (TEXT CONST options): + + line; + putline ("Steuerprozeduren in der Task """ + name (myself) + """:"); + write ("papersize, std quality"); + IF options <> "" + THEN put (","); + putline (options) + FI +END PROC show control options; + +PROC show material options (TEXT CONST options): + + line; + putline ("Mögliche Materialwerte (#material(""..."")#):"); + putline (options) +END PROC show material options; + +PROC show command options (TEXT CONST options): + + line; + putline ("Mögliche direkte Druckeranweisungen (#""...""#):"); + putline (options) +END PROC show command options; + +PROC ask for quality: + + line (1); + putline ("Standard - Druckqualität:"); + line; + REP out (up); + IF yes ("Draft Quality (schneller, aber nicht so schön)") + THEN quality := 1; LEAVE ask for quality + FI; + out (up); + IF yes ("Near Letter Quality (schöner, aber langsamer)") + THEN quality := 2; LEAVE ask for quality + FI; + PER +END PROC ask for quality; + +PROC adjust quality: + + IF quality = 1 + THEN do ("std quality (""draft"")") + ELSE do ("std quality (""nlq"")") + FI +END PROC adjust quality; + +PROC ask for papersize : +LET up = ""3""13""5""; + + paper format number := paper format ; + + . paper format : + line (1); + putline ("Papierformat:"); + line; + REP out (up); + IF yes ("Endlospapier, 8 Zoll breit") + THEN LEAVE paper format WITH 1 FI; + out (up); + IF yes ("Endlospapier, 13.2 Zoll breit") + THEN LEAVE paper format WITH 2 FI; + out (up); + IF yes ("Einzelblatteinzug, DINA 4") + THEN LEAVE paper format WITH 3 FI; + PER; + 0 +END PROC ask for papersize; + + +PROC adjust papersize: + + SELECT paper format number OF + CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 3 : do("papersize (21.0, 29.7)"); + do ("paper feed (""sheet"")") + END SELECT + +END PROC adjust papersize; + +BOOL PROC all right: + + line (3); + cursor (1,23); + yes ("Soll der ausgewählte Druckertreiber installiert werden") +END PROC all right; + +PROC get fonttable (TEXT CONST name): + + fonttab name := name; + from archive ((description file name & module file name & fonttab name) + - all); + fonttable (fonttab name); + command dialogue (FALSE); + save (fonttab name, /"configurator"); + IF service option = 0 + THEN forget (fonttab name) + FI; + command dialogue (TRUE); +END PROC get fonttable; + +PROC from archive (THESAURUS CONST files): + + IF highest entry (files) > 0 + THEN fetch from archive; + release (archive); + putline ("Archiv abgemeldet !") + FI. + + fetch from archive: + THESAURUS VAR thes :: files; + REP + ask for archive; + reserve archive; + fetch (thes / ALL archive, archive); + thes := thes - all + UNTIL highest entry (thes) = 0 PER. + +ask for archive: + TEXT VAR buffer; +(*line; + putline ("Bitte Archiv mit den Dateien"); + INT VAR index :: 0; + REP + get (thes, buffer, index); + putline (" " + buffer) + UNTIL index = 0 PER; + putline ("einlegen !"); + line; + putline ("Wenn eingelegt: Taste drücken !"); + inchar (buffer)*). + +reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop. + +END PROC from archive; + +THESAURUS OP & (TEXT CONST left, right): + THESAURUS VAR result := empty thesaurus; + insert (result, left); + insert (result, right); + result +END OP &; + +THESAURUS OP & (THESAURUS CONST left, TEXT CONST right): + THESAURUS VAR result := left; + insert (result, right); + result +END OP &; + +PROC generate (TEXT CONST name): + + open files; + read description; + build programme; + insert programme; + forget files. + + open files: + line (5); + cursor (1, 20); + putline (""4"Bitte warten !"); + putline (" - Der Treiber wird generiert."); + driver name := "printer." + name + "(generiert)"; + IF exists (driver name) + THEN forget (driver name, quiet) + FI; + FILE VAR des file :: sequential file (modify, description file name), + mod file :: sequential file (modify, module file name), + driver file :: sequential file (output, driver name). + + read description: + to line (des file, 1); + col (des file, 1); + downety (des file, "$" + name + "$"); + IF eof (des file) + THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" + + "Descriptions-File enthalten") + FI; + TEXT VAR description :: "", + record; + BOOL VAR done :: FALSE; + read record (des file, record); + record := subtext (record, col (des file) + LENGTH name + 2); + WHILE NOT eof (des file) AND NOT done REP + treat record + PER. + + treat record: + INT VAR dollar pos :: pos (record, "$"); + IF dollar pos = 0 + THEN description CAT compress (record); + down (des file); + read record (des file, record) + ELSE description CAT compress (subtext (record, 1, dollar pos - 1)); + col (des file, dollar pos); + done := TRUE; + FI. + + build programme: + get module name; + WHILE still modules REP + find module; + transfer module; + get module name + PER. + + get module name: + INT VAR semicol pos :: pos (description, ";"); + TEXT VAR module name; + IF semicol pos > 0 + THEN module name := subtext (description, 1, semicol pos - 1); + description := subtext (description, semicol pos + 1) + ELSE module name := description; + description := "" + FI. + + still modules: + module name <> "" OR description <> "". + + find module: + to line (mod file, 1); + col (mod file, 1); + downety (mod file, "$" + module name + "$"); + IF eof (mod file) + THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" + + "Modul-File enthalten") + FI. + + transfer module: + done := FALSE; + read record (mod file, record); + record := subtext (record, col (mod file) + LENGTH module name + 2); + WHILE NOT eof (mod file) AND NOT done REP + transfer record + PER. + + transfer record: + dollar pos := pos (record, "$"); + IF dollar pos = 0 + THEN write (driver file, compress (record)); + line (driver file); + down (mod file); + read record (mod file, record) + ELSE write (driver file, compress (subtext (record, 1, + dollar pos - 1))); + col (mod file, dollar pos); + done := TRUE; + cout (line no (mod file)) + FI. + + insert programme: + IF online + THEN putline (" - Der Treiber wird insertiert.") + FI; + check off; + insert (driver name). + + forget files: + IF service option = 0 + THEN forget (description file name, quiet); + forget (module file name, quiet) + FI . +END PROC generate; + +END PACKET driver inst 24 + diff --git a/system/printer-24nadel/0.9/src/module24 b/system/printer-24nadel/0.9/src/module24 new file mode 100644 index 0000000..a4957c2 --- /dev/null +++ b/system/printer-24nadel/0.9/src/module24 @@ -0,0 +1,1554 @@ + +(*************************************************************************) +(* Stand : 03. 1.89 *) +(* Module-Datei für 24-Nadel-Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +$begin$ +PACKET printer driver + + DEFINES printer, + open, + close, + execute, + paper size, + std quality, + +$headnecp6$ paper feed: +(* Treiber fuer NEC P6, automatisch generiert *) +LET underline linetype = 1; +INT VAR factor 1, factor 2, draft factor 1, draft factor 2; + +$headnecp5p7$ paper feed: +(* Treiber fuer NEC P5, P7 , automatisch generiert *) +LET underline linetype = 1; +INT VAR factor 1, factor 2, draft factor 1, draft factor 2; + +$headnecp6+$ std speed, + top margin, + paper feed, + std typeface: +(* Treiber für NEC P6 plus/P7 plus ,automatisch generiert *) + + +$headlq850$ std speed, + top margin, + paper feed, + std typeface: +(* Treiber für EPSON LQ-850/1050 ,automatisch generiert *) + +$headbrotherm1724l$ + std speed, + top margin, + paper feed: +INT VAR vertical factor := 1; +(* Treiber für BROTHER M-1724L in IBM-Emulation, automatisch generiert *) + +$headoki390/391$ + std speed, + top margin, + paper feed, + std typeface: +INT VAR vertical factor := 1; +(* Treiber für OKI MIKROLINE 390/391 ,automatisch generiert *) + +$headoki393/393Ceps$ + std speed, + top margin, + paper feed, + std typeface: +INT VAR vertical factor := 1; +(* Treiber für OKI MIKROLINE 393/393C EPSON-kompatibel, automatisch generiert *) + +$headoki393/393Cibm$ + std speed, + top margin, + paper feed, + std typeface: +INT VAR vertical factor := 1; +(* Treiber für OKI MIKROLINE 393/393C IBM-kompatibel, automatisch generiert *) + +$headtoshp321$ std speed, + paper feed: +(* Treiber für TOSHIBA P321, automatisch generiert *) + +$headstarnb24$ + std speed, + top margin, + paper feed, + std typeface: +(* Treiber für STAR NB 24-10/15 in Standard Betriebsart automatisch generiert *) + +$declarations$ +INT VAR font nr, font bits, modification bits, + blankbreite, x rest, high, low, steps; +REAL VAR x size, y size; +TEXT VAR buffer :: ""; +BOOL VAR is nlq ; +TEXT VAR font text :: ""; +TEXT VAR std quality name :: "draft"; + +. is pica : font bits = 0 +. is elite : font bits = 1 +.; + + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; +END PROC paper size; + +papersize (20.32, 30.48); + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); +END PROC paper size; + + + +PROC std quality (TEXT CONST quality) : + + IF quality = "nlq" OR quality = "draft" + THEN std quality name := quality + ELSE errorstop ("unzulässige Qualitätsbezeichnung") + FI +END PROC std quality; + +TEXT PROC std quality : + + std quality name +END PROC std quality; + + +$topmargin$ +REAL VAR y margin := 0.0 ; + +PROC top margin (REAL CONST margin): + + y margin := margin +END PROC top margin; + +REAL PROC top margin: + + y margin +END PROC top margin; + + +$speed$ +BOOL VAR is slow :: TRUE; +TEXT VAR std speed name :: "slow"; + +PROC std speed (TEXT CONST speed) : + + IF speed = "fast" OR speed = "slow" + THEN std speed name := speed + ELSE errorstop ("unzulässige Geschwindigkeit") + FI +END PROC std speed; + +TEXT PROC std speed : + +std speed name +END PROC std speed; + + +$typefacelq850$ +TEXT VAR act typeface name :: ""; +TEXT VAR std typeface name :: ""; + +. is roman: + act typeface name = "roman". +. is sansserif: + act typeface name = "sansserif" +.; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "roman" OR typeface = "sansserif" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + + + +$typefacep6+$ +BOOL VAR is courier :: TRUE; +TEXT VAR std typeface name :: "courier"; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "courier" OR typeface = "souvenir" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + +$typefaceoki$ +BOOL VAR is courier ; +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "courier" OR typeface = "kassette" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + +$typefacestar$ +BOOL VAR is roman ; +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "roman" OR typeface = "font1" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + +$feed$ +BOOL VAR is sheet feed :: FALSE; + +PROC paper feed (TEXT CONST feeder) : + + IF feeder = "sheet" + THEN is sheet feed := TRUE + ELIF feeder = "tractor" + THEN is sheet feed := FALSE + ELSE errorstop ("unzulässige Einzugsart") + FI +END PROC paper feed; + +TEXT PROC paper feed: + IF is sheet feed + THEN "sheet" + ELSE "tractor" + FI +END PROC paper feed; + +$feedschacht$ +BOOL VAR is sheet feed :: FALSE; +TEXT VAR feeder name :: "tractor"; + +PROC paper feed (TEXT CONST feeder) : + + IF feeder = "tractor" + THEN feeder name := "tractor"; + is sheet feed := FALSE + ELIF feeder = "sheet" OR feeder = "schacht1" + THEN feeder name := "schacht1" ; + is sheet feed := TRUE + ELIF feeder = "schacht2" + THEN feeder name := "schacht2" ; + is sheet feed := TRUE + ELSE errorstop ("unzulässige Einzugsart") + FI +END PROC paper feed; + +TEXT PROC paper feed: feeder name END PROC paper feed; + +$open$ +PROC open (INT CONST op code, INT VAR param1, param2): + + SELECT op code OF + CASE 1: open document(param1,param2) + CASE 2: open page (param1,param2) + END SELECT. +END PROC open ; + + +$opendoch$ +PROC open document (INT VAR x steps,y steps): + modification bits := 0; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 30) * 30; + +$opendochtosh$ +PROC open document (INT VAR x steps,y steps): + modification bits := 0; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 36) * 36; + +$initspeed$ + IF pos (material, "slow") <> 0 + THEN is slow := TRUE; + ELIF pos (material, "fast") <> 0 + THEN is slow := FALSE; + ELSE is slow := std speed name = "slow" + FI; + +$opendocp6+$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + FI; + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "courier") <> 0 + THEN is courier := TRUE ; + ELIF pos (material, "souvenir") <> 0 + THEN is courier := FALSE ; + ELSE is courier := std typeface name = "courier" + FI; +END PROC open document ; + +$opendocp5p7$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + center paper ; + FI; + + . center paper : + INT CONST x steps in chars := x steps DIV x step conversion (2.54 / 10.0), + left margin := (136 - x steps in chars) DIV 2; + out (""27"P"); + out (""27"l"); out (code (left margin + 1)); +END PROC open document ; + +$opendocp6$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + FI; +END PROC open document ; + +$opendoclq850$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + FI; + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "roman") <> 0 + THEN act typeface name := "roman" + ELIF pos (material, "sansserif") <> 0 + THEN act typeface name := "sansserif" + ELSE act typeface name := std typeface name + FI; +END PROC open document ; + +$opendocokieps$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN IF feeder name = "schacht2" + THEN out (""27""25"2") + ELSE out (""27""25"1") + FI + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "courier") <> 0 + THEN is courier := TRUE ; + ELIF pos (material, "kassette") <> 0 + THEN is courier := FALSE ; + ELSE is courier := std typeface name = "courier" + FI; +END PROC open document ; + +$opendoctosh$ + out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *) + out (""27"6"); (* Zeichensatz *) + out (""27"A"12""27"2") ; + out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; +END PROC open document ; + +$opendocbrother$ + out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *) + out (""27"6" + ""27"R"0""); (* Zeichensatz II ascii *) + out (""27"A"10""27"2") ; (* Zeilenabstand *) + out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *) + IF is sheet feed + THEN out (""27""25"4") + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; +END PROC open document ; + +$opendocokiibm$ + out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *) + out (""27"6" + ""27"!"64""); (* Zeichensatz II ascii *) + out (""27""91""92""4""0""0""0""180""); (* 1/180 *) + out (""27"A"12""27"2") ; (* Zeilenabstand *) + out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *) + IF is sheet feed + THEN IF feeder name = "schacht2" + THEN out (""27""25"2") + ELSE out (""27""25"1") + FI + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "courier") <> 0 + THEN is courier := TRUE ; + ELIF pos (material, "kassette") <> 0 + THEN is courier := FALSE ; + ELSE is courier := std typeface name = "courier" + FI; +END PROC open document ; + +$opendocstar$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* amerikanischer Zeichensatz *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN IF feeder name = "schacht2" + THEN out (""27""25"2") + ELSE out (""27""25"1") + FI + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "roman") <> 0 + THEN is roman := TRUE ; + ELIF pos (material, "font1") <> 0 + THEN is roman := FALSE ; + ELSE is roman := std typeface name = "roman" + FI; +END PROC open document ; + +$openpagetosh$ +PROC open page (INT VAR x start , y start): + + x start := 0; + IF is sheet feed + THEN y start := y step conversion (2.54) (* 1 Inch *) + ELSE y start := 0; + FI; + x rest := 0; + out (""13""); +END PROC open page; + +$openpage$ +PROC open page (INT VAR x start , y start): + + x start := 0 ; + y start := y step conversion (y margin) ; + x rest := 0; + out (""13""). +END PROC open page; + +$openpagep5-7$ +PROC open page (INT VAR x start , y start): + + x start := 0; + IF is sheet feed + THEN y start := y step conversion (8.466667e-1) (* 2/6 Inch *) + ELSE y start := 0; + FI; + x rest := 0; + out (""13""); +END PROC open page; + +$close$ + +PROC close (INT CONST op code, INT CONST param1) : + + SELECT op code OF + CASE 1: close document + CASE 2: close page (param1) + END SELECT. + +close document : +. +END PROC close ; + +$closepage$ +PROC close page (INT CONST remaining y steps) : + IF remaining y steps > 0 + THEN out (""12"") + ELIF is sheet feed + THEN out (""27""25"R") + FI; +END PROC close page; + +$closepagetosh$ +PROC close page (INT CONST remaining y steps) : + IF is sheet feed + THEN out (""12"") + ELIF remaining y steps > 0 + THEN out (""12"") + FI; +END PROC close page; + +$execute$ +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE 1: write text + CASE 2: write cmd + CASE 3: carriage return + CASE 4: move + CASE 5: draw + CASE 6: on + CASE 7: off + CASE 8: type +END SELECT. + +from : param1. +to : param2. + + write text : + out subtext (string, from, to). + +$cmdp6+$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "courier" + THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI; + ELIF buffer = "souvenir" + THEN IF is courier THEN is courier := FALSE; switch to souvenir FI; + ELIF buffer = "schwarz" + THEN out (""27"r0") + ELIF buffer = "rot" + THEN out (""27"r1") + ELIF buffer = "blau" + THEN out (""27"r2") + ELIF buffer = "violett" + THEN out (""27"r3") + ELIF buffer = "gelb" + THEN out (""27"r4") + ELIF buffer = "orange" + THEN out (""27"r5") + ELIF buffer = "grün" + THEN out (""27"r6") + ELSE out (buffer) + FI. + +$cmdp5-7$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN switch to nlq FI; + is nlq := TRUE; + ELIF buffer = "draft" + THEN IF is nlq THEN switch to draft FI; + is nlq := FALSE; + ELSE out (buffer); + FI;. + +$cmdlq850$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "roman" + THEN IF NOT is roman THEN act typeface name := "roman" ; + switch to roman FI; + ELIF buffer = "sansserif" + THEN IF NOT is sansserif THEN act typeface name := "sansserif"; + switch to sansserif FI; + ELSE out (buffer) + FI. + +$cmdoki$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "courier" + THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI; + ELIF buffer = "kassette" + THEN IF is courier THEN is courier := FALSE; switch to kassette FI; + ELIF buffer = "schwarz" + THEN out (""27"r0") + ELIF buffer = "rot" + THEN out (""27"r1") + ELIF buffer = "blau" + THEN out (""27"r2") + ELIF buffer = "violett" + THEN out (""27"r3") + ELIF buffer = "gelb" + THEN out (""27"r4") + ELIF buffer = "orange" + THEN out (""27"r5") + ELIF buffer = "grün" + THEN out (""27"r6") + ELSE out (buffer) + FI. + +$cmdtosh$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELSE out (buffer); + FI;. + +$cmdstar$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "roman" + THEN IF NOT is roman THEN is roman := TRUE; switch to roman FI; + ELIF buffer = "font1" + THEN IF is roman THEN is roman := FALSE; switch to font1 FI; + FI. + +$crs$ + carriage return : + x rest := 0; + out (""13""). + +$move$ +x steps : param1. +y steps : param2. + +move : + IF x steps < 0 OR y steps < 0 THEN stop FI; + IF x steps > 0 THEN x move FI; + IF y steps > 0 THEN y move FI. + +$stdmove$ +x move : + x rest INCR x steps; + high := (x rest) DIV blankbreite; + x rest := (x rest) MOD blankbreite; + steps := x rest DIV 3; + IF high > 0 THEN high TIMESOUT " " FI; + IF steps > 0 AND is slow + THEN IF is underline THEN out (" "8"") FI; + out (""27"Y" + code (steps) + ""0""); (* 1/360 *) + steps TIMESOUT ""0""; + x rest := x rest MOD 3 + FI. + +is underline: + bit (modification bits,7). + +y move : + IF y steps > 0 + THEN high := y steps DIV 255; + low := y steps MOD 255; + IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; (* 1/180 *) + IF low > 0 THEN out (""27"J" + code (low)) FI; + FI. + +draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> 1 + THEN stop + ELIF x steps > 0 + THEN x draw + FI. + +x draw : + x rest INCR x steps ; + steps := x steps DIV 3 ; + IF steps > 0 THEN + x rest := x steps MOD 3 ; + out (""27"Y"); + out (code (steps MOD 256)); + out (code (steps DIV 256)); + steps TIMESOUT ""1""; + FI. + +$movep5-7$ + x move : + x rest INCR x steps; + IF not is underline + THEN simple x move + ELSE underline x move + FI; + + . not is underline : + NOT bit (modification bits, 7) + + . simple x move : + high := x rest DIV factor 1; + x rest := x rest MOD factor 1; + out (""27"\"); + out (code (high MOD 256)); + out (code (high DIV 256)); + + . underline x move : + high := x rest DIV factor 2; + x rest := x rest MOD factor 2; + IF high < blankbreite + THEN stop + ELSE low := high MOD 127; + high := high DIV 127; + IF low >= blankbreite + THEN low DECR blankbreite; + ELSE high DECR 1; + low DECR (blankbreite - 127); + FI; + IF high > 0 + THEN out (""27" "); + out (code (127 - blankbreite)); + high TIMESOUT " "; + FI; + out (""27" "); + out (code (low)); + out (" "27" "0""); + FI; +. y move: + + low := y steps MOD 255; + high := y steps DIV 255; + IF high > 0 THEN high TIMESOUT (""27"J"255"") FI; + IF low > 0 THEN out (""27"J" + code (low)) FI; + +. draw : + IF x steps < 0 OR y steps <> 0 + THEN stop + ELIF x steps > 0 + THEN x draw + FI; + + . x draw : + x rest INCR x steps; + steps := x rest DIV 4; + x rest := x rest MOD 4; + IF steps > 0 + THEN low := steps MOD 256; + high := steps DIV 256; + out (""27"*"39""); + out (code (low)); + out (code (high)); + steps TIMESOUT dot; + FI; + + . dot : + IF linetype = underline linetype + THEN ""000""000""001"" + ELSE ""000""000""048"" + FI. + + +$onoff$ + modification : param1 +. + on : + buffer := on string (modification); + IF buffer <> "" + THEN modification bits := modification bits OR code (buffer); + switch to font; + ELSE stop + FI + +. + off : + buffer := off string (modification); + IF buffer <> "" + THEN modification bits := modification bits XOR code (buffer); + switch to font; + ELSE stop + FI. + +$typep6+$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is courier + THEN switch to courier + ELSE switch to souvenir + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to courier : + out (""27"k"0"") ; + +. switch to souvenir : + out (""27"k"15"") ; +END PROC execute; + +$typeplq850$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is roman + THEN switch to roman + ELSE switch to sansserif + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to roman : + out (""27"k"0"") ; + +. switch to sansserif : + out (""27"k"1"") ; +END PROC execute; + +$typeokieps$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + vertical factor := code (buffer SUB 1); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is courier + THEN switch to courier + ELSE switch to kassette + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + IF vertical factor = 2 + THEN out (""27"w"1"") + ELSE out (""27"w"0"") + FI; + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to courier : + out (""27"k"0"") ; + +. switch to kassette : + out (""27"k"127"") ; +END PROC execute; + +$typep5-7$ + type : + font nr := param1; + buffer := font string (font nr); + factor 1 := code (buffer SUB 1); (* 720 / Mikroschritte pro Inch mit ESC \ *) + factor 2 := code (buffer SUB 2); (* 720 / Mikroschritte pro Inch mit ESC Blank *) + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") DIV factor 2; + switch to font; + IF is nlq THEN switch to nlq FI; + +END PROC execute; + + +PROC switch to font : + + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +END PROC switch to font; + + +PROC switch to nlq : + + IF is pica OR is elite + THEN draft factor 1 := factor 1; + factor 1 := 4; + draft factor 2 := factor 2; + IF is pica + THEN factor 2 := 4 * factor 2 DIV 6; + blankbreite := char pitch (font nr, " ") DIV factor 2; + FI; + out (""27"x"1""); + ELSE out (""27"x"0""); + FI; + +END PROC switch to nlq; + + +PROC switch to draft : + + IF is pica OR is elite + THEN factor 1 := draft factor 1; + factor 2 := draft factor 2; + out (""27"x"0""); + FI; + +END PROC switch to draft; + +$typetosh$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + switch to font; + +. switch to font : + INT VAR master select bits := font bits OR modification bits ; + IF bit (master select bits,0) + THEN out (""27":") + ELSE out (""18"") + FI; + IF bit (master select bits,1) + THEN out (""27"I"2""27"P"1"") + ELSE out (""27"P"0"") + FI; + IF bit (master select bits,2) + THEN out (""27""15"") + FI; + IF bit (master select bits,3) + THEN out (""27"E") + ELSE out (""27"F") + FI; + IF bit (master select bits,4) + THEN out (""27"G") + ELSE out (""27"H") + FI; + IF bit (master select bits,5) + THEN out (""27"W"1"") + ELSE out (""27"W"0"") + FI; + IF bit (master select bits,6) + THEN + ELSE + FI; + IF bit (master select bits,7) + THEN out (""27"-"1"") + ELSE out (""27"-"0"") + FI; + out (font text); + + +. switch to nlq : + out (""27"I"2""); + +. switch to draft : + out (""27"I"1""); + +END PROC execute; + +$typeokiibm$ + type : + font nr := param1 ; + buffer := font string (font nr); + vertical factor := code (buffer SUB 1); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is courier + THEN switch to courier + ELSE switch to kassette + FI ; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + switch to font; + +. switch to font : + INT VAR master select bits := font bits OR modification bits ; + IF bit (master select bits,0) + THEN out (""27":") + ELSE out (""18"") + FI; + IF bit (master select bits,1) + THEN out (""27"I"2""27"P"1"") + ELSE out (""27"P"0"") + FI; + IF bit (master select bits,2) + THEN out (""27""15"") + FI; + IF bit (master select bits,3) + THEN out (""27"E") + ELSE out (""27"F") + FI; + IF bit (master select bits,4) + THEN out (""27"G") + ELSE out (""27"H") + FI; + IF bit (master select bits,5) + THEN out (""27"W"1"") + ELSE out (""27"W"0"") + FI; + IF bit (master select bits,6) + THEN out(""27"%G") + ELSE out(""27"%H") + FI; + IF bit (master select bits,7) + THEN out (""27"-"1"") + ELSE out (""27"-"0"") + FI; + IF vertical factor = 2 + THEN out (""27""91""64""4""0""0""0""2""0"") + ELSE out (""27""91""64""4""0""0""0""1""0"") + FI; + out (font text); + + +. switch to nlq : + out (""27"I"2""); + +. switch to draft : + out (""27"I"0""); + +. switch to courier : + out (""27"k"0"") ; + +. switch to kassette : + out (""27"k"127"") ; +END PROC execute; + +$typebrother$ + type : + font nr := param1 ; + buffer := font string (font nr); + vertical factor := code (buffer SUB 1); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + switch to font; + +. switch to font : + INT VAR master select bits := font bits OR modification bits ; + IF bit (master select bits,0) + THEN out (""27":") + ELSE out (""18"") + FI; + IF bit (master select bits,1) + THEN out (""27"I"2""27"P"1"") + ELSE out (""27"P"0"") + FI; + IF bit (master select bits,2) + THEN out (""27""15"") + FI; + IF bit (master select bits,3) + THEN out (""27"E") + ELSE out (""27"F") + FI; + IF bit (master select bits,4) + THEN out (""27"G") + ELSE out (""27"H") + FI; + IF bit (master select bits,5) + THEN out (""27"W"1"") + ELSE out (""27"W"0"") + FI; + IF bit (master select bits,6) + THEN + ELSE + FI; + IF bit (master select bits,7) + THEN out (""27"-"1"") + ELSE out (""27"-"0"") + FI; + IF vertical factor = 2 + THEN out (""27""91""64""4""0""0""0""2""0"") + ELSE out (""27""91""64""4""0""0""0""1""0"") + FI; + out (font text); + +. switch to nlq : + out (""27"I"2""); + +. switch to draft : + out (""27"I"0""); + +END PROC execute; + +$typestar$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is roman + THEN switch to roman + ELSE switch to font1 + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to roman : + out (""27"k"0"") ; + +. switch to font1 : + out (""27"k"1"") ; +END PROC execute; + + + +$printerlq1500$ +PACKET printer driver + +(**************************************************************************) +(* Stand : 29.07.86 *) +(* EPSON LQ-1500 Version : 4 *) +(* Autor : Rudolf Ruland *) +(* geändert am 15.12.88 hjh *) +(**************************************************************************) + + DEFINES printer, + open, + close, + execute, + + paper size, + std quality: + +LET +(* underline = 1, + bold = 2, + italics = 4, + reverse = 8, *) + + underline linetype = 1, + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8; + +INT VAR rest, high, low, factor; +BOOL VAR is nlq, factor was 6, condensed; +REAL VAR x size, y size; +TEXT VAR std quality name, buffer; + +(*********************************************************************) + +paper size (13.6 * 2.54, 12.0 * 2.54); +std quality ("draft"); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + + +PROC std quality (TEXT CONST quality) : + + IF quality = "nlq" OR quality = "draft" + THEN std quality name := quality; + ELSE errorstop ("unzulaessige Betriebsart") + FI; + +END PROC std quality; + +TEXT PROC std quality : std quality name END PROC std quality; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + factor := 0; + factor was 6 := FALSE; + condensed := FALSE; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 30) * 30; + out (""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + + +. x start : param1 +. y start : param2 +. + open page : + x start := 0; + y start := 0; + rest := 0; + out (""13""); + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page +END SELECT; + +. + close document : + + +. remaining y steps : param1 +. + close page : + IF remaining y steps > 0 THEN out (""12"") FI + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + out subtext (string, from, to) + +. + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN is nlq := TRUE; + near letter quality; + ELIF buffer = "draft" + THEN is nlq := FALSE; + draft quality; + ELSE out (buffer); + FI; + + . near letter quality : + IF factor = 6 + THEN factor was 6 := TRUE; + factor := 4; + ELSE factor was 6 := FALSE; + FI; + IF condensed + THEN out (""27"x"0"") + ELSE out (""27"x"1"") + FI; + + . draft quality : + IF factor was 6 + THEN factor was 6 := FALSE; + factor := 6; + FI; + out (""27"x"0""); + + +(*. x steps to left margin : param1*) +. + carriage return : + rest := 0; + out (""13""); + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps < 0 OR y steps < 0 + THEN stop + ELIF x steps > 0 + THEN x move + ELIF y steps > 0 + THEN y move + FI; + + . x move : + high := (x steps + rest) DIV factor; + rest := (x steps + rest) MOD factor; + out (""27"\"); + out (code (high MOD 256)); + out (code (high DIV 256)); + + . y move : + high := y steps DIV 255; + low := y steps MOD 255; + IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; + IF low > 0 THEN out (""27"J"); out (code (low)) FI; + +. + draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> underline linetype + THEN stop + ELIF x steps > 0 + THEN x draw + FI; + + . x draw : + high := (x steps + rest) DIV 6; + rest := (x steps + rest) MOD 6; + IF high > 0 + THEN low := high MOD 255; + high := high DIV 255; + out (""27"V"); + out (code (low)); + out (""27"*"1""1""0""1""27"V"0""); + FOR low FROM 1 UPTO high + REP out (""27"V"255""27"*"1""1""0""1""27"V"0"") PER; + FI; + + +. modification : param1 +. + on : + IF on string (modification) <> "" + THEN out (on string (modification)) + ELSE stop + FI + +. + off : + IF off string (modification) <> "" + THEN out (off string (modification)) + ELSE stop + FI + + +. font nr : param1 +. + type : + buffer := font string (font nr); + out (buffer); + factor := pitch factor; + IF is nlq THEN near letter quality FI; + + . pitch factor : (* Mikroschritt *) + INT CONST font bits := code (buffer SUB 3); + IF bit (font bits, 1) + THEN condensed := FALSE; 2 (* proportional 1/360 Inch *) + ELIF pos (buffer, ""27"x"1"") <> 0 + THEN condensed := FALSE; 4 (* near letter 1/180 Inch *) + ELIF bit (font bits, 2) + THEN condensed := TRUE; 3 (* condensed 1/240 Inch *) + ELIF bit (font bits, 0) + THEN condensed := FALSE; 4 (* elite 1/180 Inch *) + ELSE condensed := FALSE; 6 (* pica 1/120 Inch *) + FI + +END PROC execute; + + +$end$ +INT VAR reply; DATASPACE VAR ds; FILE VAR file; + +PROC printer: + + disable stop; + continue (server channel); + check error (error message); + ds := nilspace; + REP forget (ds); + execute print; + IF is error AND online THEN put error; clear error; FI; + PER; +END PROC printer; + +PROC execute print: + + LET ack = 0, fetch code = 11, file type = 1003; + enable stop; + ds := nilspace; + call (father, fetch code, ds, reply); + IF reply = ack CAND type (ds) = file type + THEN file := sequential file (input, ds); + print (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); + FI; +END PROC execute print; + +PROC check error(TEXT CONST message): + + IF is error + THEN clear error; rename myself (message); + IF is error THEN end(myself) FI; + pause (9000); end(myself); + FI; +END PROC check error; + +END PACKET printerdriver + + diff --git a/system/printer-24nadel/0.9/src/printer.24.nadel b/system/printer-24nadel/0.9/src/printer.24.nadel new file mode 100644 index 0000000..579f67f --- /dev/null +++ b/system/printer-24nadel/0.9/src/printer.24.nadel @@ -0,0 +1,776 @@ + +(*************************************************************************) +(* Installationsprogramm für Stand : 3. 1.89 *) +(* 24-Nadel Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +PACKET driver inst 24 + + + DEFINES treiber einrichten: + + +LET up = ""3""13""5"", + + generator name = "printer.24.nadel", + + description file name = "beschreibungen24", + module file name = "module24"; + + +INT VAR pr channel, + quality, + paper format number, + service option; +TEXT VAR fonttab name :: "", + driver name :: ""; +TEXT VAR inp; +BOOL VAR was esc; + +treiber einrichten + +PROC treiber einrichten: + + treiber einrichten (0) +END PROC treiber einrichten; + +PROC treiber einrichten (INT CONST service opt): + + ask for print channel; + main menu; + IF installed + THEN generate printer spool + ELSE inform about restart + FI. + + ask for printchannel: + inits; + page; + headline ("Druckerkanal - Einstellung"); + cursor (1, 15); + putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit"); + putline (" 'serverchannel (Kanalnummer)' in der Task """ + + name (myself) + """"); + putline (" verändert werden."); + REP + cursor (1, 10); + put (""5"EUMEL-Kanalnummer des Druckerkanals:"); + get (pr channel); + disable stop; + serverchannel (pr channel); + BOOL VAR no error :: NOT is error; + IF is error + THEN cursor (1, 7); + put error; + putline ("Eingabe korrigiert wiederholen!") + FI; + clear error; + enable stop + UNTIL no error PER. + + inits: + line; + IF single task + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") + FI; + command dialogue (TRUE); + IF name (myself) <> "PRINTER" + THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ + + name (myself) + """ !"); + IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?") + THEN rename myself ("PRINTER") + FI + FI; + INT VAR choice; + service option := service opt. + + single task: (pcb (9) AND 255) = 1. + + main menu: + BOOL VAR installed :: FALSE; + REP + show main menu; + get choice; + treat choice + UNTIL was esc OR installed PER. + + show main menu: + page; + headline("Hauptmenü 24-Nadel-Drucker"); + putline (" 1. Brother"); + putline (" 2. Epson"); + putline (" 3. NEC"); + putline (" 4. OKI"); + putline (" 5. Toshiba"). + + get choice: + cursor (1,24); + put ("CR: Eingabe ESC: Installation abbrechen"); + ask user (5). + + treat choice: + SELECT int (inp) OF + CASE 1: brother menu + CASE 2: epson menu + CASE 3: nec menu + CASE 4: oki menu + CASE 5: toshiba menu + END SELECT. + + + brother menu: + page; + headline ("brother - Menü"); + putline (" 1. M-1724 L"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + brother m1724l inst + FI. + + brother m1724l inst: + putline ("brother M-1724 L"); + line; + putline ("Wählen Sie folgende DIP-Schalter Optionen:"); + putline ("Emulationsmodus IBM Proprinter XL "); + putline ("Automatischer Zeilenvorschub Nein "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.brother"); + generate ("brotherm1724l"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + toshiba menu: + page; + headline ("TOSHIBA - Menü"); + putline (" 1. P 321"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + toshiba p321 inst + FI. + + toshiba p321 inst: + putline ("TOSHIBA P 321"); + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S3-8 S3-7 S3-5 übrige Schalter"); + putline ("OFF OFF *) egal "); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std speed, paper feed"); + show material options("slow, fast"); + show command options ("nlq, draft"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.toshiba.p321"); + generate ("toshp321"); + adjust papersize; + adjust quality; + do ("papersize(21.0,30.48)"); + installed := TRUE; + FI. + + + epson menu: + page; + headline ("Epson - Menü"); + putline (" 1. LQ 850"); + putline (" 2. LQ 1050"); + putline (" 3. LQ 1500"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (3); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : lq850 inst + CASE 2 : lq850 inst + CASE 3 : lq1500 inst + END SELECT + FI. + + lq850 inst: + IF choice = 1 + THEN putline ("Epson LQ 850") + ELSE putline ("Epson LQ 1050") + FI; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8"); + putline ("egal egal egal egal egal egal *1) OFF "); + putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line; + putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8"); + putline ("egal egal *2) OFF OFF"); + putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle "); + putline (" gesetzt werden (Druckerhandbuch)"); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, roman, sansserif"); + show command options ("draft, nlq, roman, sansserif"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.epson.lq850"); + generate ("epsonlq850"); + adjust quality; + adjust papersize; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + lq1500 inst: + putline ("EPSON LQ-1500"); + show control options (""); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + IF all right + THEN get fonttable ("fonttab.epson.lq1500"); + generate ("epsonlq1500"); + adjust quality; + installed := TRUE + FI. + + nec menu: + page; + headline ("NEC - Menü"); + putline (" 1. PINWRITER P5 "); + putline (" 2. PINWRITER P6 "); + putline (" 3. PINWRITER P7 "); + putline (" 4. PINWRITER P6 PLUS"); + putline (" 5. PINWRITER P7 PLUS"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (5); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : necp5p7 inst + CASE 2 : necp6 inst + CASE 3 : necp5p7 inst + CASE 4 : necp6plus inst + CASE 5 : necp6plus inst + END SELECT + FI. + + necp5p7 inst: + IF choice = 1 + THEN putline ("NEC PINWRITER P5") + ELSE putline ("NEC PINWRITER P7") + FI; + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp5p7"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6 inst: + putline ("NEC PINWRITER P6 "); + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp6"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6plus inst: + IF choice = 4 + THEN putline ("NEC PINWRITER P6 PLUS") + ELSE putline ("NEC PINWRITER P7 PLUS") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("CR FUNCTION CR ONLY "); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, courier, souvenir"); + show command options ("draft, nlq, courier, souvenir"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.nec.p6+"); + generate ("necp6+"); + adjust papersize; + adjust quality; + installed := TRUE; + IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI; + FI. + + oki menu: + page; + headline ("OKI - Menü"); + putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel"); + putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel"); + putline (" 3. MICROLINE 393/393C EPSON-kompatibel"); + putline (" 4. MICROLINE 393/393C IBM-kompatibel"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (4); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : oki ml390 inst + CASE 2 : oki ml390 inst + CASE 3 : oki ml393eps inst + CASE 4 : oki ml393ibm inst + END SELECT + FI. + + oki ml390 inst: + IF choice = 1 + THEN putline ("OKI Microline 390") ; + ELSE putline ("OKI Microline 391") ; + FI; + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE EPSON LQ "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki390/391"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + oki ml393eps inst: + putline ("OKI Microline 393 EPSON-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Ceps"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + oki ml393ibm inst: + putline ("OKI Microline 393 IBM-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE ASCII "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Cibm"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + + +generate printer spool: + IF service opt = 0 + THEN forget (generator name, quiet); + forget (driver name, quiet) + FI; + eumel must advertise; + cursor (1, 10); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (2); + putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer"); + putline (" Drucker eingesetzt werden soll."); + line (2); + put ("Generierung beendet, weiter mit 'SV'"); + break (quiet); + do ("spool manager (PROC printer)"). + + inform about restart: + page; + putline ("Es ist kein Druckertreiber installiert worden!"); + line; + putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline ("mit 'treiber einrichten' erneut aufgerufen werden."); + line. + +END PROC treiber einrichten; + +PROC headline (TEXT CONST header): + + cursor (13,1); + putline ("E U M E L - Druckertreiber - Installations - Programm"); + cursor (40 - LENGTH header DIV 2, 2); + put (header); + line (2) +END PROC headline; + +PROC ask user (INT CONST max choice): + + TEXT VAR exit; + inp := ""; + REP + cursor (1,23); + IF inp = "" + THEN put ("Ihre Wahl (Nummer eingeben):") + ELSE put ("FEHLER! Eingabe korrigieren:") + FI; + editget (inp, ""27"", "", exit); + was esc := exit = ""27""; + UNTIL was esc OR ok PER. + + ok: + int (inp) > 0 AND int (inp) <= max choice AND last conversion ok. +END PROC ask user; + +PROC show control options (TEXT CONST options): + + line; + putline ("Steuerprozeduren in der Task """ + name (myself) + """:"); + write ("papersize, std quality"); + IF options <> "" + THEN put (","); + putline (options) + FI +END PROC show control options; + +PROC show material options (TEXT CONST options): + + line; + putline ("Mögliche Materialwerte (#material(""..."")#):"); + putline (options) +END PROC show material options; + +PROC show command options (TEXT CONST options): + + line; + putline ("Mögliche direkte Druckeranweisungen (#""...""#):"); + putline (options) +END PROC show command options; + +PROC ask for quality: + + line (1); + putline ("Standard - Druckqualität:"); + line; + REP out (up); + IF yes ("Draft Quality (schneller, aber nicht so schön)") + THEN quality := 1; LEAVE ask for quality + FI; + out (up); + IF yes ("Near Letter Quality (schöner, aber langsamer)") + THEN quality := 2; LEAVE ask for quality + FI; + PER +END PROC ask for quality; + +PROC adjust quality: + + IF quality = 1 + THEN do ("std quality (""draft"")") + ELSE do ("std quality (""nlq"")") + FI +END PROC adjust quality; + +PROC ask for papersize : +LET up = ""3""13""5""; + + paper format number := paper format ; + + . paper format : + line (1); + putline ("Papierformat:"); + line; + REP out (up); + IF yes ("Endlospapier, 8 Zoll breit") + THEN LEAVE paper format WITH 1 FI; + out (up); + IF yes ("Endlospapier, 13.2 Zoll breit") + THEN LEAVE paper format WITH 2 FI; + out (up); + IF yes ("Einzelblatteinzug, DINA 4") + THEN LEAVE paper format WITH 3 FI; + PER; + 0 +END PROC ask for papersize; + + +PROC adjust papersize: + + SELECT paper format number OF + CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 3 : do("papersize (21.0, 29.7)"); + do ("paper feed (""sheet"")") + END SELECT + +END PROC adjust papersize; + +BOOL PROC all right: + + line (3); + cursor (1,23); + yes ("Soll der ausgewählte Druckertreiber installiert werden") +END PROC all right; + +PROC get fonttable (TEXT CONST name): + + fonttab name := name; + from archive ((description file name & module file name & fonttab name) + - all); + fonttable (fonttab name); + command dialogue (FALSE); + save (fonttab name, /"configurator"); + IF service option = 0 + THEN forget (fonttab name) + FI; + command dialogue (TRUE); +END PROC get fonttable; + +PROC from archive (THESAURUS CONST files): + + IF highest entry (files) > 0 + THEN fetch from archive; + release (archive); + putline ("Archiv abgemeldet !") + FI. + + fetch from archive: + THESAURUS VAR thes :: files; + REP + ask for archive; + reserve archive; + fetch (thes / ALL archive, archive); + thes := thes - all + UNTIL highest entry (thes) = 0 PER. + +ask for archive: + line; + putline ("Bitte Archiv mit den Dateien"); + TEXT VAR buffer; + INT VAR index :: 0; + REP + get (thes, buffer, index); + putline (" " + buffer) + UNTIL index = 0 PER; + putline ("einlegen !"); + line; + putline ("Wenn eingelegt: Taste drücken !"); + inchar (buffer). + +reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop. + +END PROC from archive; + +THESAURUS OP & (TEXT CONST left, right): + THESAURUS VAR result := empty thesaurus; + insert (result, left); + insert (result, right); + result +END OP &; + +THESAURUS OP & (THESAURUS CONST left, TEXT CONST right): + THESAURUS VAR result := left; + insert (result, right); + result +END OP &; + +PROC generate (TEXT CONST name): + + open files; + read description; + build programme; + insert programme; + forget files. + + open files: + line (5); + cursor (1, 20); + putline (""4"Bitte warten !"); + putline (" - Der Treiber wird generiert."); + driver name := "printer." + name + "(generiert)"; + IF exists (driver name) + THEN forget (driver name, quiet) + FI; + FILE VAR des file :: sequential file (modify, description file name), + mod file :: sequential file (modify, module file name), + driver file :: sequential file (output, driver name). + + read description: + to line (des file, 1); + col (des file, 1); + downety (des file, "$" + name + "$"); + IF eof (des file) + THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" + + "Descriptions-File enthalten") + FI; + TEXT VAR description :: "", + record; + BOOL VAR done :: FALSE; + read record (des file, record); + record := subtext (record, col (des file) + LENGTH name + 2); + WHILE NOT eof (des file) AND NOT done REP + treat record + PER. + + treat record: + INT VAR dollar pos :: pos (record, "$"); + IF dollar pos = 0 + THEN description CAT compress (record); + down (des file); + read record (des file, record) + ELSE description CAT compress (subtext (record, 1, dollar pos - 1)); + col (des file, dollar pos); + done := TRUE; + FI. + + build programme: + get module name; + WHILE still modules REP + find module; + transfer module; + get module name + PER. + + get module name: + INT VAR semicol pos :: pos (description, ";"); + TEXT VAR module name; + IF semicol pos > 0 + THEN module name := subtext (description, 1, semicol pos - 1); + description := subtext (description, semicol pos + 1) + ELSE module name := description; + description := "" + FI. + + still modules: + module name <> "" OR description <> "". + + find module: + to line (mod file, 1); + col (mod file, 1); + downety (mod file, "$" + module name + "$"); + IF eof (mod file) + THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" + + "Modul-File enthalten") + FI. + + transfer module: + done := FALSE; + read record (mod file, record); + record := subtext (record, col (mod file) + LENGTH module name + 2); + WHILE NOT eof (mod file) AND NOT done REP + transfer record + PER. + + transfer record: + dollar pos := pos (record, "$"); + IF dollar pos = 0 + THEN write (driver file, compress (record)); + line (driver file); + down (mod file); + read record (mod file, record) + ELSE write (driver file, compress (subtext (record, 1, + dollar pos - 1))); + col (mod file, dollar pos); + done := TRUE; + cout (line no (mod file)) + FI. + + insert programme: + IF online + THEN putline (" - Der Treiber wird insertiert.") + FI; + check off; + insert (driver name). + + forget files: + IF service option = 0 + THEN forget (description file name, quiet); + forget (module file name, quiet) + FI . +END PROC generate; + +END PACKET driver inst 24 + diff --git a/system/printer-24nadel/schulis-mathe-1.0/doc/readme b/system/printer-24nadel/schulis-mathe-1.0/doc/readme new file mode 100644 index 0000000..d526aa3 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/doc/readme @@ -0,0 +1,320 @@ +#type("nlq10")##limit(18.0)##start(1.5,1.0)# +#head# +Treiber-Installations-Programm #right#Seite % +für 24-Nadel-Matrixdrucker #right#23.12.1988 + + +#end# +#on("u")#Dokumentation zum Treiber-Installations-Programm für 24-Nadel- +Matrixdrucker#off("u")# + +#on("u")#Inhalt:#off("u")# + +1. Installations- und Gebrauchsanleitung +2. Druckertreiber-Auswahl +3. Steuerungsmöglichkeiten und Spezialfeatures +4. Weitere Hinweise + + +#on("b")#1. Installations- und Gebrauchsanleitung#off("b")# + +#on("u")#Einrichten#off("u")# +So wird das Treiber-Installationsprogramm eingerichtet: + + SV drücken + + nach 'gib supervisor kommando:' + + begin("PRINTER","SYSUR") + + in der Task "PRINTER" (nach 'gib kommando'): + + archive ("std.printer") + fetch ("printer.24.nadel",archive) + check off + insert ("printer.24.nadel") + +Das Programm wird dann insertiert. + +#on("u")#Druckerkanal#off("u")# +Hiernach wird die Kanalnummer des Druckers erfragt. Wenn der Drucker +über Parallelschnittstelle betrieben wird, ist die Kanalnummer +meistens 15. + +#on("u")#Menüsystem#off("u")# +Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern. +Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste +der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier +den passenden Typ aus! +Das Installationsprogramm zeigt nun einige Informationen zu dem ange +wählten Drucker. Besonders zu beachten sind hierbei #on("u")#Angaben zur Konfi +guration des Druckers#off("u")# (z.B. DIP-Schalter). Der Drucker muß unbedingt +wie angegeben konfiguriert werden, wenn er mit dem ausgewählten Trei +ber betrieben werden soll. + +Hinweise zu Konfigurationsangaben: +1. Die Angabe 'egal' bedeutet, daß die Einstellung für die Funktion + des Treibers keine Bedeutung hat. Dennoch solte der Anwender darauf + achten, welche Funktion die Schalter haben (Druckerhandbuch!). So + ist es zum Beispiel immer empfehlenswert, den Papierende-Sensor zu + aktivieren, damit der Drucker nach Papierende nicht auf der Walze + weiterdruckt. +2. Die Konfigurationsangaben beziehen sich immer auf genau den ausge + wählten Druckertyp. Wenn Sie den Treiber mit einem anderen Drucker + als den ausgewählten verwenden, dann beachten Sie folgende Regeln + für die Konfiguration: + - Der Drucker muß auf eine passende Emulation konfiguriert werden. + - Der Drucker darf bei einem Carriage Return (Code 13) keinen Zei + lenvorschub durchführen. + - Der Drucker darf die Perforation #on("u")#nicht#off("u")# automatisch überspringen. + + - Auf Seitenlängen und internationale Zeichensätze müssen Sie nicht + achten. + +(Hinweise zur Auswahl des richtigen Treibers gibt Abschnitt 2) + +Nach den Konfigurationsangaben werden Steuerungsmöglichkeiten des +ausgewählten Treibers angezeigt. (Siehe hierzu Abschnitt 3) + +Falls der Treiber bestimmte grundsätzliche Betriebsmöglichkeiten er +laubt (z.B. DRAFT/NLQ, Einzelblatteinzug), werden Sie danach gefragt, +welche Möglichkeit standardmäßig gewählt werden soll. diese Vorein +stellungen können nachträglich in der Task "PRINTER" mit den entspre +chenden Steuerprozeduren neu gesetzt werden. Außerdem können bestimmte +Einstellungen noch für jedes einzelne Dokument (d.h. für jede Druck +datei) gewählt ('material'-Anweisung) oder sogar innerhalb eines Doku +ments verändert werden (direkte Druckeranweisung \#"..."\#). +Über die Steuerungsmöglichkeiten informiert Abschnitt 3 ausführlicher. + + +#on("b")#2. Druckertreiber-Auswahl#off("b")# + +#on("u")#Verwendung nicht im Menü enthaltener Drucker#off("u")# +Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, soll +ten Sie zunächst versuchen, ob ein Treiber für einen anderen Drucker +des gleichen Herstellers mit Ihrem Drucker korrekt arbeitet. +Falls dies nicht funktioniert oder der Hersteller überhaupt nicht im +Menü erscheint, müssen Sie herausfinden (Druckerhandbuch, -händler!), +welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist. +(Viele Drucker verfügen über EPSON LQ-1000 oder IBM Grafikdrucker bzw. +Proprinter-Eumulationen.) +Eine der beiden Anpassungen 'EPSON LQ-1050' oder 'OKI ML-393 +IBM-kompatibel' müßte immer einen (Minimal-) Betrieb ermöglichen (wobei die +Verwendung der Proportionalschrift bzw. der doppelt hohen Schriften u. U. +nicht funktioniert). + + +#on("b")#3. Steuerungsmöglichkeiten und Spezialfeatures#off("b")# + +Einige Treiber bieten bestimmte Einstellungsmöglichkeiten (z.B. +DRAFT/NLQ) und/oder Spezialfeatures (z.B. Farbdruck). +Die Einstellungen können über +- Steuerprozeduren +- Materialanweisungen bzw. +- direkte Druckeranweisungen +vorgenommen werden. + +#on("u")#Steuerprozeduren#off("u")# +setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten +sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER") +aufgerufen werden. #on("b")#Gültig werden die Änderungen erst, wenn danach in +der Druckspooltask das Kommando 'start' gegeben wird!#off("b")# + +PROC papersize (REAL CONST breite, länge) + Dient zur Einstellung der Größe der physikalisch beschreibbaren + Fläche. + Beispiel: papersize (20.32, 30.48) + (Standardeinstellung für Endlospapier 8 Zoll breit und + 12 Zoll lang) + +PROC papersize + Informationsprozedur + +PROC top margin (REAL CONST margin) + Falls der Drucker es nicht erlaubt, direkt am Blattanfang zu druk + ken (zum Beispiel wegen eines Einzelblatteinzugs), muß mit dieser + Prozedur die Länge des oberen Randes, den der Drucker nicht be + drucken kann, in cm angegeben werden. + Beispiel: top margin (2.0) + (Teilt dem Druckertreiber mit, daß die ersten 2 cm + nicht bedruckbar sind.) + +REAL PROC top margin + Informationsprozedur + +PROC std speed (TEXT CONST speed) + Parameter: slow, fast + Wahl zwischen Positionierung in Mikroschritten (slow) oder in + Blanks (fast). + Beispiel: std speed ("slow") + +TEXR PROC std speed + Informationsprozedur + +PROC std quality (TEXT CONST quality) + übliche Parameter: draft, nlq + Wahl zwischen Datenverarbeitungs-Qualität und Schönschrift- + Qualität + Beispiel: std quality ("draft") + +TEXT PROC std quality + Informationsprozedur + +PROC std typeface (TEXT CONST typeface) + übliche Parameter: roman, sansserif, courier + Wahl zwischen verschiedenen NLQ-Schriftarten (nur sichtbar im + NLQ-Modus, das heißt 'std typeface' schaltet nicht auf NLQ). + Beispiel: std typeface ("roman") + +TEXT PROC std typeface + Informationsprozedur + +PROC paper feed (TEXT CONST name) + übliche Parameter: tractor, sheet, schacht1, schacht2 + Wählt Endlospapier oder Einzelblatteinzug und ggf. Schachtnummer. + Beispiel: paper feed ("sheet") + +TEXT PROC paper feed + Informationsprozedur + + +#on("u")#Materialanweisungen \#material("...")\##off("u")# +müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und +setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben +für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge +stellten Standardwerten. Diese werden durch die Materialanweisung aber +nicht geändert.) + +Beispiel: \#material("nlq")\# + sorgt bei entsprechendem Treiber dafür, daß das gesamte + Dokument in Schönschrift-Qualität ausgedruckt wird, egal + wie 'std quality' eingestellt ist. + +#on("b")#Es darf in einer Datei nur eine Materialanweisung stehen!#off("b")# Sollen meh +rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung +erscheinen. Beispiel: \#material("sheet;draft")\# + + +#on("u")#direkte Druckeranweisungen \#"..."\##off("u")# +gelten ab der Position, an der sie in der Datei auftreten. Sie haben +(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und +Materialeinstellungen. + +Beispiel: \#"draft"\# + schaltet (bei entsprechendem Treiber) auf Datenverar + beitungs-Qualität, egal welche Standardeinstellung vorliegt + und welche Materialanweisung gegeben wurde. + +#on("b")#In einer Druckeranweisung darf nur eine Einstellung vorgenommen +werden.#off("b")# Also: \#"nlq"\#\#"sansserif"\# + + +#on("u")#Wichtig#off("u")# +- Achten Sie bei Materialanweisungen und direkten Druckeranweisungen + besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben + berücksichtigt! Also: \#"nlq"\# und keinesfalls \#"NLQ"\#!!! +- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und + nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann + daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse + erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen + Reihenfolge an den Drucker sendet, als er in der Datei steht, die + mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B. + für beide Spalten) unerwünscht erhalten bleibt. + + +#on("u")#Tabelle#off("u")# +Die Tabelle soll einen Anhaltspunkt dafür geben, wie welche Einstel +lungen erfolgen können. + +#type("17")# + Steuerprozeduren Materialanweisungen direkte Druckeranweisungen + +#on("u")# #off("u")# + +Positionierung std speed slow, fast ------ + slow, fast + +Qualität std quality z.B. draft, nlq z.B. draft, nlq + z.B. draft, nlq + +Schriftart std typeface z.B. roman, z.B. roman, +(nur bei NLQ) z.B. roman, sansserif, courier sansserif, courier + sansserif, courier + +Einzelblatt- paper feed z.B. schacht1, z.B. schacht1, +einzug z.B. tractor, schacht2 schacht2 + sheet, + schacht1, schacht2 + +Farbdruck ------ ------ z.B. schwarz, + rot, blau, + violett, gelb + orange, grün + + + +#type("nlq10")##on("b")#4. Weitere Hinweise#off("b")# + +#on("u")#Zeichensatzänderungen gegenüber früheren Versionen#off("u")# +In den Fonttabellen früherer Druckertreiber-Versionen wurden oberhalb +des Codes 127 einige internationale Zeichen zur Verfügung gestellt +(und zwar in Anlehnung an den Agfa-Laserdrucker-Zeichensatz). +Bei den Treibern der vorliegenden Version gilt folgendes: +- Wie bisher wird der volle im Benutzerhandbuch festgelegte EUMEL- + Zeichensatz (sofern möglich) unterstützt. +- Der Code 252 liefert das Paragraphzeichen. +- Alle übrigen (vom EUMEL-Zeichensatz nicht definierten) Zeichencodes + oberhalb 127 liefern, sofern möglich, die entsprechenden Zeichen des + IBM-Grafikzeichensatzes. + + +#on("u")#Hinweis zu Proportionalschriften#off("u")# +Bei Proportionalschriften kann die Modifikation \#on("i")\# zu Problemen +führen (z.B. beim Blocksatz), wenn die kursiven Zeichen andere +Proportionalbreiten haben. + +#on("u")#Hinweis zur Modifikation on/off("b") bzw. on/off("r")#off("u")# +Die meisten 24-Nadel Drucker verfügen sowohl über einen horizontalen als +auch über einen vertikalen Schattendruck. Diese beiden Druckarten können +mit der Modifikation on("b") (bold) bzw. on("r") (eigentlich für reverse +gedacht) eingeschaltet werden. + +#on("u")#Hinweis zur Benutzung von Einzelblatteinzügen#off("u")# +Bei der Benutzung von Einzelblatteinzügen müssen folgende Einstel +lungen vorgenommen werden (vgl. auch Abschnitt 3!): + + Am Drucker: +1. Sie müssen Ihren Drucker auf die Option Einzelblatteinzug + schalten (siehe Druckerhandbuch!). + + In der Druckspooltask (meist 'PRINTER'): +2. Falls der Druckertreiber die Steuerprozedur 'paper feed' zur Verfü + gung stellt, müssen Sie mit 'paperfeed ("sheet")' oder (für + 2-Schacht-Einzüge) mit 'paperfeed ("schacht1")' bzw. 'paperfeed + ("schacht2")' den Druckertreiber auf Einzelblatteinzug umschalten. +3. Falls Sie eine andere Papierlänge als 12 Zoll (=30.48 cm) verwen + den, müssen Sie die neuen Papiermaße mit 'papersize' in cm einstel + len. + Beispiel: papersize (21.0, 29.7) + (für DIN A4-Blätter) +4. Falls der Drucker mit dem Einzelblatteinzug nicht direkt am Blatt + anfang drucken kann, sondern ein gewisser oberer Rand bleibt, muß + mit 'top margin' die Länge des nicht bedruckbaren Randes in cm dem + Druckertreiber mitgeteilt werden. + Beispiel: top margin (1.5) + (Wie groß der obere Rand ist, kann festgestellt werden, indem eine + Datei mit \#start(0.0,0.0)\# ausgedruckt wird.) + + Wurde mit 'top margin' dem Treiber die Größe der nicht bedruckbaren + Fläche mitgeteilt, so ist darauf zu achten, daß in den Druckdateien + ein genügend großer y-Wert für die Startposition eingestellt wird + ('start'-Anweisung). Andernfalls kommt es bei der Ausgabe in der + ersten Zeile zu Überschreibungen. + + +#on("b")#5. Die Änderungen, die Sie in der Druckspooltask vorgenommen haben + werden erst wirksam, wenn das Spool-Kommando 'start' gegeben wird.#off("b")# + + + + diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen24 b/system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen24 new file mode 100644 index 0000000..e3d2fa9 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen24 @@ -0,0 +1,62 @@ + +(*************************************************************************) +(* Stand : 3. 1.89 *) +(* Beschreibungen-Datei für 24-Nadel-Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +$necp5p7$ +begin;headnecp5p7;declarations;feed; +open;opendoch;opendocp5p7;openpagep5-7;close;closepage; +execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end + +$necp6$ +begin;headnecp6;declarations;feed; +open;opendoch;opendocp6;openpagep5-7;close;closepage; +execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end + +$necp6+$ +begin;headnecp6+;declarations;speed;topmargin;typefacep6+;feed; +open;opendoch;initspeed;opendocp6+;openpage;close;closepage; +execute;cmdp6+;crs;move;stdmove;onoff;typep6+;end + +$epsonlq850$ +begin;headlq850;declarations;speed;topmargin;typefacelq850;feed; +open;opendoch;initspeed;opendoclq850;openpage;close;closepage; +execute;cmdlq850;crs;move;stdmove;onoff;typeplq850;end + +$epsonlq1500$ +printerlq1500;end + +$oki390/391$ +begin;headoki390/391;declarations;speed;topmargin;typefaceoki;feedschacht; +open;opendoch;initspeed;opendocokieps;openpage;close;closepage; +execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end + +$oki393/393Ceps$ +begin;headoki393/393Ceps;declarations;speed;topmargin;typefaceoki;feedschacht; +open;opendoch;initspeed;opendocokieps;openpage;close;closepage; +execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end + +$oki393/393Cibm$ +begin;headoki393/393Cibm;declarations;speed;topmargin;typefaceoki;feedschacht; +open;opendoch;initspeed;opendocokiibm;openpage;close;closepage; +execute;cmdoki;crs;move;stdmove;onoff;typeokiibm;end + +$toshp321$ +begin;headtoshp321;declarations;speed;feed; +open;opendochtosh;initspeed;opendoctosh;openpagetosh;close;closepagetosh; +execute;cmdtosh;crs;move;stdmove;onoff;typetosh;end + +$starnb24$ +begin;headstarnb24;declarations;speed;topmargin;typefacestar;feedschacht; +open;opendoch;initspeed;opendocstar;openpage;close;closepage; +execute;cmdstar;crs;move;stdmove;onoff;typestar;end + +$brotherm1724l$ +begin;headbrotherm1724l;declarations;speed;topmargin;feed; +open;opendoch;initspeed;opendocbrother;openpage;close;closepage; +execute;cmdtosh;crs;move;stdmove;onoff;typebrother;end + + + diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brother b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brother Binary files differnew file mode 100644 index 0000000..2251e18 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brother diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500 Binary files differnew file mode 100644 index 0000000..1b4c6a6 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500 diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850 Binary files differnew file mode 100644 index 0000000..7a6d2f0 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850 diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5 Binary files differnew file mode 100644 index 0000000..9910da6 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5 diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.new b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.new Binary files differnew file mode 100644 index 0000000..9804bd5 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.new diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+ Binary files differnew file mode 100644 index 0000000..b209e81 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+ diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.oki b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.oki Binary files differnew file mode 100644 index 0000000..2251e18 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.oki diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321 Binary files differnew file mode 100644 index 0000000..452afca --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321 diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/inserter b/system/printer-24nadel/schulis-mathe-1.0/src/inserter new file mode 100644 index 0000000..1a165e0 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/inserter @@ -0,0 +1,793 @@ + +(*************************************************************************) +(* Installationsprogramm für Stand : 3. 1.89 *) +(* 24-Nadel Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +PACKET driver inst 24 + + + DEFINES treiber einrichten: + + +LET up = ""3""13""5"", + + generator name = "printer.24.nadel", + + description file name = "beschreibungen24", + module file name = "module24"; + + +INT VAR pr channel, + quality, + paper format number, + service option; +TEXT VAR fonttab name :: "", + driver name :: ""; +TEXT VAR inp; +BOOL VAR was esc; + +treiber einrichten + +PROC treiber einrichten: + + treiber einrichten (0) +END PROC treiber einrichten; + +PROC treiber einrichten (INT CONST service opt): + + ask for print channel; + main menu; + IF installed + THEN generate printer spool + ELSE inform about restart + FI. + + ask for printchannel: + inits; + page; + headline ("Druckerkanal - Einstellung"); + cursor (1, 15); + putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit"); + putline (" 'serverchannel (Kanalnummer)' in der Task """ + + name (myself) + """"); + putline (" verändert werden."); + REP + cursor (1, 10); + put (""5"EUMEL-Kanalnummer des Druckerkanals:"); + get (pr channel); + disable stop; + serverchannel (pr channel); + BOOL VAR no error :: NOT is error; + clear error; + no error := no error CAND + (pr channel <> channel (myself)) CAND + (pr channel > 1) CAND + (pr channel < 17); + + IF NOT no error + THEN cursor (1, 7); + put error; + putline ("Eingabe korrigiert wiederholen!") + FI; + enable stop + UNTIL no error PER; + IF exists task ("canal " + text (pr channel)) + THEN end (/ ("canal " + text (pr channel))); + FI; + +. inits: + line; + IF single task + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") + FI; + command dialogue (TRUE); + IF name (myself) <> "PRINTER" + THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ + + name (myself) + """ !"); + IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?") + THEN rename myself ("PRINTER") + FI + FI; + INT VAR choice; + service option := service opt. + + single task: (pcb (9) AND 255) = 1. + + main menu: + BOOL VAR installed :: FALSE; + REP + show main menu; + get choice; + treat choice + UNTIL was esc OR installed PER. + + show main menu: + page; + headline("Hauptmenü 24-Nadel-Drucker"); + putline (" 1. Brother"); + putline (" 2. Epson"); + putline (" 3. NEC"); + putline (" 4. OKI"); + putline (" 5. Toshiba"). + + get choice: + cursor (1,24); + put ("CR: Eingabe ESC: Installation abbrechen"); + ask user (5). + + treat choice: + SELECT int (inp) OF + CASE 1: brother menu + CASE 2: epson menu + CASE 3: nec menu + CASE 4: oki menu + CASE 5: toshiba menu + END SELECT. + + + brother menu: + page; + headline ("brother - Menü"); + putline (" 1. M-1724 L"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + brother m1724l inst + FI. + + brother m1724l inst: + putline ("brother M-1724 L"); + line; + putline ("Wählen Sie folgende DIP-Schalter Optionen:"); + putline ("Emulationsmodus IBM Proprinter XL "); + putline ("Automatischer Zeilenvorschub Nein "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.brother"); + generate ("brotherm1724l"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + toshiba menu: + page; + headline ("TOSHIBA - Menü"); + putline (" 1. P 321"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + toshiba p321 inst + FI. + + toshiba p321 inst: + putline ("TOSHIBA P 321"); + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S3-8 S3-7 S3-5 übrige Schalter"); + putline ("OFF OFF *) egal "); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std speed, paper feed"); + show material options("slow, fast"); + show command options ("nlq, draft"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.toshiba.p321"); + generate ("toshp321"); + adjust papersize; + adjust quality; + do ("papersize(21.0,30.48)"); + installed := TRUE; + FI. + + + epson menu: + page; + headline ("Epson - Menü"); + putline (" 1. LQ 850"); + putline (" 2. LQ 1050"); + putline (" 3. LQ 1500"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (3); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : lq850 inst + CASE 2 : lq850 inst + CASE 3 : lq1500 inst + END SELECT + FI. + + lq850 inst: + IF choice = 1 + THEN putline ("Epson LQ 850") + ELSE putline ("Epson LQ 1050") + FI; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8"); + putline ("egal egal egal egal egal egal *1) OFF "); + putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line; + putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8"); + putline ("egal egal *2) OFF OFF"); + putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle "); + putline (" gesetzt werden (Druckerhandbuch)"); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, roman, sansserif"); + show command options ("draft, nlq, roman, sansserif"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.epson.lq850"); + generate ("epsonlq850"); + adjust quality; + adjust papersize; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + lq1500 inst: + putline ("EPSON LQ-1500"); + show control options (""); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + IF all right + THEN get fonttable ("fonttab.epson.lq1500"); + generate ("epsonlq1500"); + adjust quality; + installed := TRUE + FI. + + nec menu: + page; + headline ("NEC - Menü"); + putline (" 1. PINWRITER P5 "); + putline (" 2. PINWRITER P6 "); + putline (" 3. PINWRITER P7 "); + putline (" 4. PINWRITER P6 PLUS"); + putline (" 5. PINWRITER P7 PLUS"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (5); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : necp5p7 inst + CASE 2 : necp6 inst + CASE 3 : necp5p7 inst + CASE 4 : necp6plus inst + CASE 5 : necp6plus inst + END SELECT + FI. + + necp5p7 inst: + IF choice = 1 + THEN putline ("NEC PINWRITER P5") + ELSE putline ("NEC PINWRITER P7") + FI; + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp5p7"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6 inst: + putline ("NEC PINWRITER P6 "); + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp6"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6plus inst: + IF choice = 4 + THEN putline ("NEC PINWRITER P6 PLUS") + ELSE putline ("NEC PINWRITER P7 PLUS") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("CR FUNCTION CR ONLY "); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, courier, souvenir"); + show command options ("draft, nlq, courier, souvenir"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.nec.p6+"); + generate ("necp6+"); + adjust papersize; + adjust quality; + installed := TRUE; + IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI; + FI. + + oki menu: + page; + headline ("OKI - Menü"); + putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel"); + putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel"); + putline (" 3. MICROLINE 393/393C EPSON-kompatibel"); + putline (" 4. MICROLINE 393/393C IBM-kompatibel"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (4); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : oki ml390 inst + CASE 2 : oki ml390 inst + CASE 3 : oki ml393eps inst + CASE 4 : oki ml393ibm inst + END SELECT + FI. + + oki ml390 inst: + IF choice = 1 + THEN putline ("OKI Microline 390") ; + ELSE putline ("OKI Microline 391") ; + FI; + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE EPSON LQ "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki390/391"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + oki ml393eps inst: + putline ("OKI Microline 393 EPSON-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Ceps"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + oki ml393ibm inst: + putline ("OKI Microline 393 IBM-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE ASCII "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Cibm"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + + +generate printer spool: + IF service opt = 0 + THEN forget (generator name, quiet); + forget (driver name, quiet) + FI; + eumel must advertise; + cursor (1, 10); +(* putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (2); + putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer"); + putline (" Drucker eingesetzt werden soll."); + line (2); +*) +(* put ("Generierung beendet, weiter mit 'SV'"); + break (quiet); +*) + putline (" Generierung beendet."); + putline (" Weiter: Bitte Taste drücken"); + WHILE incharety <> "" REP ENDREP; + REP UNTIL incharety <> "" ENDREP; + unlink; + do ("spool manager (PROC printer)"). + + inform about restart: + page; + putline ("Es ist kein Druckertreiber installiert worden!"); + line; + putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline ("mit 'treiber einrichten' erneut aufgerufen werden."); + line; + pause(50); + unlink. + +END PROC treiber einrichten; + +PROC headline (TEXT CONST header): + + cursor (13,1); + putline ("E U M E L - Druckertreiber - Installations - Programm"); + cursor (40 - LENGTH header DIV 2, 2); + put (header); + line (2) +END PROC headline; + +PROC ask user (INT CONST max choice): + + TEXT VAR exit; + inp := ""; + REP + cursor (1,23); + IF inp = "" + THEN put ("Ihre Wahl (Nummer eingeben):") + ELSE put ("FEHLER! Eingabe korrigieren:") + FI; + editget (inp, ""27"", "", exit); + was esc := exit = ""27""; + UNTIL was esc OR ok PER. + + ok: + int (inp) > 0 AND int (inp) <= max choice AND last conversion ok. +END PROC ask user; + +PROC show control options (TEXT CONST options): + + line; + putline ("Steuerprozeduren in der Task """ + name (myself) + """:"); + write ("papersize, std quality"); + IF options <> "" + THEN put (","); + putline (options) + FI +END PROC show control options; + +PROC show material options (TEXT CONST options): + + line; + putline ("Mögliche Materialwerte (#material(""..."")#):"); + putline (options) +END PROC show material options; + +PROC show command options (TEXT CONST options): + + line; + putline ("Mögliche direkte Druckeranweisungen (#""...""#):"); + putline (options) +END PROC show command options; + +PROC ask for quality: + + line (1); + putline ("Standard - Druckqualität:"); + line; + REP out (up); + IF yes ("Draft Quality (schneller, aber nicht so schön)") + THEN quality := 1; LEAVE ask for quality + FI; + out (up); + IF yes ("Near Letter Quality (schöner, aber langsamer)") + THEN quality := 2; LEAVE ask for quality + FI; + PER +END PROC ask for quality; + +PROC adjust quality: + + IF quality = 1 + THEN do ("std quality (""draft"")") + ELSE do ("std quality (""nlq"")") + FI +END PROC adjust quality; + +PROC ask for papersize : +LET up = ""3""13""5""; + + paper format number := paper format ; + + . paper format : + line (1); + putline ("Papierformat:"); + line; + REP out (up); + IF yes ("Endlospapier, 8 Zoll breit") + THEN LEAVE paper format WITH 1 FI; + out (up); + IF yes ("Endlospapier, 13.2 Zoll breit") + THEN LEAVE paper format WITH 2 FI; + out (up); + IF yes ("Einzelblatteinzug, DINA 4") + THEN LEAVE paper format WITH 3 FI; + PER; + 0 +END PROC ask for papersize; + + +PROC adjust papersize: + + SELECT paper format number OF + CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 3 : do("papersize (21.0, 29.7)"); + do ("paper feed (""sheet"")") + END SELECT + +END PROC adjust papersize; + +BOOL PROC all right: + + line (3); + cursor (1,23); + yes ("Soll der ausgewählte Druckertreiber installiert werden") +END PROC all right; + +PROC get fonttable (TEXT CONST name): + + fonttab name := name; + from archive ((description file name & module file name & fonttab name) + - all); + fonttable (fonttab name); + command dialogue (FALSE); + save (fonttab name, /"configurator"); + IF service option = 0 + THEN forget (fonttab name) + FI; + command dialogue (TRUE); +END PROC get fonttable; + +PROC from archive (THESAURUS CONST files): + + IF highest entry (files) > 0 + THEN fetch from archive; + release (archive); + putline ("Archiv abgemeldet !") + FI. + + fetch from archive: + THESAURUS VAR thes :: files; + REP + ask for archive; + reserve archive; + fetch (thes / ALL archive, archive); + thes := thes - all + UNTIL highest entry (thes) = 0 PER. + +ask for archive: + TEXT VAR buffer; +(*line; + putline ("Bitte Archiv mit den Dateien"); + INT VAR index :: 0; + REP + get (thes, buffer, index); + putline (" " + buffer) + UNTIL index = 0 PER; + putline ("einlegen !"); + line; + putline ("Wenn eingelegt: Taste drücken !"); + inchar (buffer)*). + +reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop. + +END PROC from archive; + +THESAURUS OP & (TEXT CONST left, right): + THESAURUS VAR result := empty thesaurus; + insert (result, left); + insert (result, right); + result +END OP &; + +THESAURUS OP & (THESAURUS CONST left, TEXT CONST right): + THESAURUS VAR result := left; + insert (result, right); + result +END OP &; + +PROC generate (TEXT CONST name): + + open files; + read description; + build programme; + insert programme; + forget files. + + open files: + line (5); + cursor (1, 20); + putline (""4"Bitte warten !"); + putline (" - Der Treiber wird generiert."); + driver name := "printer." + name + "(generiert)"; + IF exists (driver name) + THEN forget (driver name, quiet) + FI; + FILE VAR des file :: sequential file (modify, description file name), + mod file :: sequential file (modify, module file name), + driver file :: sequential file (output, driver name). + + read description: + to line (des file, 1); + col (des file, 1); + downety (des file, "$" + name + "$"); + IF eof (des file) + THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" + + "Descriptions-File enthalten") + FI; + TEXT VAR description :: "", + record; + BOOL VAR done :: FALSE; + read record (des file, record); + record := subtext (record, col (des file) + LENGTH name + 2); + WHILE NOT eof (des file) AND NOT done REP + treat record + PER. + + treat record: + INT VAR dollar pos :: pos (record, "$"); + IF dollar pos = 0 + THEN description CAT compress (record); + down (des file); + read record (des file, record) + ELSE description CAT compress (subtext (record, 1, dollar pos - 1)); + col (des file, dollar pos); + done := TRUE; + FI. + + build programme: + get module name; + WHILE still modules REP + find module; + transfer module; + get module name + PER. + + get module name: + INT VAR semicol pos :: pos (description, ";"); + TEXT VAR module name; + IF semicol pos > 0 + THEN module name := subtext (description, 1, semicol pos - 1); + description := subtext (description, semicol pos + 1) + ELSE module name := description; + description := "" + FI. + + still modules: + module name <> "" OR description <> "". + + find module: + to line (mod file, 1); + col (mod file, 1); + downety (mod file, "$" + module name + "$"); + IF eof (mod file) + THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" + + "Modul-File enthalten") + FI. + + transfer module: + done := FALSE; + read record (mod file, record); + record := subtext (record, col (mod file) + LENGTH module name + 2); + WHILE NOT eof (mod file) AND NOT done REP + transfer record + PER. + + transfer record: + dollar pos := pos (record, "$"); + IF dollar pos = 0 + THEN write (driver file, compress (record)); + line (driver file); + down (mod file); + read record (mod file, record) + ELSE write (driver file, compress (subtext (record, 1, + dollar pos - 1))); + col (mod file, dollar pos); + done := TRUE; + cout (line no (mod file)) + FI. + + insert programme: + IF online + THEN putline (" - Der Treiber wird insertiert.") + FI; + check off; + insert (driver name). + + forget files: + IF service option = 0 + THEN forget (description file name, quiet); + forget (module file name, quiet) + FI . +END PROC generate; + +END PACKET driver inst 24 + diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/module24 b/system/printer-24nadel/schulis-mathe-1.0/src/module24 new file mode 100644 index 0000000..a4957c2 --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/module24 @@ -0,0 +1,1554 @@ + +(*************************************************************************) +(* Stand : 03. 1.89 *) +(* Module-Datei für 24-Nadel-Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +$begin$ +PACKET printer driver + + DEFINES printer, + open, + close, + execute, + paper size, + std quality, + +$headnecp6$ paper feed: +(* Treiber fuer NEC P6, automatisch generiert *) +LET underline linetype = 1; +INT VAR factor 1, factor 2, draft factor 1, draft factor 2; + +$headnecp5p7$ paper feed: +(* Treiber fuer NEC P5, P7 , automatisch generiert *) +LET underline linetype = 1; +INT VAR factor 1, factor 2, draft factor 1, draft factor 2; + +$headnecp6+$ std speed, + top margin, + paper feed, + std typeface: +(* Treiber für NEC P6 plus/P7 plus ,automatisch generiert *) + + +$headlq850$ std speed, + top margin, + paper feed, + std typeface: +(* Treiber für EPSON LQ-850/1050 ,automatisch generiert *) + +$headbrotherm1724l$ + std speed, + top margin, + paper feed: +INT VAR vertical factor := 1; +(* Treiber für BROTHER M-1724L in IBM-Emulation, automatisch generiert *) + +$headoki390/391$ + std speed, + top margin, + paper feed, + std typeface: +INT VAR vertical factor := 1; +(* Treiber für OKI MIKROLINE 390/391 ,automatisch generiert *) + +$headoki393/393Ceps$ + std speed, + top margin, + paper feed, + std typeface: +INT VAR vertical factor := 1; +(* Treiber für OKI MIKROLINE 393/393C EPSON-kompatibel, automatisch generiert *) + +$headoki393/393Cibm$ + std speed, + top margin, + paper feed, + std typeface: +INT VAR vertical factor := 1; +(* Treiber für OKI MIKROLINE 393/393C IBM-kompatibel, automatisch generiert *) + +$headtoshp321$ std speed, + paper feed: +(* Treiber für TOSHIBA P321, automatisch generiert *) + +$headstarnb24$ + std speed, + top margin, + paper feed, + std typeface: +(* Treiber für STAR NB 24-10/15 in Standard Betriebsart automatisch generiert *) + +$declarations$ +INT VAR font nr, font bits, modification bits, + blankbreite, x rest, high, low, steps; +REAL VAR x size, y size; +TEXT VAR buffer :: ""; +BOOL VAR is nlq ; +TEXT VAR font text :: ""; +TEXT VAR std quality name :: "draft"; + +. is pica : font bits = 0 +. is elite : font bits = 1 +.; + + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; +END PROC paper size; + +papersize (20.32, 30.48); + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); +END PROC paper size; + + + +PROC std quality (TEXT CONST quality) : + + IF quality = "nlq" OR quality = "draft" + THEN std quality name := quality + ELSE errorstop ("unzulässige Qualitätsbezeichnung") + FI +END PROC std quality; + +TEXT PROC std quality : + + std quality name +END PROC std quality; + + +$topmargin$ +REAL VAR y margin := 0.0 ; + +PROC top margin (REAL CONST margin): + + y margin := margin +END PROC top margin; + +REAL PROC top margin: + + y margin +END PROC top margin; + + +$speed$ +BOOL VAR is slow :: TRUE; +TEXT VAR std speed name :: "slow"; + +PROC std speed (TEXT CONST speed) : + + IF speed = "fast" OR speed = "slow" + THEN std speed name := speed + ELSE errorstop ("unzulässige Geschwindigkeit") + FI +END PROC std speed; + +TEXT PROC std speed : + +std speed name +END PROC std speed; + + +$typefacelq850$ +TEXT VAR act typeface name :: ""; +TEXT VAR std typeface name :: ""; + +. is roman: + act typeface name = "roman". +. is sansserif: + act typeface name = "sansserif" +.; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "roman" OR typeface = "sansserif" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + + + +$typefacep6+$ +BOOL VAR is courier :: TRUE; +TEXT VAR std typeface name :: "courier"; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "courier" OR typeface = "souvenir" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + +$typefaceoki$ +BOOL VAR is courier ; +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "courier" OR typeface = "kassette" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + +$typefacestar$ +BOOL VAR is roman ; +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "roman" OR typeface = "font1" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : + + std typeface name +END PROC std typeface; + +$feed$ +BOOL VAR is sheet feed :: FALSE; + +PROC paper feed (TEXT CONST feeder) : + + IF feeder = "sheet" + THEN is sheet feed := TRUE + ELIF feeder = "tractor" + THEN is sheet feed := FALSE + ELSE errorstop ("unzulässige Einzugsart") + FI +END PROC paper feed; + +TEXT PROC paper feed: + IF is sheet feed + THEN "sheet" + ELSE "tractor" + FI +END PROC paper feed; + +$feedschacht$ +BOOL VAR is sheet feed :: FALSE; +TEXT VAR feeder name :: "tractor"; + +PROC paper feed (TEXT CONST feeder) : + + IF feeder = "tractor" + THEN feeder name := "tractor"; + is sheet feed := FALSE + ELIF feeder = "sheet" OR feeder = "schacht1" + THEN feeder name := "schacht1" ; + is sheet feed := TRUE + ELIF feeder = "schacht2" + THEN feeder name := "schacht2" ; + is sheet feed := TRUE + ELSE errorstop ("unzulässige Einzugsart") + FI +END PROC paper feed; + +TEXT PROC paper feed: feeder name END PROC paper feed; + +$open$ +PROC open (INT CONST op code, INT VAR param1, param2): + + SELECT op code OF + CASE 1: open document(param1,param2) + CASE 2: open page (param1,param2) + END SELECT. +END PROC open ; + + +$opendoch$ +PROC open document (INT VAR x steps,y steps): + modification bits := 0; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 30) * 30; + +$opendochtosh$ +PROC open document (INT VAR x steps,y steps): + modification bits := 0; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 36) * 36; + +$initspeed$ + IF pos (material, "slow") <> 0 + THEN is slow := TRUE; + ELIF pos (material, "fast") <> 0 + THEN is slow := FALSE; + ELSE is slow := std speed name = "slow" + FI; + +$opendocp6+$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + FI; + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "courier") <> 0 + THEN is courier := TRUE ; + ELIF pos (material, "souvenir") <> 0 + THEN is courier := FALSE ; + ELSE is courier := std typeface name = "courier" + FI; +END PROC open document ; + +$opendocp5p7$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + center paper ; + FI; + + . center paper : + INT CONST x steps in chars := x steps DIV x step conversion (2.54 / 10.0), + left margin := (136 - x steps in chars) DIV 2; + out (""27"P"); + out (""27"l"); out (code (left margin + 1)); +END PROC open document ; + +$opendocp6$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + FI; +END PROC open document ; + +$opendoclq850$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN out (""27""25"4"); (* Sheetmode ein *) + FI; + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "roman") <> 0 + THEN act typeface name := "roman" + ELIF pos (material, "sansserif") <> 0 + THEN act typeface name := "sansserif" + ELSE act typeface name := std typeface name + FI; +END PROC open document ; + +$opendocokieps$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN IF feeder name = "schacht2" + THEN out (""27""25"2") + ELSE out (""27""25"1") + FI + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "courier") <> 0 + THEN is courier := TRUE ; + ELIF pos (material, "kassette") <> 0 + THEN is courier := FALSE ; + ELSE is courier := std typeface name = "courier" + FI; +END PROC open document ; + +$opendoctosh$ + out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *) + out (""27"6"); (* Zeichensatz *) + out (""27"A"12""27"2") ; + out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; +END PROC open document ; + +$opendocbrother$ + out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *) + out (""27"6" + ""27"R"0""); (* Zeichensatz II ascii *) + out (""27"A"10""27"2") ; (* Zeilenabstand *) + out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *) + IF is sheet feed + THEN out (""27""25"4") + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; +END PROC open document ; + +$opendocokiibm$ + out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *) + out (""27"6" + ""27"!"64""); (* Zeichensatz II ascii *) + out (""27""91""92""4""0""0""0""180""); (* 1/180 *) + out (""27"A"12""27"2") ; (* Zeilenabstand *) + out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *) + IF is sheet feed + THEN IF feeder name = "schacht2" + THEN out (""27""25"2") + ELSE out (""27""25"1") + FI + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "courier") <> 0 + THEN is courier := TRUE ; + ELIF pos (material, "kassette") <> 0 + THEN is courier := FALSE ; + ELSE is courier := std typeface name = "courier" + FI; +END PROC open document ; + +$opendocstar$ + out (""24""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* amerikanischer Zeichensatz *) + out (""27"O"); + out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + IF is sheet feed + THEN IF feeder name = "schacht2" + THEN out (""27""25"2") + ELSE out (""27""25"1") + FI + FI; (* Sheetmode ein *) + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + IF pos (material, "roman") <> 0 + THEN is roman := TRUE ; + ELIF pos (material, "font1") <> 0 + THEN is roman := FALSE ; + ELSE is roman := std typeface name = "roman" + FI; +END PROC open document ; + +$openpagetosh$ +PROC open page (INT VAR x start , y start): + + x start := 0; + IF is sheet feed + THEN y start := y step conversion (2.54) (* 1 Inch *) + ELSE y start := 0; + FI; + x rest := 0; + out (""13""); +END PROC open page; + +$openpage$ +PROC open page (INT VAR x start , y start): + + x start := 0 ; + y start := y step conversion (y margin) ; + x rest := 0; + out (""13""). +END PROC open page; + +$openpagep5-7$ +PROC open page (INT VAR x start , y start): + + x start := 0; + IF is sheet feed + THEN y start := y step conversion (8.466667e-1) (* 2/6 Inch *) + ELSE y start := 0; + FI; + x rest := 0; + out (""13""); +END PROC open page; + +$close$ + +PROC close (INT CONST op code, INT CONST param1) : + + SELECT op code OF + CASE 1: close document + CASE 2: close page (param1) + END SELECT. + +close document : +. +END PROC close ; + +$closepage$ +PROC close page (INT CONST remaining y steps) : + IF remaining y steps > 0 + THEN out (""12"") + ELIF is sheet feed + THEN out (""27""25"R") + FI; +END PROC close page; + +$closepagetosh$ +PROC close page (INT CONST remaining y steps) : + IF is sheet feed + THEN out (""12"") + ELIF remaining y steps > 0 + THEN out (""12"") + FI; +END PROC close page; + +$execute$ +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE 1: write text + CASE 2: write cmd + CASE 3: carriage return + CASE 4: move + CASE 5: draw + CASE 6: on + CASE 7: off + CASE 8: type +END SELECT. + +from : param1. +to : param2. + + write text : + out subtext (string, from, to). + +$cmdp6+$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "courier" + THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI; + ELIF buffer = "souvenir" + THEN IF is courier THEN is courier := FALSE; switch to souvenir FI; + ELIF buffer = "schwarz" + THEN out (""27"r0") + ELIF buffer = "rot" + THEN out (""27"r1") + ELIF buffer = "blau" + THEN out (""27"r2") + ELIF buffer = "violett" + THEN out (""27"r3") + ELIF buffer = "gelb" + THEN out (""27"r4") + ELIF buffer = "orange" + THEN out (""27"r5") + ELIF buffer = "grün" + THEN out (""27"r6") + ELSE out (buffer) + FI. + +$cmdp5-7$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN switch to nlq FI; + is nlq := TRUE; + ELIF buffer = "draft" + THEN IF is nlq THEN switch to draft FI; + is nlq := FALSE; + ELSE out (buffer); + FI;. + +$cmdlq850$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "roman" + THEN IF NOT is roman THEN act typeface name := "roman" ; + switch to roman FI; + ELIF buffer = "sansserif" + THEN IF NOT is sansserif THEN act typeface name := "sansserif"; + switch to sansserif FI; + ELSE out (buffer) + FI. + +$cmdoki$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "courier" + THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI; + ELIF buffer = "kassette" + THEN IF is courier THEN is courier := FALSE; switch to kassette FI; + ELIF buffer = "schwarz" + THEN out (""27"r0") + ELIF buffer = "rot" + THEN out (""27"r1") + ELIF buffer = "blau" + THEN out (""27"r2") + ELIF buffer = "violett" + THEN out (""27"r3") + ELIF buffer = "gelb" + THEN out (""27"r4") + ELIF buffer = "orange" + THEN out (""27"r5") + ELIF buffer = "grün" + THEN out (""27"r6") + ELSE out (buffer) + FI. + +$cmdtosh$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELSE out (buffer); + FI;. + +$cmdstar$ + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI; + ELIF buffer = "draft" + THEN IF is nlq THEN is nlq := FALSE; switch to draft FI; + ELIF buffer = "roman" + THEN IF NOT is roman THEN is roman := TRUE; switch to roman FI; + ELIF buffer = "font1" + THEN IF is roman THEN is roman := FALSE; switch to font1 FI; + FI. + +$crs$ + carriage return : + x rest := 0; + out (""13""). + +$move$ +x steps : param1. +y steps : param2. + +move : + IF x steps < 0 OR y steps < 0 THEN stop FI; + IF x steps > 0 THEN x move FI; + IF y steps > 0 THEN y move FI. + +$stdmove$ +x move : + x rest INCR x steps; + high := (x rest) DIV blankbreite; + x rest := (x rest) MOD blankbreite; + steps := x rest DIV 3; + IF high > 0 THEN high TIMESOUT " " FI; + IF steps > 0 AND is slow + THEN IF is underline THEN out (" "8"") FI; + out (""27"Y" + code (steps) + ""0""); (* 1/360 *) + steps TIMESOUT ""0""; + x rest := x rest MOD 3 + FI. + +is underline: + bit (modification bits,7). + +y move : + IF y steps > 0 + THEN high := y steps DIV 255; + low := y steps MOD 255; + IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; (* 1/180 *) + IF low > 0 THEN out (""27"J" + code (low)) FI; + FI. + +draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> 1 + THEN stop + ELIF x steps > 0 + THEN x draw + FI. + +x draw : + x rest INCR x steps ; + steps := x steps DIV 3 ; + IF steps > 0 THEN + x rest := x steps MOD 3 ; + out (""27"Y"); + out (code (steps MOD 256)); + out (code (steps DIV 256)); + steps TIMESOUT ""1""; + FI. + +$movep5-7$ + x move : + x rest INCR x steps; + IF not is underline + THEN simple x move + ELSE underline x move + FI; + + . not is underline : + NOT bit (modification bits, 7) + + . simple x move : + high := x rest DIV factor 1; + x rest := x rest MOD factor 1; + out (""27"\"); + out (code (high MOD 256)); + out (code (high DIV 256)); + + . underline x move : + high := x rest DIV factor 2; + x rest := x rest MOD factor 2; + IF high < blankbreite + THEN stop + ELSE low := high MOD 127; + high := high DIV 127; + IF low >= blankbreite + THEN low DECR blankbreite; + ELSE high DECR 1; + low DECR (blankbreite - 127); + FI; + IF high > 0 + THEN out (""27" "); + out (code (127 - blankbreite)); + high TIMESOUT " "; + FI; + out (""27" "); + out (code (low)); + out (" "27" "0""); + FI; +. y move: + + low := y steps MOD 255; + high := y steps DIV 255; + IF high > 0 THEN high TIMESOUT (""27"J"255"") FI; + IF low > 0 THEN out (""27"J" + code (low)) FI; + +. draw : + IF x steps < 0 OR y steps <> 0 + THEN stop + ELIF x steps > 0 + THEN x draw + FI; + + . x draw : + x rest INCR x steps; + steps := x rest DIV 4; + x rest := x rest MOD 4; + IF steps > 0 + THEN low := steps MOD 256; + high := steps DIV 256; + out (""27"*"39""); + out (code (low)); + out (code (high)); + steps TIMESOUT dot; + FI; + + . dot : + IF linetype = underline linetype + THEN ""000""000""001"" + ELSE ""000""000""048"" + FI. + + +$onoff$ + modification : param1 +. + on : + buffer := on string (modification); + IF buffer <> "" + THEN modification bits := modification bits OR code (buffer); + switch to font; + ELSE stop + FI + +. + off : + buffer := off string (modification); + IF buffer <> "" + THEN modification bits := modification bits XOR code (buffer); + switch to font; + ELSE stop + FI. + +$typep6+$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is courier + THEN switch to courier + ELSE switch to souvenir + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to courier : + out (""27"k"0"") ; + +. switch to souvenir : + out (""27"k"15"") ; +END PROC execute; + +$typeplq850$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is roman + THEN switch to roman + ELSE switch to sansserif + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to roman : + out (""27"k"0"") ; + +. switch to sansserif : + out (""27"k"1"") ; +END PROC execute; + +$typeokieps$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + vertical factor := code (buffer SUB 1); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is courier + THEN switch to courier + ELSE switch to kassette + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + IF vertical factor = 2 + THEN out (""27"w"1"") + ELSE out (""27"w"0"") + FI; + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to courier : + out (""27"k"0"") ; + +. switch to kassette : + out (""27"k"127"") ; +END PROC execute; + +$typep5-7$ + type : + font nr := param1; + buffer := font string (font nr); + factor 1 := code (buffer SUB 1); (* 720 / Mikroschritte pro Inch mit ESC \ *) + factor 2 := code (buffer SUB 2); (* 720 / Mikroschritte pro Inch mit ESC Blank *) + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") DIV factor 2; + switch to font; + IF is nlq THEN switch to nlq FI; + +END PROC execute; + + +PROC switch to font : + + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +END PROC switch to font; + + +PROC switch to nlq : + + IF is pica OR is elite + THEN draft factor 1 := factor 1; + factor 1 := 4; + draft factor 2 := factor 2; + IF is pica + THEN factor 2 := 4 * factor 2 DIV 6; + blankbreite := char pitch (font nr, " ") DIV factor 2; + FI; + out (""27"x"1""); + ELSE out (""27"x"0""); + FI; + +END PROC switch to nlq; + + +PROC switch to draft : + + IF is pica OR is elite + THEN factor 1 := draft factor 1; + factor 2 := draft factor 2; + out (""27"x"0""); + FI; + +END PROC switch to draft; + +$typetosh$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + switch to font; + +. switch to font : + INT VAR master select bits := font bits OR modification bits ; + IF bit (master select bits,0) + THEN out (""27":") + ELSE out (""18"") + FI; + IF bit (master select bits,1) + THEN out (""27"I"2""27"P"1"") + ELSE out (""27"P"0"") + FI; + IF bit (master select bits,2) + THEN out (""27""15"") + FI; + IF bit (master select bits,3) + THEN out (""27"E") + ELSE out (""27"F") + FI; + IF bit (master select bits,4) + THEN out (""27"G") + ELSE out (""27"H") + FI; + IF bit (master select bits,5) + THEN out (""27"W"1"") + ELSE out (""27"W"0"") + FI; + IF bit (master select bits,6) + THEN + ELSE + FI; + IF bit (master select bits,7) + THEN out (""27"-"1"") + ELSE out (""27"-"0"") + FI; + out (font text); + + +. switch to nlq : + out (""27"I"2""); + +. switch to draft : + out (""27"I"1""); + +END PROC execute; + +$typeokiibm$ + type : + font nr := param1 ; + buffer := font string (font nr); + vertical factor := code (buffer SUB 1); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is courier + THEN switch to courier + ELSE switch to kassette + FI ; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + switch to font; + +. switch to font : + INT VAR master select bits := font bits OR modification bits ; + IF bit (master select bits,0) + THEN out (""27":") + ELSE out (""18"") + FI; + IF bit (master select bits,1) + THEN out (""27"I"2""27"P"1"") + ELSE out (""27"P"0"") + FI; + IF bit (master select bits,2) + THEN out (""27""15"") + FI; + IF bit (master select bits,3) + THEN out (""27"E") + ELSE out (""27"F") + FI; + IF bit (master select bits,4) + THEN out (""27"G") + ELSE out (""27"H") + FI; + IF bit (master select bits,5) + THEN out (""27"W"1"") + ELSE out (""27"W"0"") + FI; + IF bit (master select bits,6) + THEN out(""27"%G") + ELSE out(""27"%H") + FI; + IF bit (master select bits,7) + THEN out (""27"-"1"") + ELSE out (""27"-"0"") + FI; + IF vertical factor = 2 + THEN out (""27""91""64""4""0""0""0""2""0"") + ELSE out (""27""91""64""4""0""0""0""1""0"") + FI; + out (font text); + + +. switch to nlq : + out (""27"I"2""); + +. switch to draft : + out (""27"I"0""); + +. switch to courier : + out (""27"k"0"") ; + +. switch to kassette : + out (""27"k"127"") ; +END PROC execute; + +$typebrother$ + type : + font nr := param1 ; + buffer := font string (font nr); + vertical factor := code (buffer SUB 1); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + switch to font; + +. switch to font : + INT VAR master select bits := font bits OR modification bits ; + IF bit (master select bits,0) + THEN out (""27":") + ELSE out (""18"") + FI; + IF bit (master select bits,1) + THEN out (""27"I"2""27"P"1"") + ELSE out (""27"P"0"") + FI; + IF bit (master select bits,2) + THEN out (""27""15"") + FI; + IF bit (master select bits,3) + THEN out (""27"E") + ELSE out (""27"F") + FI; + IF bit (master select bits,4) + THEN out (""27"G") + ELSE out (""27"H") + FI; + IF bit (master select bits,5) + THEN out (""27"W"1"") + ELSE out (""27"W"0"") + FI; + IF bit (master select bits,6) + THEN + ELSE + FI; + IF bit (master select bits,7) + THEN out (""27"-"1"") + ELSE out (""27"-"0"") + FI; + IF vertical factor = 2 + THEN out (""27""91""64""4""0""0""0""2""0"") + ELSE out (""27""91""64""4""0""0""0""1""0"") + FI; + out (font text); + +. switch to nlq : + out (""27"I"2""); + +. switch to draft : + out (""27"I"0""); + +END PROC execute; + +$typestar$ + type : + font nr := param1 ; + buffer := font string (font nr); + font bits := code (buffer SUB 3); + font text := subtext (buffer, 4); + blankbreite := char pitch (font nr, " ") ; + IF is roman + THEN switch to roman + ELSE switch to font1 + FI ; + switch to font; + IF is nlq + THEN switch to nlq + ELSE switch to draft + FI; + +. switch to font : + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +. switch to nlq : + out (""27"x"1""); + +. switch to draft : + out (""27"x"0""); + +. switch to roman : + out (""27"k"0"") ; + +. switch to font1 : + out (""27"k"1"") ; +END PROC execute; + + + +$printerlq1500$ +PACKET printer driver + +(**************************************************************************) +(* Stand : 29.07.86 *) +(* EPSON LQ-1500 Version : 4 *) +(* Autor : Rudolf Ruland *) +(* geändert am 15.12.88 hjh *) +(**************************************************************************) + + DEFINES printer, + open, + close, + execute, + + paper size, + std quality: + +LET +(* underline = 1, + bold = 2, + italics = 4, + reverse = 8, *) + + underline linetype = 1, + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8; + +INT VAR rest, high, low, factor; +BOOL VAR is nlq, factor was 6, condensed; +REAL VAR x size, y size; +TEXT VAR std quality name, buffer; + +(*********************************************************************) + +paper size (13.6 * 2.54, 12.0 * 2.54); +std quality ("draft"); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + + +PROC std quality (TEXT CONST quality) : + + IF quality = "nlq" OR quality = "draft" + THEN std quality name := quality; + ELSE errorstop ("unzulaessige Betriebsart") + FI; + +END PROC std quality; + +TEXT PROC std quality : std quality name END PROC std quality; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + factor := 0; + factor was 6 := FALSE; + condensed := FALSE; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 30) * 30; + out (""27""64""); (* Reset des Druckers *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + + +. x start : param1 +. y start : param2 +. + open page : + x start := 0; + y start := 0; + rest := 0; + out (""13""); + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page +END SELECT; + +. + close document : + + +. remaining y steps : param1 +. + close page : + IF remaining y steps > 0 THEN out (""12"") FI + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + out subtext (string, from, to) + +. + write cmd : + buffer := subtext (string, from, to); + IF buffer = "nlq" + THEN is nlq := TRUE; + near letter quality; + ELIF buffer = "draft" + THEN is nlq := FALSE; + draft quality; + ELSE out (buffer); + FI; + + . near letter quality : + IF factor = 6 + THEN factor was 6 := TRUE; + factor := 4; + ELSE factor was 6 := FALSE; + FI; + IF condensed + THEN out (""27"x"0"") + ELSE out (""27"x"1"") + FI; + + . draft quality : + IF factor was 6 + THEN factor was 6 := FALSE; + factor := 6; + FI; + out (""27"x"0""); + + +(*. x steps to left margin : param1*) +. + carriage return : + rest := 0; + out (""13""); + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps < 0 OR y steps < 0 + THEN stop + ELIF x steps > 0 + THEN x move + ELIF y steps > 0 + THEN y move + FI; + + . x move : + high := (x steps + rest) DIV factor; + rest := (x steps + rest) MOD factor; + out (""27"\"); + out (code (high MOD 256)); + out (code (high DIV 256)); + + . y move : + high := y steps DIV 255; + low := y steps MOD 255; + IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; + IF low > 0 THEN out (""27"J"); out (code (low)) FI; + +. + draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> underline linetype + THEN stop + ELIF x steps > 0 + THEN x draw + FI; + + . x draw : + high := (x steps + rest) DIV 6; + rest := (x steps + rest) MOD 6; + IF high > 0 + THEN low := high MOD 255; + high := high DIV 255; + out (""27"V"); + out (code (low)); + out (""27"*"1""1""0""1""27"V"0""); + FOR low FROM 1 UPTO high + REP out (""27"V"255""27"*"1""1""0""1""27"V"0"") PER; + FI; + + +. modification : param1 +. + on : + IF on string (modification) <> "" + THEN out (on string (modification)) + ELSE stop + FI + +. + off : + IF off string (modification) <> "" + THEN out (off string (modification)) + ELSE stop + FI + + +. font nr : param1 +. + type : + buffer := font string (font nr); + out (buffer); + factor := pitch factor; + IF is nlq THEN near letter quality FI; + + . pitch factor : (* Mikroschritt *) + INT CONST font bits := code (buffer SUB 3); + IF bit (font bits, 1) + THEN condensed := FALSE; 2 (* proportional 1/360 Inch *) + ELIF pos (buffer, ""27"x"1"") <> 0 + THEN condensed := FALSE; 4 (* near letter 1/180 Inch *) + ELIF bit (font bits, 2) + THEN condensed := TRUE; 3 (* condensed 1/240 Inch *) + ELIF bit (font bits, 0) + THEN condensed := FALSE; 4 (* elite 1/180 Inch *) + ELSE condensed := FALSE; 6 (* pica 1/120 Inch *) + FI + +END PROC execute; + + +$end$ +INT VAR reply; DATASPACE VAR ds; FILE VAR file; + +PROC printer: + + disable stop; + continue (server channel); + check error (error message); + ds := nilspace; + REP forget (ds); + execute print; + IF is error AND online THEN put error; clear error; FI; + PER; +END PROC printer; + +PROC execute print: + + LET ack = 0, fetch code = 11, file type = 1003; + enable stop; + ds := nilspace; + call (father, fetch code, ds, reply); + IF reply = ack CAND type (ds) = file type + THEN file := sequential file (input, ds); + print (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); + FI; +END PROC execute print; + +PROC check error(TEXT CONST message): + + IF is error + THEN clear error; rename myself (message); + IF is error THEN end(myself) FI; + pause (9000); end(myself); + FI; +END PROC check error; + +END PACKET printerdriver + + diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel b/system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel new file mode 100644 index 0000000..579f67f --- /dev/null +++ b/system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel @@ -0,0 +1,776 @@ + +(*************************************************************************) +(* Installationsprogramm für Stand : 3. 1.89 *) +(* 24-Nadel Drucker Version : 0.9 *) +(* Autor : hjh *) +(*************************************************************************) + +PACKET driver inst 24 + + + DEFINES treiber einrichten: + + +LET up = ""3""13""5"", + + generator name = "printer.24.nadel", + + description file name = "beschreibungen24", + module file name = "module24"; + + +INT VAR pr channel, + quality, + paper format number, + service option; +TEXT VAR fonttab name :: "", + driver name :: ""; +TEXT VAR inp; +BOOL VAR was esc; + +treiber einrichten + +PROC treiber einrichten: + + treiber einrichten (0) +END PROC treiber einrichten; + +PROC treiber einrichten (INT CONST service opt): + + ask for print channel; + main menu; + IF installed + THEN generate printer spool + ELSE inform about restart + FI. + + ask for printchannel: + inits; + page; + headline ("Druckerkanal - Einstellung"); + cursor (1, 15); + putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit"); + putline (" 'serverchannel (Kanalnummer)' in der Task """ + + name (myself) + """"); + putline (" verändert werden."); + REP + cursor (1, 10); + put (""5"EUMEL-Kanalnummer des Druckerkanals:"); + get (pr channel); + disable stop; + serverchannel (pr channel); + BOOL VAR no error :: NOT is error; + IF is error + THEN cursor (1, 7); + put error; + putline ("Eingabe korrigiert wiederholen!") + FI; + clear error; + enable stop + UNTIL no error PER. + + inits: + line; + IF single task + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") + FI; + command dialogue (TRUE); + IF name (myself) <> "PRINTER" + THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ + + name (myself) + """ !"); + IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?") + THEN rename myself ("PRINTER") + FI + FI; + INT VAR choice; + service option := service opt. + + single task: (pcb (9) AND 255) = 1. + + main menu: + BOOL VAR installed :: FALSE; + REP + show main menu; + get choice; + treat choice + UNTIL was esc OR installed PER. + + show main menu: + page; + headline("Hauptmenü 24-Nadel-Drucker"); + putline (" 1. Brother"); + putline (" 2. Epson"); + putline (" 3. NEC"); + putline (" 4. OKI"); + putline (" 5. Toshiba"). + + get choice: + cursor (1,24); + put ("CR: Eingabe ESC: Installation abbrechen"); + ask user (5). + + treat choice: + SELECT int (inp) OF + CASE 1: brother menu + CASE 2: epson menu + CASE 3: nec menu + CASE 4: oki menu + CASE 5: toshiba menu + END SELECT. + + + brother menu: + page; + headline ("brother - Menü"); + putline (" 1. M-1724 L"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + brother m1724l inst + FI. + + brother m1724l inst: + putline ("brother M-1724 L"); + line; + putline ("Wählen Sie folgende DIP-Schalter Optionen:"); + putline ("Emulationsmodus IBM Proprinter XL "); + putline ("Automatischer Zeilenvorschub Nein "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.brother"); + generate ("brotherm1724l"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + toshiba menu: + page; + headline ("TOSHIBA - Menü"); + putline (" 1. P 321"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + toshiba p321 inst + FI. + + toshiba p321 inst: + putline ("TOSHIBA P 321"); + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S3-8 S3-7 S3-5 übrige Schalter"); + putline ("OFF OFF *) egal "); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std speed, paper feed"); + show material options("slow, fast"); + show command options ("nlq, draft"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.toshiba.p321"); + generate ("toshp321"); + adjust papersize; + adjust quality; + do ("papersize(21.0,30.48)"); + installed := TRUE; + FI. + + + epson menu: + page; + headline ("Epson - Menü"); + putline (" 1. LQ 850"); + putline (" 2. LQ 1050"); + putline (" 3. LQ 1500"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (3); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : lq850 inst + CASE 2 : lq850 inst + CASE 3 : lq1500 inst + END SELECT + FI. + + lq850 inst: + IF choice = 1 + THEN putline ("Epson LQ 850") + ELSE putline ("Epson LQ 1050") + FI; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8"); + putline ("egal egal egal egal egal egal *1) OFF "); + putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line; + putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8"); + putline ("egal egal *2) OFF OFF"); + putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle "); + putline (" gesetzt werden (Druckerhandbuch)"); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, roman, sansserif"); + show command options ("draft, nlq, roman, sansserif"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.epson.lq850"); + generate ("epsonlq850"); + adjust quality; + adjust papersize; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + lq1500 inst: + putline ("EPSON LQ-1500"); + show control options (""); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + IF all right + THEN get fonttable ("fonttab.epson.lq1500"); + generate ("epsonlq1500"); + adjust quality; + installed := TRUE + FI. + + nec menu: + page; + headline ("NEC - Menü"); + putline (" 1. PINWRITER P5 "); + putline (" 2. PINWRITER P6 "); + putline (" 3. PINWRITER P7 "); + putline (" 4. PINWRITER P6 PLUS"); + putline (" 5. PINWRITER P7 PLUS"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (5); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : necp5p7 inst + CASE 2 : necp6 inst + CASE 3 : necp5p7 inst + CASE 4 : necp6plus inst + CASE 5 : necp6plus inst + END SELECT + FI. + + necp5p7 inst: + IF choice = 1 + THEN putline ("NEC PINWRITER P5") + ELSE putline ("NEC PINWRITER P7") + FI; + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp5p7"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6 inst: + putline ("NEC PINWRITER P6 "); + show control options ("paper feed"); + show material options ("draft, nlq"); + show command options ("draft, nlq"); + ask for quality; + ask for papersize; + IF all right + THEN get fonttable ("fonttab.nec.p5.new"); + generate ("necp6"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + necp6plus inst: + IF choice = 4 + THEN putline ("NEC PINWRITER P6 PLUS") + ELSE putline ("NEC PINWRITER P7 PLUS") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("CR FUNCTION CR ONLY "); + show control options ("std speed, top margin, std typeface, paperfeed"); + show material options ("slow, fast, draft, nlq, courier, souvenir"); + show command options ("draft, nlq, courier, souvenir"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.nec.p6+"); + generate ("necp6+"); + adjust papersize; + adjust quality; + installed := TRUE; + IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI; + FI. + + oki menu: + page; + headline ("OKI - Menü"); + putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel"); + putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel"); + putline (" 3. MICROLINE 393/393C EPSON-kompatibel"); + putline (" 4. MICROLINE 393/393C IBM-kompatibel"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (4); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1 : oki ml390 inst + CASE 2 : oki ml390 inst + CASE 3 : oki ml393eps inst + CASE 4 : oki ml393ibm inst + END SELECT + FI. + + oki ml390 inst: + IF choice = 1 + THEN putline ("OKI Microline 390") ; + ELSE putline ("OKI Microline 391") ; + FI; + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE EPSON LQ "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki390/391"); + adjust papersize; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + oki ml393eps inst: + putline ("OKI Microline 393 EPSON-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Ceps"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + oki ml393ibm inst: + putline ("OKI Microline 393 IBM-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:"); + putline ("EMULATION MODE ASCII "); + putline ("AUTO LF NO "); + show control options ("paperfeed, std speed, top margin, std typeface"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for papersize; + ask for quality; + IF all right + THEN get fonttable ("fonttab.oki"); + generate ("oki393/393Cibm"); + adjust papersize; + adjust quality; + installed := TRUE + FI. + + + +generate printer spool: + IF service opt = 0 + THEN forget (generator name, quiet); + forget (driver name, quiet) + FI; + eumel must advertise; + cursor (1, 10); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (2); + putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer"); + putline (" Drucker eingesetzt werden soll."); + line (2); + put ("Generierung beendet, weiter mit 'SV'"); + break (quiet); + do ("spool manager (PROC printer)"). + + inform about restart: + page; + putline ("Es ist kein Druckertreiber installiert worden!"); + line; + putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline ("mit 'treiber einrichten' erneut aufgerufen werden."); + line. + +END PROC treiber einrichten; + +PROC headline (TEXT CONST header): + + cursor (13,1); + putline ("E U M E L - Druckertreiber - Installations - Programm"); + cursor (40 - LENGTH header DIV 2, 2); + put (header); + line (2) +END PROC headline; + +PROC ask user (INT CONST max choice): + + TEXT VAR exit; + inp := ""; + REP + cursor (1,23); + IF inp = "" + THEN put ("Ihre Wahl (Nummer eingeben):") + ELSE put ("FEHLER! Eingabe korrigieren:") + FI; + editget (inp, ""27"", "", exit); + was esc := exit = ""27""; + UNTIL was esc OR ok PER. + + ok: + int (inp) > 0 AND int (inp) <= max choice AND last conversion ok. +END PROC ask user; + +PROC show control options (TEXT CONST options): + + line; + putline ("Steuerprozeduren in der Task """ + name (myself) + """:"); + write ("papersize, std quality"); + IF options <> "" + THEN put (","); + putline (options) + FI +END PROC show control options; + +PROC show material options (TEXT CONST options): + + line; + putline ("Mögliche Materialwerte (#material(""..."")#):"); + putline (options) +END PROC show material options; + +PROC show command options (TEXT CONST options): + + line; + putline ("Mögliche direkte Druckeranweisungen (#""...""#):"); + putline (options) +END PROC show command options; + +PROC ask for quality: + + line (1); + putline ("Standard - Druckqualität:"); + line; + REP out (up); + IF yes ("Draft Quality (schneller, aber nicht so schön)") + THEN quality := 1; LEAVE ask for quality + FI; + out (up); + IF yes ("Near Letter Quality (schöner, aber langsamer)") + THEN quality := 2; LEAVE ask for quality + FI; + PER +END PROC ask for quality; + +PROC adjust quality: + + IF quality = 1 + THEN do ("std quality (""draft"")") + ELSE do ("std quality (""nlq"")") + FI +END PROC adjust quality; + +PROC ask for papersize : +LET up = ""3""13""5""; + + paper format number := paper format ; + + . paper format : + line (1); + putline ("Papierformat:"); + line; + REP out (up); + IF yes ("Endlospapier, 8 Zoll breit") + THEN LEAVE paper format WITH 1 FI; + out (up); + IF yes ("Endlospapier, 13.2 Zoll breit") + THEN LEAVE paper format WITH 2 FI; + out (up); + IF yes ("Einzelblatteinzug, DINA 4") + THEN LEAVE paper format WITH 3 FI; + PER; + 0 +END PROC ask for papersize; + + +PROC adjust papersize: + + SELECT paper format number OF + CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)"); + do ("paper feed (""tractor"")") + CASE 3 : do("papersize (21.0, 29.7)"); + do ("paper feed (""sheet"")") + END SELECT + +END PROC adjust papersize; + +BOOL PROC all right: + + line (3); + cursor (1,23); + yes ("Soll der ausgewählte Druckertreiber installiert werden") +END PROC all right; + +PROC get fonttable (TEXT CONST name): + + fonttab name := name; + from archive ((description file name & module file name & fonttab name) + - all); + fonttable (fonttab name); + command dialogue (FALSE); + save (fonttab name, /"configurator"); + IF service option = 0 + THEN forget (fonttab name) + FI; + command dialogue (TRUE); +END PROC get fonttable; + +PROC from archive (THESAURUS CONST files): + + IF highest entry (files) > 0 + THEN fetch from archive; + release (archive); + putline ("Archiv abgemeldet !") + FI. + + fetch from archive: + THESAURUS VAR thes :: files; + REP + ask for archive; + reserve archive; + fetch (thes / ALL archive, archive); + thes := thes - all + UNTIL highest entry (thes) = 0 PER. + +ask for archive: + line; + putline ("Bitte Archiv mit den Dateien"); + TEXT VAR buffer; + INT VAR index :: 0; + REP + get (thes, buffer, index); + putline (" " + buffer) + UNTIL index = 0 PER; + putline ("einlegen !"); + line; + putline ("Wenn eingelegt: Taste drücken !"); + inchar (buffer). + +reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop. + +END PROC from archive; + +THESAURUS OP & (TEXT CONST left, right): + THESAURUS VAR result := empty thesaurus; + insert (result, left); + insert (result, right); + result +END OP &; + +THESAURUS OP & (THESAURUS CONST left, TEXT CONST right): + THESAURUS VAR result := left; + insert (result, right); + result +END OP &; + +PROC generate (TEXT CONST name): + + open files; + read description; + build programme; + insert programme; + forget files. + + open files: + line (5); + cursor (1, 20); + putline (""4"Bitte warten !"); + putline (" - Der Treiber wird generiert."); + driver name := "printer." + name + "(generiert)"; + IF exists (driver name) + THEN forget (driver name, quiet) + FI; + FILE VAR des file :: sequential file (modify, description file name), + mod file :: sequential file (modify, module file name), + driver file :: sequential file (output, driver name). + + read description: + to line (des file, 1); + col (des file, 1); + downety (des file, "$" + name + "$"); + IF eof (des file) + THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" + + "Descriptions-File enthalten") + FI; + TEXT VAR description :: "", + record; + BOOL VAR done :: FALSE; + read record (des file, record); + record := subtext (record, col (des file) + LENGTH name + 2); + WHILE NOT eof (des file) AND NOT done REP + treat record + PER. + + treat record: + INT VAR dollar pos :: pos (record, "$"); + IF dollar pos = 0 + THEN description CAT compress (record); + down (des file); + read record (des file, record) + ELSE description CAT compress (subtext (record, 1, dollar pos - 1)); + col (des file, dollar pos); + done := TRUE; + FI. + + build programme: + get module name; + WHILE still modules REP + find module; + transfer module; + get module name + PER. + + get module name: + INT VAR semicol pos :: pos (description, ";"); + TEXT VAR module name; + IF semicol pos > 0 + THEN module name := subtext (description, 1, semicol pos - 1); + description := subtext (description, semicol pos + 1) + ELSE module name := description; + description := "" + FI. + + still modules: + module name <> "" OR description <> "". + + find module: + to line (mod file, 1); + col (mod file, 1); + downety (mod file, "$" + module name + "$"); + IF eof (mod file) + THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" + + "Modul-File enthalten") + FI. + + transfer module: + done := FALSE; + read record (mod file, record); + record := subtext (record, col (mod file) + LENGTH module name + 2); + WHILE NOT eof (mod file) AND NOT done REP + transfer record + PER. + + transfer record: + dollar pos := pos (record, "$"); + IF dollar pos = 0 + THEN write (driver file, compress (record)); + line (driver file); + down (mod file); + read record (mod file, record) + ELSE write (driver file, compress (subtext (record, 1, + dollar pos - 1))); + col (mod file, dollar pos); + done := TRUE; + cout (line no (mod file)) + FI. + + insert programme: + IF online + THEN putline (" - Der Treiber wird insertiert.") + FI; + check off; + insert (driver name). + + forget files: + IF service option = 0 + THEN forget (description file name, quiet); + forget (module file name, quiet) + FI . +END PROC generate; + +END PACKET driver inst 24 + diff --git a/system/printer-24nadel/schulis-sim-3.0 b/system/printer-24nadel/schulis-sim-3.0 new file mode 120000 index 0000000..5ca05f9 --- /dev/null +++ b/system/printer-24nadel/schulis-sim-3.0 @@ -0,0 +1 @@ +schulis-mathe-1.0/
\ No newline at end of file diff --git a/system/printer-9nadel/0.9/doc/readme b/system/printer-9nadel/0.9/doc/readme new file mode 100644 index 0000000..2047abe --- /dev/null +++ b/system/printer-9nadel/0.9/doc/readme @@ -0,0 +1,324 @@ +#type("nlq10")##limit(18.0)##start(1.5,1.0)# +#head# +Treiber-Installations-Programm #right#Seite % +für 9-Nadel-Matrixdrucker #right#23.06.1988 + + +#end# +#on("u")#Dokumentation zum Treiber-Installations-Programm für 9-Nadel- +Matrixdrucker#off("u")# + +#on("u")#Inhalt:#off("u")# + +1. Installations- und Gebrauchsanleitung +2. Druckertreiber-Auswahl +3. Steuerungsmöglichkeiten und Spezialfeatures +4. Weitere Hinweise + + +#on("b")#1. Installations- und Gebrauchsanleitung#off("b")# + +#on("u")#Einrichten#off("u")# +So wird das Treiber-Installationsprogramm eingerichtet: + + SV drücken + + nach 'gib supervisor kommando:' + + begin("PRINTER","SYSUR") + + in der Task "PRINTER" (nach 'gib kommando'): + + archive ("std.printer") + fetch ("printer.neun.nadel",archive) + check off + insert ("printer.neun.nadel") + +Das Programm wird dann insertiert. + +#on("u")#Druckerkanal#off("u")# +Hiernach wird die Kanalnummer des Druckers erfragt. Wenn der Drucker +über Parallelschnittstelle betrieben wird, ist die Kanalnummer +meistens 15. + +#on("u")#Menüsystem#off("u")# +Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern. +Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste +der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier +den passenden Typ aus! +Das Installationsprogramm zeigt nun einige Informationen zu dem ange +wählten Drucker. Besonders zu beachten sind hierbei #on("u")#Angaben zur Konfi +guration des Druckers#off("u")# (z.B. DIP-Schalter). Der Drucker muß unbedingt +wie angegeben konfiguriert werden, wenn er mit dem ausgewählten Trei +ber betrieben werden soll. + +Hinweise zu Konfigurationsangaben: +1. Die Angabe 'egal' bedeutet, daß die Einstellung für die Funktion + des Treibers keine Bedeutung hat. Dennoch solte der Anwender darauf + achten, welche Funktion die Schalter haben (Druckerhandbuch!). So + ist es zum Beispiel immer empfehlenswert, den Papierende-Sensor zu + aktivieren, damit der Drucker nach Papierende nicht auf der Walze + weiterdruckt. +2. Die Konfigurationsangaben beziehen sich immer auf genau den ausge + wählten Druckertyp. Wenn Sie den Treiber mit einem anderen Drucker + als den ausgewählten verwenden, dann beachten Sie folgende Regeln + für die Konfiguration: + - Der Drucker muß auf eine passende Emulation konfiguriert werden. + - Der Drucker darf bei einem Carriage Return (Code 13) keinen Zei + lenvorschub durchführen. + - Der Drucker darf die Perforation #on("u")#nicht#off("u")# automatisch überspringen. + + - Auf Seitenlängen und internationale Zeichensätze müssen Sie nicht + achten. + +(Hinweise zur Auswahl des richtigen Treibers gibt Abschnitt 2) + +Nach den Konfigurationsangaben werden Steuerungsmöglichkeiten des +ausgewählten Treibers angezeigt. (Siehe hierzu Abschnitt 3) + +Falls der Treiber bestimmte grundsätzliche Betriebsmöglichkeiten er +laubt (z.B. DRAFT/NLQ, Einzelblatteinzug), werden Sie danach gefragt, +welche Möglichkeit standardmäßig gewählt werden soll. diese Vorein +stellungen können nachträglich in der Task "PRINTER" mit den entspre +chenden Steuerprozeduren neu gesetzt werden. Außerdem können bestimmte +Einstellungen noch für jedes einzelne Dokument (d.h. für jede Druck +datei) gewählt ('material'-Anweisung) oder sogar innerhalb eines Doku +ments verändert werden (direkte Druckeranweisung \#"..."\#). +Über die Steuerungsmöglichkeiten informiert Abschnitt 3 ausführlicher. + + +#on("b")#2. Druckertreiber-Auswahl#off("b")# + +#on("u")#Verwendung nicht im Menü enthaltener Drucker#off("u")# +Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, soll +ten Sie zunächst versuchen, ob ein Treiber für einen anderen Drucker +des gleichen Herstellers mit Ihrem Drucker korrekt arbeitet. +Falls dies nicht funktioniert oder der Hersteller überhaupt nicht im +Menü erscheint, müssen Sie herausfinden (Druckerhandbuch, -händler!), +welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist. +(Viele Drucker verfügen über EPSON FX-85 bzw. FX-800-Emulationen oder +IBM Grafikdrucker bzw. Proprinter-Eumulationen.) +Eine der beiden Anpassungen 'EPSON MX' oder 'IBM-Grafikdrucker' müßte +immer einen (Minimal-) Betrieb ermöglichen. + +#on("u")#Hinweise zu den Treibern für FX-80/85-kompatilble Drucker#off("u")# +Die Treiber für FX-80-bzw. FX-85-kompatible Geräte, die oft auch IBM- +kompatibel sind, basieren üblicherweise auf den Treibern für EPSON- +Drucker, weil so einige Schrifttypen (z.B. Proportionalschrift) und +Modifikationen leichter ausgenutzt werden können. Ein Nachteil liegt +aber darin, daß beim FX-80 und FX-85 noch die alten EPSON-Zeichensätze +benutzt werden, die nicht die IBM-üblichen Grafik- und Sonderzeichen +enthalten. +Falls für Sie die Benutzung dieser Zeichen vordringlich ist, sollten +Sie Ihren Drucker (nachdem er auf IBM-Emulation konfiguriert wurde) +zusammen mit dem Treiber für IBM-Grafikdrucker bzw. -Proprinter ver +wenden. + + +#on("b")#3. Steuerungsmöglichkeiten und Spezialfeatures#off("b")# + +Einige Treiber bieten bestimmte Einstellungsmöglichkeiten (z.B. +DRAFT/NLQ) und/oder Spezialfeatures (z.B. Farbdruck). +Die Einstellungen können über +- Steuerprozeduren +- Materialanweisungen bzw. +- direkte Druckeranweisungen +vorgenommen werden. + +#on("u")#Steuerprozeduren#off("u")# +setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten +sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER") +aufgerufen werden. #on("b")#Gültig werden die Änderungen erst, wenn danach in +der Druckspooltask das Kommando 'start' gegeben wird!#off("b")# + +PROC papersize (REAL CONST breite, länge) + Dient zur Einstellung der Größe der physikalisch beschreibbaren + Fläche. + Beispiel: papersize (20.32, 30.48) + (Standardeinstellung für Endlospapier 8 Zoll breit und + 12 Zoll lang) + +PROC papersize + Informationsprozedur + +PROC top margin (REAL CONST margin) + Falls der Drucker es nicht erlaubt, direkt am Blattanfang zu druk + ken (zum Beispiel wegen eines Einzelblatteinzugs), muß mit dieser + Prozedur die Länge des oberen Randes, den der Drucker nicht be + drucken kann, in cm angegeben werden. + Beispiel: top margin (2.0) + (Teilt dem Druckertreiber mit, daß die ersten 2 cm + nicht bedruckbar sind.) + +REAL PROC top margin + Informationsprozedur + +PROC std speed (TEXT CONST speed) + Parameter: slow, fast + Wahl zwischen Positionierung in Mikroschritten (slow) oder in + Blanks (fast). + Beispiel: std speed ("slow") + +TEXR PROC std speed + Informationsprozedur + +PROC std quality (TEXT CONST quality) + übliche Parameter: draft, nlq + Wahl zwischen Datenverarbeitungs-Qualität und Schönschrift- + Qualität + Beispiel: std quality ("draft") + +TEXT PROC std quality + Informationsprozedur + +PROC std typeface (TEXT CONST typeface) + übliche Parameter: roman, sansserif, courier + Wahl zwischen verschiedenen NLQ-Schriftarten (nur sichtbar im + NLQ-Modus, das heißt 'std typeface' schaltet nicht auf NLQ). + Beispiel: std typeface ("roman") + +TEXT PROC std typeface + Informationsprozedur + +PROC paper feed (TEXT CONST name) + übliche Parameter: tractor, sheet, schacht1, schacht2 + Wählt Endlospapier oder Einzelblatteinzug und ggf. Schachtnummer. + Beispiel: paper feed ("sheet") + +TEXT PROC paper feed + Informationsprozedur + + +#on("u")#Materialanweisungen \#material("...")\##off("u")# +müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und +setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben +für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge +stellten Standardwerten. Diese werden durch die Materialanweisung aber +nicht geändert.) + +Beispiel: \#material("nlq")\# + sorgt bei entsprechendem Treiber dafür, daß das gesamte + Dokument in Schönschrift-Qualität ausgedruckt wird, egal + wie 'std quality' eingestellt ist. + +#on("b")#Es darf in einer Datei nur eine Materialanweisung stehen!#off("b")# Sollen meh +rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung +erscheinen. Beispiel: \#material("sheet;draft")\# + + +#on("u")#direkte Druckeranweisungen \#"..."\##off("u")# +gelten ab der Position, an der sie in der Datei auftreten. Sie haben +(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und +Materialeinstellungen. + +Beispiel: \#"draft"\# + schaltet (bei entsprechendem Treiber) auf Datenverar + beitungs-Qualität, egal welche Standardeinstellung vorliegt + und welche Materialanweisung gegeben wurde. + +#on("b")#In einer Druckeranweisung darf nur eine Einstellung vorgenommen +werden.#off("b")# Also: \#"nlq"\#\#"sansserif"\# + + +#on("u")#Wichtig#off("u")# +- Achten Sie bei Materialanweisungen und direkten Druckeranweisungen + besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben + berücksichtigt! Also: \#"nlq"\# und keinesfalls \#"NLQ"\#!!! +- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und + nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann + daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse + erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen + Reihenfolge an den Drucker sendet, als er in der Datei steht, die + mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B. + für beide Spalten) unerwünscht erhalten bleibt. + + +#on("u")#Tabelle#off("u")# +Die Tabelle soll einen Anhaltspunkt dafür geben, wie welche Einstel +lungen erfolgen können. + +#type("17")# + Steuerprozeduren Materialanweisungen direkte Druckeranweisungen + +#on("u")# #off("u")# + +Positionierung std speed slow, fast ------ + slow, fast + +Qualität std quality z.B. draft, nlq z.B. draft, nlq + z.B. draft, nlq + +Schriftart std typeface z.B. roman, z.B. roman, +(nur bei NLQ) z.B. roman, sansserif, courier sansserif, courier + sansserif, courier + +Einzelblatt- paper feed z.B. schacht1, z.B. schacht1, +einzug z.B. tractor, schacht2 schacht2 + sheet, + schacht1, schacht2 + +Farbdruck ------ ------ z.B. schwarz, + rot, blau, + violett, gelb + orange, grün + + + +#type("nlq10")##on("b")#4. Weitere Hinweise#off("b")# + +#on("u")#Zeichensatzänderungen gegenüber früheren Versionen#off("u")# +In den Fonttabellen früherer Druckertreiber-Versionen wurden oberhalb +des Codes 127 einige internationale Zeichen zur Verfügung gestellt +(und zwar in Anlehnung an den Agfa-Laserdrucker-Zeichensatz). +Bei den Treibern der vorliegenden Version gilt folgendes: +- Wie bisher wird der volle im Benutzerhandbuch festgelegte EUMEL- + Zeichensatz (sofern möglich) unterstützt. +- Der Code 252 liefert das Paragraphzeichen. +- Alle übrigen (vom EUMEL-Zeichensatz nicht definierten) Zeichencodes + oberhalb 127 liefern, sofern möglich, die entsprechenden Zeichen des + IBM-Grafikzeichensatzes. + + +#on("u")#Hinweis zu Proportionalschriften#off("u")# +Bei Proportionalschriften sollte die Modifikation \#on("i")\# nicht +benutzt werden, da die kursiven Zeichen andere Proportionalbreiten +haben. Stattdessen sollte auf den schrägen Typ umgeschaltet werden +(z.B. von "prop10" auf "prop10i"). + + +#on("u")#Hinweis zur Benutzung von Einzelblatteinzügen#off("u")# +Bei der Benutzung von Einzelblatteinzügen müssen folgende Einstel +lungen vorgenommen werden (vgl. auch Abschnitt 3!): + + Am Drucker: +1. Sie müssen Ihren Drucker auf die Option Einzelblatteinzug konfigu + rieren (siehe Druckerhandbuch!). + + In der Druckspooltask (meist 'PRINTER'): +2. Falls der Druckertreiber die Steuerprozedur 'paper feed' zur Verfü + gung stellt, müssen Sie mit 'paperfeed ("sheet")' oder (für + 2-Schacht-Einzüge) mit 'paperfeed ("schacht1")' bzw. 'paperfeed + ("schacht2")' den Druckertreiber auf Einzelblatteinzug umschalten. +3. Falls Sie eine andere Papierlänge als 12 Zoll (=30.48 cm) verwen + den, müssen Sie die neuen Papiermaße mit 'papersize' in cm einstel + len. + Beispiel: papersize (21.0, 29.7) + (für DIN A4-Blätter) +4. Falls der Drucker mit dem Einzelblatteinzug nicht direkt am Blatt + anfang drucken kann, sondern ein gewisser oberer Rand bleibt, muß + mit 'top margin' die Länge des nicht bedruckbaren Randes in cm dem + Druckertreiber mitgeteilt werden. + Beispiel: top margin (1.5) + (Wie groß der obere Rand ist, kann festgestellt werden, indem eine + Datei mit \#start(0.0,0.0)\# ausgedruckt wird.) + + Wurde mit 'top margin' dem Treiber die Größe der nicht bedruckbaren + Fläche mitgeteilt, so ist darauf zu achten, daß in den Druckdateien + ein genügend großer y-Wert für die Startposition eingestellt wird + ('start'-Anweisung). Andernfalls kommt es bei der Ausgabe in der + ersten Zeile zu Überschreibungen. + + +#on("b")#5. Die Änderungen, die Sie in der Druckspooltask vorgenommen haben + werden erst wirksam, wenn das Spool-Kommando 'start' gegeben wird.#off("b")# + diff --git a/system/printer-9nadel/0.9/source-disk b/system/printer-9nadel/0.9/source-disk new file mode 100644 index 0000000..ddcd852 --- /dev/null +++ b/system/printer-9nadel/0.9/source-disk @@ -0,0 +1 @@ +grundpaket/06_std.printer_9_nadel.img diff --git a/system/printer-9nadel/0.9/src/beschreibungen9 b/system/printer-9nadel/0.9/src/beschreibungen9 new file mode 100644 index 0000000..6a74b88 --- /dev/null +++ b/system/printer-9nadel/0.9/src/beschreibungen9 @@ -0,0 +1,97 @@ + +(*************************************************************************) +(* Stand : 01.10.88 *) +(* Beschreibungen-Datei für 9-Nadel-Drucker Version : 0.9 *) +(* Autoren : mov/hjh *) +(*************************************************************************) + +$fx85$ +head;hfx85;decl;speed;openh;opendoch;initspeed;opendocfx85;openpge;betwoc; +clpge;betwce;cmd;crs;moh;mofx85;ymodr;onoff;tyfx85;end + +$fx800$ +head;hfx800;decl;quality;typeface;openh;opendoch;opendocfx800;openpge;betwoc; +clpge;betwce;cmdfx800;crs;moh;mofx800;ymodr;onoff;tyfx800;end + +$mx$ +head;hmx;decl;speed;openh;opendoch;initspeed;opendocmx;openpge;betwoc;clpge; +betwce;cmd;crs;moh;modrmx;onoff;tymx;end + +$lx800$ +head;hlx800;decl;speed;quality;typeface;openh;opendoch;initspeed; +opendocfx800;openpge;betwoc;clpge;betwce;cmdfx800;crs;moh;mofx85;ymodr;onoff; +tyfx800;end + +$ibmgp$ +head;hgp;decl;speed;openh;opendoch;initspeed;opendocgp;openpge;betwoc; +clpge;betwce;cmd;crs;moh;mogp;ymodr;onoff;tyfx85;end + +$ibmpp$ +head;hpp;decl;speed;quality;openh;opendoch;initspeed;opendocpp;openpge; +betwoc;clpge;betwce;cmdpp;crs;moh;mofx85;ymodr;onoffpp;tyfx85;end + +$okiml182i$ +head;hml182i;decl;speed;quality;openh;opendoch;initspeed;opendocml182i; +opendocgp;openpge;betwoc;clpge;betwce;cmdml182i;crs;moh;mogp;ymodr;onoff; +tyohnesmall;end + +$okiml192el$ +head;hml192el;decl;speed;feed;openh;opendoch;initspeed;opendocml192el; +openpgemlsf;betwoc;clmlsf;betwce;cmd;crs;moh;moml192el;ymodr;onoff;tyml192el; +end + +$okiml292el$ +head;hml292el;decl;quality;typeface292;feed;openh;opendoch;opendocml292el; +openpgemlsf;betwoc;clmlsf;betwce;cmdml292el;crs;moh;mofx800;ymodr;onoff; +tyml292el;end + +$okiml294i$ +head;hml294i;decl;speed;quality;feed;openh;opendoch;initspeed;opendocml294i; +openpgemlsf;betwoc;clmlsf;betwce;cmdml294i;crs;moh;mofx85;ymodr;ontyml294i;end + +$okiml320$ +head;hml320;decl;speed;openh;opendoch;initspeed;opendocml320; +openpge;betwoc;clpge;betwce;cmd;crs;moh;moml192el;ymodr;onoff;tyml192el; +end + +$starlc10$ +head;hlc10;decl;quality;typefacelc10;openh;opendoch;opendoclc10;openpge; +betwoc;clpge;betwce;cmdlc10;crs;moh;mofx800;ymodr;onoff;tyfx800;end + +$dmp4000$ +head;hdmp4000;decl;speed;openh;opendoch;initspeed;opendocdmp4000;openpge; +betwoc;clpge;betwce;cmd;crs;moh;mofx85;ymodr;onoff;tyfx85;end + +$starnx15$ +head;hnx15;decl;speed;openh;opendoch;initspeed;opendocnx15;openpge;betwoc; +clpge;betwce;cmd;crs;moh;mofx85;ymodr;onoff;tyfx85;end + +$mt230$ +head;hmt230;decl;speed;feedschacht;openh;opendoch;initspeed;opendocmt; +openpgemtsf;betwoc;clmtsf;betwce;cmdmt230;crs;moh;mofx85;ymodr;onoff; +tyfx85;end + +$mt340$ +head;hmt340;decl;speed;feedschacht;openh;opendoch;initspeed;opendocmt; +openpgemtsf;betwoc;clmtsf;betwce;cmdmt230;crs;moh;moml192el;ymodr;onoff; +tyml192el;end + +$citi120d$ +head;h120d;decl;openh;opendoch;opendoc120d;openpge;betwoc; +clpge;betwce;cmd;crs;moh;mofx800;ymodr;onoff;tyfx85;end + +$citohc310cxp$ +head;hc310;decl;speed;feedschacht;openh;opendoch;initspeed;opendocc310; +openpgec310sf;betwoc;clc310sf;betwce;cmdc310;crs;moh;mofx85;ymodr;onoff; +tyfx85;end + +$citohci3500$ +head;hci3500;decl;speed;openh;opendoch;initspeed;opendocgp;openpge;betwoc; +clpge;betwce;cmd;crs;moh;mogp;ymodr;onoff;tyfx85;end + +$fujdx2100$ +head;hdx2100;decl;speed;feed;openh;opendoch;initspeed;opendocdx2100; +openpge;betwoc;clpge;betwce;cmddx2100;crs;moh;moml192el;ymodr;onoff;tyml192el; +end + + diff --git a/system/printer-9nadel/0.9/src/fonttab.1 b/system/printer-9nadel/0.9/src/fonttab.1 Binary files differnew file mode 100644 index 0000000..b5d17e6 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.1 diff --git a/system/printer-9nadel/0.9/src/fonttab.10 b/system/printer-9nadel/0.9/src/fonttab.10 Binary files differnew file mode 100644 index 0000000..6a13c49 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.10 diff --git a/system/printer-9nadel/0.9/src/fonttab.20 b/system/printer-9nadel/0.9/src/fonttab.20 Binary files differnew file mode 100644 index 0000000..7cf0aaf --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.20 diff --git a/system/printer-9nadel/0.9/src/fonttab.20.lc b/system/printer-9nadel/0.9/src/fonttab.20.lc Binary files differnew file mode 100644 index 0000000..ddf4535 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.20.lc diff --git a/system/printer-9nadel/0.9/src/fonttab.20.lx b/system/printer-9nadel/0.9/src/fonttab.20.lx Binary files differnew file mode 100644 index 0000000..1ce0940 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.20.lx diff --git a/system/printer-9nadel/0.9/src/fonttab.7 b/system/printer-9nadel/0.9/src/fonttab.7 Binary files differnew file mode 100644 index 0000000..676b9a0 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.7 diff --git a/system/printer-9nadel/0.9/src/fonttab.7.cxp b/system/printer-9nadel/0.9/src/fonttab.7.cxp Binary files differnew file mode 100644 index 0000000..0a996f3 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.7.cxp diff --git a/system/printer-9nadel/0.9/src/fonttab.7.fuj b/system/printer-9nadel/0.9/src/fonttab.7.fuj Binary files differnew file mode 100644 index 0000000..1ed83be --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.7.fuj diff --git a/system/printer-9nadel/0.9/src/fonttab.7.mt b/system/printer-9nadel/0.9/src/fonttab.7.mt Binary files differnew file mode 100644 index 0000000..c816646 --- /dev/null +++ b/system/printer-9nadel/0.9/src/fonttab.7.mt diff --git a/system/printer-9nadel/0.9/src/module9 b/system/printer-9nadel/0.9/src/module9 new file mode 100644 index 0000000..65de1ee --- /dev/null +++ b/system/printer-9nadel/0.9/src/module9 @@ -0,0 +1,1099 @@ + +(*************************************************************************) +(* Stand : 01.10.88 *) +(* Module-Datei für 9-Nadel-Drucker Version : 0.9 *) +(* Autoren : mov/hjh *) +(*************************************************************************) + +$head$ +PACKET printer driver + + DEFINES printer, + open, + close, + execute, + paper size, + top margin, + +$hfx85$ std speed: +(* Treiber für EPSON FX85/105, automatisch generiert *) + +$hfx800$ std quality, + std typeface: +(* Treiber für EPSON FX800/1000, automatisch generiert *) +BOOL VAR was tall font; + +$hmx$ std speed: +(* Treiber für EPSON MX80/100, Typ III *) +(* Treiber automatisch generiert *) +BOOL VAR is condensed, is small; + +$hlx800$ std speed, + std quality, + std typeface: +(* Treiber für EPSON LX800/1000, automatisch generiert *) +BOOL VAR was tall font; + +$hgp$ std speed: +(* Treiber für IBM-Grafikdrucker *) +(* Treiber automatisch generiert *) + +$hpp$ std speed, + std quality: +(* Treiber für IBM-Proprinter *) +(* Treiber automatisch generiert *) + +$hml182i$ std speed, + std quality: +(* Treiber für OKI ML182/183 IBM-kompatibel *) +(* Treiber automatisch generiert *) + +$hml192el$ paper feed, + std speed: +(* Treiber für OKI ML192/193 Elite *) +(* Treiber automatisch generiert *) +BOOL VAR prop font; + +$hml292el$ std quality, + std typeface, + paper feed: +(* Treiber für OKI ML292/293 Elite *) +(* Treiber automatisch generiert *) +BOOL VAR was tall font; + +$hml294i$ std speed, + paper feed, + std quality: +(* Treiber für OKI ML294 IBM-kompatibel *) +(* Treiber automatisch generiert *) + +$hml320$ std speed: +(* Treiber für OKI ML320 IBM/EPSON-kompatibel *) +(* Treiber automatisch generiert *) +BOOL VAR prop font; + +$hlc10$ std quality, + std typeface: +(* Treiber für Star LC-10 oder LC-10 Colour *) +(* Treiber automatisch generiert *) +BOOL VAR was tall font; + +$hdmp4000$ std speed: +(* Treiber für Schneider DMP4000, automatisch generiert *) + +$hnx15$ std speed: +(* Treiber für Star NX-15, ND-10, ND-15, NR-10 und NR-15 *) +(* Treiber automatisch generiert *) + +$hmt230$ paper feed, + std speed: +(* Treiber für Mannesmann-Tally MT 230 *) +(* Treiber automatisch generiert *) + +$hmt340$ paper feed, + std speed: +(* Treiber für Mannesmann-Tally MT 340 *) +(* Treiber automatisch generiert *) +BOOL VAR prop font := FALSE; + +$h120d$ : +(* Treiber für Citizen 120-D *) +(* Treiber automatisch generiert *) + +$hc310$ paper feed, + std speed: +(* Treiber für C. Itoh C 310/315 CXP *) +(* Treiber automatisch generiert *) + +$hci3500$ std speed: +(* Treiber für C. Itoh CI-3500 *) +(* Treiber automatisch generiert *) + +$hdx2100$ paper feed, + std speed: +(* Treiber für Fujitsu DX 2100 *) +(* Treiber automatisch generiert *) +BOOL VAR prop font := FALSE ; + +$decl$ +INT VAR blankbreite, x rest, y rest, high, low, small, modifikations; +REAL VAR x size, y size, y margin; +TEXT VAR buffer :: ""; + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); +END PROC paper size; + +papersize (20.32, 30.48); + +PROC top margin (REAL CONST margin): + + y margin := margin +END PROC top margin; + +REAL PROC top margin: y margin END PROC top margin; + +top margin (0.0); + +$speed$ +BOOL VAR is slow; +TEXT VAR std speed name :: "slow"; + +PROC std speed (TEXT CONST speed) : + + IF speed = "fast" OR speed = "slow" + THEN std speed name := speed + ELSE errorstop ("unzulässige Geschwindigkeit") + FI +END PROC std speed; + +TEXT PROC std speed : std speed name END PROC std speed; + +$quality$ +TEXT VAR std quality name :: "draft"; + +PROC std quality (TEXT CONST quality) : + + IF quality = "nlq" OR quality = "draft" + THEN std quality name := quality + ELSE errorstop ("unzulässige Qualitätsbezeichnung") + FI +END PROC std quality; + +TEXT PROC std quality : std quality name END PROC std quality; + +$typeface$ +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "roman" OR typeface = "sansserif" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : std typeface name END PROC std typeface; + +$typeface292$ +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "courier" OR typeface = "sansserif" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : std typeface name END PROC std typeface; + +$typefacelc10$ +TEXT VAR std typeface name :: ""; + +PROC std typeface (TEXT CONST typeface) : + + IF typeface = "" OR typeface = "courier" OR typeface = "sansserif" + OR typeface = "orator1" OR typeface = "orator2" + THEN std typeface name := typeface + ELSE errorstop ("unzulässige Schriftart") + FI +END PROC std typeface; + +TEXT PROC std typeface : std typeface name END PROC std typeface; + +$feed$ +TEXT VAR feeder name :: "tractor"; + +PROC paper feed (TEXT CONST feeder) : + + IF feeder = "sheet" OR feeder = "tractor" + THEN feeder name := feeder + ELSE errorstop ("unzulässige Einzugsart") + FI +END PROC paper feed; + +TEXT PROC paper feed: feeder name END PROC paper feed; + +$feedschacht$ +TEXT VAR act feeder :: "", + feeder name :: "tractor"; + +PROC paper feed (TEXT CONST feeder) : + + IF feeder = "tractor" OR feeder = "schacht1" OR feeder = "schacht2" + THEN feeder name := feeder + ELIF feeder = "sheet" + THEN feeder name := "schacht1" + ELSE errorstop ("unzulässige Einzugsart") + FI +END PROC paper feed; + +TEXT PROC paper feed: feeder name END PROC paper feed; + +$openh$ +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE 1: open document + CASE 2: open page +END SELECT. + +$opendoch$ + open document : + modifikations := 0; + param 1 := x step conversion ( x size ); + param 2 := y step conversion ( y size ); +$initspeed$ + IF pos (material, "slow") <> 0 + THEN is slow := TRUE; + ELIF pos (material, "fast") <> 0 + THEN is slow := FALSE; + ELSE is slow := std speed name = "slow" + FI; +$opendocfx85$ + param 2 := (param 2 DIV 36) * 36; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"27"6"); + out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *) + +$opendocfx800$ + param 2 := (param 2 DIV 36) * 36; + was tall font := TRUE; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"); (* Zeichentabelle 4 (Grafik) *) + out (""27"R"0""27"9"27"O"27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + IF pos (material, "nlq") <> 0 + THEN out (""27"x"1"") + ELIF pos (material, "draft") <> 0 + THEN out (""27"x"0"") + ELIF std quality name = "nlq" + THEN out (""27"x"1"") + ELSE out (""27"x"0"") + FI; + IF pos (material, "roman") <> 0 + THEN out (""27"k"0"") + ELIF pos (material, "sansserif") <> 0 + THEN out (""27"k"1"") + ELIF std typeface name = "roman" + THEN out (""27"k"0"") + ELIF std typeface name = "sansserif" + THEN out (""27"k"1"") + FI. + +$opendocmx$ + param 2 := (param 2 DIV 36) * 36; + out (""27"R"0""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"9"27"O"). + +$opendocgp$ + param 2 := (param 2 DIV 36) * 36; + out (""27"6"); (* Zeichensatz 2 *) + out (""18""27"F"27"H"27"W"0""27"T"27"-"0""); (* Modifikationen rücksetzen *) + out (""27"9"27"O"27"A"12""27"2"); + out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *) + +$opendocpp$ + param 2 := (param 2 DIV 36) * 36; + out (""27"6"); (* Zeichensatz 2 *) + out (""18""27"F"27"W"0""27"T"27"-"0""); (* Modifikationen rücksetzen *) + out (""27"9"27"O"27"A"12""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + IF pos (material, "nlq") <> 0 + THEN out (""27"G") + ELIF pos (material, "draft") <> 0 + THEN out (""27"H") + ELIF std quality name = "nlq" + THEN out (""27"G") + ELSE out (""27"H") + FI. + +$opendocml182i$ + IF pos (material, "nlq") <> 0 + THEN out (""27"I3") + ELIF pos (material, "draft") <> 0 + THEN out (""27"I1") + ELIF std quality name = "nlq" + THEN out (""27"I3") + ELSE out (""27"I1") + FI; + out (""27"N"0""); (* Kein Sprung über Perf. *) + +$opendocml192el$ + param 2 := (param 2 DIV 36) * 36; + prop font := FALSE; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"6"); (* Erweiterung des Zeichensatzes *) + out (""27"9"27"O"27"x"0""). + +$opendocml292el$ + param 2 := (param 2 DIV 36) * 36; + was tall font := TRUE; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"); (* Zeichentabelle 4 (Grafik) *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"9"27"O"27"r0"); + IF pos (material, "nlq") <> 0 + THEN out (""27"x"1"") + ELIF pos (material, "draft") <> 0 + THEN out (""27"x"0"") + ELIF std quality name = "nlq" + THEN out (""27"x"1"") + ELSE out (""27"x"0"") + FI; + IF pos (material, "courier") <> 0 + THEN out (""27"k"0"") + ELIF pos (material, "sansserif") <> 0 + THEN out (""27"k"1"") + ELIF std typeface name = "courier" + THEN out (""27"k"0"") + ELIF std typeface name = "sansserif" + THEN out (""27"k"1"") + FI. + +$opendocml294i$ + param 2 := (param 2 DIV 36) * 36; + out (""27"6"); (* Zeichensatz 2 *) + out (""18""27"F"27"W0"27"T"27"-0"27"%H"); (* Modifikationen rücksetzen *) + out (""27"9"27"O"27"A"12""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + IF pos (material, "nlq") <> 0 + THEN out (""27"G") + ELIF pos (material, "draft") <> 0 + THEN out (""27"H") + ELIF std quality name = "nlq" + THEN out (""27"G") + ELSE out (""27"H") + FI. + +$opendocml320$ + param 2 := (param 2 DIV 36) * 36; + prop font := FALSE; + out (""27"{"99""27"{"40""); (* Umschaltung auf EPSON-Emulation *) + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"6"); (* Erweiterung des Zeichensatzes *) + out (""27"9"27"O"27"x"0""). + +$opendoclc10$ + param 2 := (param 2 DIV 36) * 36; + was tall font := TRUE; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"t"1""27"6"); (* Zeichentabelle 4 (Grafik) *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"9"27"r"0""); + IF pos (material, "nlq") <> 0 + THEN out (""27"x"1"") + ELIF pos (material, "draft") <> 0 + THEN out (""27"x"0"") + ELIF std quality name = "nlq" + THEN out (""27"x"1"") + ELSE out (""27"x"0"") + FI; + IF pos (material, "courier") <> 0 + THEN out (""27"k"0"") + ELIF pos (material, "sansserif") <> 0 + THEN out (""27"k"1"") + ELIF pos (material, "orator1") <> 0 + THEN out (""27"k"2"") + ELIF pos (material, "orator2") <> 0 + THEN out (""27"k"3"") + ELIF std typeface name = "courier" + THEN out (""27"k"0"") + ELIF std typeface name = "sansserif" + THEN out (""27"k"1"") + ELIF std typeface name = "orator1" + THEN out (""27"k"2"") + ELIF std typeface name = "orator2" + THEN out (""27"k"3"") + FI. + +$opendocnx15$ + param 2 := (param 2 DIV 36) * 36; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"6"); (* Erweiterung des Zeichensatzes *) + out (""27"9"27"x"0""). + +$opendocdmp4000$ + param 2 := (param 2 DIV 36) * 36; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"m"0""27"R"0""27"9"27"O"27"2"27"6"); + out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *) + +$opendocmt$ + param 2 := (param 2 DIV 36) * 36; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"O"27"x"0""27"r"0""27"6"); + IF feeder name = "tractor" + THEN act feeder := feeder name; + out (""27"[5{") + ELSE out (""27"[0{"); + IF pos (material, "schacht1") <> 0 + THEN act feeder := "schacht1" + ELIF pos (material, "schacht2") <> 0 + THEN act feeder := "schacht2" + ELSE act feeder := feeder name + FI + FI. + +$opendocdx2100$ +param 2 := (param 2 DIV 36) * 36; +out (""24""27""64""); (* Reset des Druckers *) +out (""27"R"0""); (* US-Zeichensatz *) +out (""27"2" + ""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) +out (""27"N"0""); (* skip perforation *) +out (""27"x"0"" + ""27"r"0""). (* draft und black *) + + +$opendoc120d$ + param 2 := (param 2 DIV 36) * 36; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"9"27"O"27"x0"27"2"); + out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *) + +$opendocc310$ + param 2 := (param 2 DIV 36) * 36; + out (""27""64""27""64""); (* Reset des Druckers *) + out (""27"R"0""27"2"); + out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *) + out (""27"O"27"x"0""27"r"0""27"6"); + IF feeder name = "tractor" + THEN act feeder := feeder name; + ELSE IF pos (material, "schacht1") <> 0 + THEN act feeder := "schacht1" + ELIF pos (material, "schacht2") <> 0 + THEN act feeder := "schacht2" + ELSE act feeder := feeder name + FI + FI. + +$openpge$ + open page : + param 1 := 0; + param 2 := y step conversion (y margin); + x rest := 0; + y rest := 0; + small := 0; + out (""13""). +$openpgemlsf$ + open page : + param 1 := 0; + param 2 := 0; + x rest := 0; + y rest := 0; + small := 0; + IF feeder name = "sheet" THEN out (""12"") FI; + out (""13""). +$openpgemtsf$ + open page : + param 1 := 0; + param 2 := 0; + x rest := 0; + y rest := 0; + small := 0; + IF feeder name = "schacht1" + THEN out (""27"[21{"12"") + ELIF feeder name = "schacht2" + THEN out (""27"[22{"12"") + FI; + out (""13""). + +$openpgec310sf$ + open page : + param 1 := 0; + param 2 := 0; + x rest := 0; + y rest := 0; + small := 0; + IF feeder name = "schacht1" + THEN out (""27""25"1"12"") + ELIF feeder name = "schacht2" + THEN out (""27""25"2"12"") + FI; + out (""13""). + +$betwoc$ +END PROC open; + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE 1: close document + CASE 2: close page +END SELECT. +close document : +$clpge$ +. close page : + IF param 1 > 0 THEN out (""12"") FI. +$clmlsf$ +.close page : + IF feeder name = "sheet" + THEN out (""27""25""3"") + ELIF param 1 > 0 + THEN out (""12"") + FI. +$clmtsf$ +.close page : + IF feeder name <> "tractor" + THEN out (""27"[2J") + ELIF param 1 > 0 + THEN out (""12"") + FI. +$clc310sf$ +.close page : + IF feeder name = "sheet" + THEN out (""27""25"R") + ELIF param 1 > 0 + THEN out (""12"") + FI. + +$betwce$ +END PROC close; + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE 1: write text + CASE 2: write cmd + CASE 3: carriage return + CASE 4: move + CASE 5: draw + CASE 6: on + CASE 7: off + CASE 8: type +END SELECT. + +is underline: bit (modifikations, 0). +is bold : bit (modifikations, 1). +is italics : bit (modifikations, 2). + + write text : + out subtext (string, param 1, param 2). +$cmd$ + write cmd : + out subtext (string, param 1, param 2). +$cmdfx800$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "draft" + THEN out (""27"x"0"") + ELIF buffer = "nlq" + THEN out (""27"x"1"") + ELIF buffer = "roman" + THEN out (""27"k"0"") + ELIF buffer = "sansserif" + THEN out (""27"k"1"") + ELSE out (buffer) + FI. +$cmdpp$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "draft" + THEN out (""27"H") + ELIF buffer = "nlq" + THEN out (""27"G") + ELSE out (buffer) + FI. +$cmdml182i$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "draft" + THEN out (""27"I1") + ELIF buffer = "nlq" + THEN out (""27"I3") + ELSE out (buffer) + FI. +$cmdml292el$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "draft" + THEN out (""27"x"0"") + ELIF buffer = "nlq" + THEN out (""27"x"1"") + ELIF buffer = "courier" + THEN out (""27"k"0"") + ELIF buffer = "sansserif" + THEN out (""27"k"1"") + ELIF buffer = "schwarz" + THEN out (""27"r0") + ELIF buffer = "rot" + THEN out (""27"r1") + ELIF buffer = "blau" + THEN out (""27"r2") + ELIF buffer = "violett" + THEN out (""27"r3") + ELIF buffer = "gelb" + THEN out (""27"r4") + ELIF buffer = "orange" + THEN out (""27"r5") + ELIF buffer = "grün" + THEN out (""27"r6") + ELSE out (buffer) + FI. +$cmdml294i$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "draft" + THEN out (""27"H") + ELIF buffer = "nlq" + THEN out (""27"G") + ELIF buffer = "schwarz" + THEN out (""27"r0") + ELIF buffer = "rot" + THEN out (""27"r1") + ELIF buffer = "blau" + THEN out (""27"r2") + ELIF buffer = "violett" + THEN out (""27"r3") + ELIF buffer = "gelb" + THEN out (""27"r4") + ELIF buffer = "orange" + THEN out (""27"r5") + ELIF buffer = "grün" + THEN out (""27"r6") + ELSE out (buffer) + FI. +$cmdlc10$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "draft" + THEN out (""27"x"0"") + ELIF buffer = "nlq" + THEN out (""27"x"1"") + ELIF buffer = "courier" + THEN out (""27"k"0"") + ELIF buffer = "sansserif" + THEN out (""27"k"1"") + ELIF buffer = "orator1" + THEN out (""27"k"2"") + ELIF buffer = "orator2" + THEN out (""27"k"3"") + ELIF buffer = "schwarz" + THEN out (""27"r"0"") + ELIF buffer = "rot" + THEN out (""27"r"1"") + ELIF buffer = "blau" + THEN out (""27"r"2"") + ELIF buffer = "violett" + THEN out (""27"r"3"") + ELIF buffer = "gelb" + THEN out (""27"r"4"") + ELIF buffer = "orange" + THEN out (""27"r"5"") + ELIF buffer = "grün" + THEN out (""27"r"6"") + ELSE out (buffer) + FI. +$cmdmt230$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF feeder name <> "tractor" + THEN IF buffer = "schacht1" OR buffer = "schacht2" + THEN act feeder := buffer + FI + ELIF buffer = "schwarz" + THEN out (""27"r"0"") + ELIF buffer = "magenta" + THEN out (""27"r"1"") + ELIF buffer = "cyan" + THEN out (""27"r"2"") + ELIF buffer = "blau" + THEN out (""27"r"3"") + ELIF buffer = "gelb" + THEN out (""27"r"4"") + ELIF buffer = "rot" + THEN out (""27"r"5"") + ELIF buffer = "grün" + THEN out (""27"r"6"") + ELSE out (buffer) + FI. + +$cmdc310$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF feeder name <> "tractor" + THEN IF buffer = "schacht1" OR buffer = "schacht2" + THEN act feeder := buffer + FI + ELIF buffer = "schwarz" + THEN out (""27"r"0"") + ELIF buffer = "rot" + THEN out (""27"r"1"") + ELIF buffer = "blau" + THEN out (""27"r"2"") + ELIF buffer = "violett" + THEN out (""27"r"3"") + ELIF buffer = "gelb" + THEN out (""27"r"4"") + ELIF buffer = "orange" + THEN out (""27"r"5"") + ELIF buffer = "grün" + THEN out (""27"r"6"") + ELSE out (buffer) + FI. + +$cmddx2100$ + write cmd : + buffer := subtext (string, param 1, param 2); + IF buffer = "schwarz" + THEN out (""27"r"0"") + ELIF buffer = "rot" + THEN out (""27"r"1"") + ELIF buffer = "blau" + THEN out (""27"r"2"") + ELIF buffer = "violett" + THEN out (""27"r"3"") + ELIF buffer = "gelb" + THEN out (""27"r"4"") + ELIF buffer = "orange" + THEN out (""27"r"5"") + ELIF buffer = "grün" + THEN out (""27"r"6"") + ELSE out (buffer) + FI. + +$crs$ + carriage return : + y rest INCR small; + x rest := 0; + small := 0; + out (""13""). +$moh$ +x steps : param1. +y steps : param2. + +move : + IF x steps < 0 OR y steps < 0 THEN stop FI; + IF x steps > 0 THEN x move FI; + IF y steps > 0 THEN y move FI. + +$mofx85$ +x move : + high := (x steps + x rest) DIV blankbreite; + x rest := (x steps + x rest) MOD blankbreite; + IF high > 0 THEN high TIMESOUT " " FI; + IF x rest > 0 AND is slow + THEN IF is underline THEN out (" "8"") FI; + out (""27"Y"+ code (x rest) + ""0""); + x rest TIMESOUT ""0""; + x rest := 0 + FI. + + +$mofx800$ +x move : + IF is underline + THEN underline x move + ELSE simple x move + FI. + +underline x move: + high := (x steps + x rest) DIV blankbreite; + low := (x steps + x rest) MOD blankbreite; + IF high > 0 THEN high TIMESOUT " " FI; + IF low > 0 + THEN out (" "8""27"\"+ code (low) + ""0"") + FI. + +simple x move: + out (""27"\"); + out (code (x steps MOD 256)); + out (code (x steps DIV 256)). + +$modrmx$ +x move : + high := (x steps + x rest) DIV blankbreite; + low := (x steps + x rest) MOD blankbreite; + IF high > 0 THEN high TIMESOUT " " FI; + IF low > 0 AND is slow + THEN IF is underline THEN out ("_"8"") FI; + IF is condensed + THEN high := low; + low := 0; + out (""27"L"+ code (high) + ""0""); + ELSE high := low DIV 2; + low := low MOD 2; + out (""27"K"+ code (high) + ""0""); + FI; + high TIMESOUT ""0""; + IF is small + THEN out (""27"S"1""); + small DECR 1; + FI; + FI; + x rest := low. + +y move : + y rest INCR y steps; + IF y rest > 0 + THEN high := y rest DIV 255; + low := y rest MOD 255; + IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; + IF low > 0 THEN out (""27"J"); out (code (low)) FI; + y rest := 0 + FI. + +draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> 1 + THEN stop + ELIF x steps > 0 + THEN x draw + FI. + +x draw : + out (""27"L"); + out (code (x steps MOD 256)); + out (code (x steps DIV 256)); + x steps TIMESOUT ""1""; + IF is small THEN out (""27"S"1"") FI. + +$mogp$ +x move : + high := (x steps + x rest) DIV blankbreite; + x rest := (x steps + x rest) MOD blankbreite; + IF high > 0 THEN high TIMESOUT " " FI; + IF x rest > 0 AND is slow + THEN IF is underline + THEN out (" "13""27"Y"); + out (code (x pos MOD 256)); + out (code (x pos DIV 256)); + x pos TIMESOUT ""0"" + ELSE out (""27"Y"+ code (x rest) + ""0""); + x rest TIMESOUT ""0"" + FI; + x rest := 0 + FI. + +$moml192el$ +x move : + high := (x steps + x rest) DIV blankbreite; + x rest := (x steps + x rest) MOD blankbreite; + IF high > 0 THEN high TIMESOUT " " FI; + IF x rest > 0 AND is slow + THEN IF is underline THEN + IF prop font THEN + out (""27"p"0"" + " "8"" + ""27"p"1"") + ELSE + out (" "8"") + FI; + FI; + out (""27"Y"+ code (x rest) + ""0""); + x rest TIMESOUT ""0""; + x rest := 0 + FI. + +$ymodr$ +y move : + y rest INCR y steps; + IF y rest > 0 + THEN high := y rest DIV 255; + low := y rest MOD 255; + IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; + IF low > 0 THEN out (""27"J"); out (code (low)) FI; + y rest := 0 + FI. + +draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> 1 + THEN stop + ELIF x steps > 0 + THEN x draw + FI. + +x draw : + out (""27"Y"); + out (code (x steps MOD 256)); + out (code (x steps DIV 256)); + x steps TIMESOUT ""1"". + +$onoff$ + on : + IF on string (param 1) <> "" + THEN out (on string (param 1)); + modifikations := modifikations OR param 1 + ELSE stop + FI. + + off : + IF off string (param 1) <> "" + THEN out (off string (param 1)); + modifikations := modifikations AND (param 1 XOR -1) + ELSE stop + FI. + +$onoffpp$ + on : + IF on string (param 1) <> "" AND param 1 <> 2 + THEN out (on string (param 1)); + modifikations := modifikations OR param 1 + ELSE stop + FI. + + off : + IF off string (param 1) <> "" AND param 1 <> 2 + THEN out (off string (param 1)); + modifikations := modifikations AND (param 1 XOR -1) + ELSE stop + FI. + +$tyfx85$ + type : + buffer := font string (param 1); + out (buffer); + restore modifikations; + blankbreite := char pitch (param 1, " "); + IF pos (buffer, ""27"S") <> 0 THEN small DECR 1 FI. + +$tyfx800$ + type : + buffer := font string (param 1); + IF was tall font + THEN out (""27"w"0"") + FI; + out (buffer); + restore modifikations; + blankbreite := char pitch (param 1, " "); + was tall font := pos (buffer, ""27"w"1"") <> 0. + +$tymx$ + type : + buffer := font string (param 1); + blankbreite := char pitch (param 1, " "); + is condensed := pos (buffer, ""15"") <> 0; + IF pos (buffer, ""27"S") <> 0 + THEN small DECR 1; + is small := TRUE; + ELSE is small := FALSE; + FI; + out (buffer); + restore modifikations. + +$tyohnesmall$ + type : + buffer := font string (param 1); + out (buffer); + restore modifikations; + blankbreite := char pitch (param 1, " "). + +$tyml192el$ + type : + buffer := font string (param 1); + out (buffer); + restore modifikations; + blankbreite := char pitch (param 1, " "); + prop font := pos (buffer, ""27"p"1"") <> 0; + IF pos (buffer, ""27"S") <> 0 THEN small DECR 1 FI. + +$tyml292el$ + type : + buffer := font string (param 1); + IF was tall font + THEN out (""27""31"0"27"U0") + FI; + was tall font := pos (buffer, ""27"w"1"") <> 0; + change all (buffer, ""27"w"0"", ""27""31"0"27"U0"); + change all (buffer, ""27"w"1"", ""27""31"1"27"U1"); + out (buffer); + restore modifikations; + blankbreite := char pitch (param 1, " "). + +$ontyml294i$ + on : + IF on string (param 1) <> "" AND param 1 <> 2 + THEN out (on string (param 1)); + modifikations := modifikations OR param 1 + ELIF param 1 = 4 + THEN out (""27"%G"); + modifikations := modifikations OR param 1 + ELSE stop + FI. + + off : + IF off string (param 1) <> "" AND param 1 <> 2 + THEN out (off string (param 1)); + modifikations := modifikations AND (param 1 XOR -1) + ELIF param 1 = 4 + THEN out (""27"%H"); + modifikations := modifikations AND (param 1 XOR -1) + ELSE stop + FI. + + type : + buffer := font string (param 1); + out (buffer); + IF is underline THEN out (on string (1)) FI; + IF is bold THEN out (on string (2)) FI; + IF is italics THEN out (""27"%G") FI; + blankbreite := char pitch (param 1, " "); + IF pos (buffer, ""27"S") <> 0 THEN small DECR 1 FI. + +$end$ + restore modifikations: + IF is underline THEN out (on string (1)) FI; + IF is bold THEN out (on string (2)) FI; + IF is italics THEN out (on string (4)) FI. + +END PROC execute; + +INT VAR reply; DATASPACE VAR ds; FILE VAR file; + +PROC printer: + + disable stop; + continue (server channel); + check error (error message); + ds := nilspace; + REP forget (ds); + execute print; + IF is error AND online THEN put error; clear error; FI; + PER; +END PROC printer; + +PROC execute print: + + LET ack = 0, fetch code = 11, file type = 1003; + enable stop; + ds := nilspace; + call (father, fetch code, ds, reply); + IF reply = ack CAND type (ds) = file type + THEN file := sequential file (input, ds); + print (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); + FI; +END PROC execute print; + +PROC check error(TEXT CONST message): + + IF is error + THEN clear error; rename myself (message); + IF is error THEN end(myself) FI; + pause (9000); end(myself); + FI; +END PROC check error; + +END PACKET printerdriver + + diff --git a/system/printer-9nadel/0.9/src/printer.neun.nadel b/system/printer-9nadel/0.9/src/printer.neun.nadel new file mode 100644 index 0000000..00f698b --- /dev/null +++ b/system/printer-9nadel/0.9/src/printer.neun.nadel @@ -0,0 +1,1129 @@ +PACKET driver inst 9 (* Autoren : mov/hjh *) + (* Stand : 01.10.88 *) + + DEFINES druckerkanal, + treiber einrichten: + + +LET up = ""3""13""5"", + + generator name = "printer.neun.nadel", + + description file name = "beschreibungen9", + module file name = "module9"; + + +INT VAR pr channel, + positioning, + quality, + sheet feeder, + service option; +TEXT VAR fonttab name :: "", + driver name :: ""; +TEXT VAR inp; +BOOL VAR was esc; + + +PROC druckerkanal (INT CONST channel) : + + serverchannel (channel) + +END PROC druckerkanal; + +INT PROC druckerkanal : pr channel END PROC druckerkanal; + + +PROC treiber einrichten: + + treiber einrichten (0) +END PROC treiber einrichten; + +PROC treiber einrichten (INT CONST service opt): + + ask for print channel; + main menu; + IF installed + THEN generate printer spool + ELSE inform about restart + FI. + + ask for printchannel: + inits; + page; + headline ("Druckerkanal - Einstellung"); + cursor (1, 15); + putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit"); + putline (" 'druckerkanal (Kanalnummer)' in der Task """ + + name (myself) + """"); + putline (" verändert werden."); + REP + cursor (1, 10); + put (""5"EUMEL-Kanalnummer des Druckerkanals:"); + get (pr channel); + disable stop; + druckerkanal (pr channel); + BOOL VAR no error :: NOT is error; + IF is error + THEN cursor (1, 7); + put error; + putline ("Eingabe korrigiert wiederholen!") + FI; + clear error; + enable stop + UNTIL no error PER. + + inits: + line; + IF single task + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") + FI; + command dialogue (TRUE); + IF name (myself) <> "PRINTER" + THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ + + name (myself) + """ !"); + IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?") + THEN rename myself ("PRINTER") + FI + FI; + INT VAR choice; + service option := service opt. + + single task: (pcb (9) AND 255) = 1. + + main menu: + BOOL VAR installed :: FALSE; + REP + show main menu; + get choice; + treat choice + UNTIL was esc OR installed PER. + + show main menu: + page; + headline ("Hauptmenü 9-Nadel-Drucker"); + putline (" 1. Brother"); + putline (" 2. Citizen"); + putline (" 3. C. Itoh"); + putline (" 4. Epson"); + putline (" 5. Fujitsu"); + putline (" 6. IBM"); + putline (" 7. Mannesmann - Tally"); + putline (" 8. OKI"); + putline (" 9. Schneider"); + putline ("10. Star"). + + get choice: + cursor (1,24); + put ("CR: Eingabe ESC: Installation abbrechen"); + ask user (10). + + treat choice: + SELECT int (inp) OF + CASE 1: brother menu + CASE 2: citizen menu + CASE 3: c itoh menu + CASE 4: epson menu + CASE 5: fujitsu menu + CASE 6: ibm menu + CASE 7: mannesmann menu + CASE 8: oki menu + CASE 9: schneider menu + CASE 10: star menu + END SELECT. + + + brother menu:. + + citizen menu: + page; + headline ("Citizen - Menü"); + putline (" 1. 120-D"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + citi120d inst + FI. + + citi120d inst: + putline ("Citizen 120-D"); + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S1 S2 S3 S4 S5 S6 S7 S8"); + putline ("egal OFF OFF egal egal egal egal egal"); + show control options (""); + IF all right + THEN get fonttable ("fonttab.7"); + generate ("citi120d"); + installed := TRUE + FI. + + c itoh menu: + page; + headline ("C. Itoh - Menü"); + putline (" 1. C 310 CXP"); + putline (" 2. C 315 CXP"); + putline (" 3. CI-3500"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (3); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + IF choice = 3 + THEN ci3500 inst + ELSE c310 inst + FI + FI. + + c310 inst: + IF choice = 1 + THEN putline ("C. Itoh C 310 CXP") + ELSE putline ("C. Itoh C 315 CXP") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):"); + putline ("- 00: Epson-Modus (02)"); + putline ("- 22: nur Wagenrücklauf (01)"); + show control options ("std speed, paperfeed"); + show material options ("slow, fast, schacht1, schacht2"); + show command options ("schacht1, schacht2, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for positioning; + ask for paper feed; + IF all right + THEN get fonttable ("fonttab.7.cxp"); + generate ("citohc310cxp"); + adjust positioning; + adjust paper feed; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + ci3500 inst: + putline ("C. Itoh CI-3500"); + line; + putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):"); + putline ("- 26: nur Wagenrücklauf (1)"); + putline ("- 49: 17,1 Zeichen pro Zoll (17)"); + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.10"); + generate ("citohci3500"); + adjust positioning; + installed := TRUE + FI. + + epson menu: + page; + headline ("Epson - Menü"); + putline (" 1. MX 80 Typ III"); + putline (" 2. MX 100 Typ III"); + putline (" 3. LX 800"); + putline (" 4. LX 1000"); + putline (" 5. FX 85"); + putline (" 6. FX 105"); + putline (" 7. FX 800 oder FX 850"); + putline (" 8. FX 1000 oder FX 1050"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (8); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1, 2: mx80 inst + CASE 3, 4: lx800 inst + CASE 5, 6: fx85 inst + CASE 7, 8: fx800 inst + END SELECT + FI. + + mx80 inst: + IF choice = 1 + THEN putline ("Epson MX 80 Typ III") + ELSE putline ("Epson MX 100 Typ III") + FI; + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.1"); + generate ("mx"); + adjust positioning; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + lx800 inst: + IF choice = 3 + THEN putline ("Epson LX 800") + ELSE putline ("Epson LX 1000") + FI; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4"); + putline ("egal egal egal egal egal egal egal egal egal *) OFF OFF"); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std speed, std quality, std typeface"); + show material options ("slow, fast, draft, nlq, roman, sansserif"); + show command options ("draft, nlq, roman, sansserif"); + ask for positioning; + ask for quality; + IF all right + THEN get fonttable ("fonttab.20.lx"); + generate ("lx800"); + adjust positioning; + adjust quality; + IF choice = 4 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + fx85 inst: + IF choice = 5 + THEN putline ("Epson FX 85") + ELSE putline ("Epson FX 105") + FI; + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4"); + putline ("egal egal egal ON egal egal egal egal egal egal OFF OFF"); + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("fx85"); + adjust positioning; + IF choice = 6 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + fx800 inst: + IF choice = 7 + THEN putline ("Epson FX 800 oder FX 850") + ELSE putline ("Epson FX 1000 oder FX 1050") + FI; + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4"); + putline ("egal egal egal ON egal egal egal egal egal *) OFF OFF"); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std quality, std typeface"); + show material options ("draft, nlq, roman, sansserif"); + show command options ("draft, nlq, roman, sansserif"); + ask for quality; + IF all right + THEN get fonttable ("fonttab.20"); + generate ("fx800"); + adjust quality; + IF choice = 8 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + fujitsu menu: + page; + headline ("Fujitsu - Menü"); + putline (" 1. DX 2100"); + putline (" 2. DX 2200"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (2); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1,2 : dx2100 inst + END SELECT + FI. + + dx2100 inst: + IF choice = 1 + THEN putline ("Fujitsu DX 2100") + ELSE putline ("Fujitsu DX 2200") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4"); + putline ("egal egal egal egal egal egal egal egal egal *) OFF OFF"); + putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug"); + show control options ("std speed, paper feed"); + show material options ("slow, fast"); + show command options ("schwarz, rot, blau, violett, gelb, rot, grün"); + ask for positioning; + ask for paper feed; + IF all right + THEN get fonttable ("fonttab.7.fuj"); + generate ("fujdx2100"); + adjust positioning; + adjust paper feed; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + + + ibm menu: + page; + headline ("IBM - Menü"); + putline (" 1. Grafikdrucker (""80 Zeichen breit"")"); + putline (" 2. Grafikdrucker (""136 Zeichen breit"")"); + putline (" 3. Proprinter/Grafikdrucker II (""80 Zeichen breit"")"); + putline (" 4. Proprinter/Grafikdrucker II (""136 Zeichen breit"")"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (4); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + IF choice = 1 OR choice = 2 + THEN ibmgp inst + ELSE ibmpp inst + FI + FI. + + ibmgp inst: + IF choice = 1 + THEN putline ("IBM Grafikdrucker (""80 Zeichen breit"")") + ELSE putline ("IBM Grafikdrucker (""136 Zeichen breit"")") + FI; + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.10"); + generate ("ibmgp"); + adjust positioning; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + ibmpp inst: + IF choice = 3 + THEN putline ("IBM Proprinter/Grafikdrucker II (""80 Zeichen breit"")") + ELSE putline ("IBM Proprinter/Grafikdrucker II (""136 Zeichen breit"")") + FI; + show control options ("std speed, std quality"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq"); + ask for positioning; + ask for quality; + IF all right + THEN get fonttable ("fonttab.10"); + generate ("ibmpp"); + adjust positioning; + adjust quality; + IF choice = 4 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + mannesmann menu: + page; + headline ("Mannesmann - Tally - Menü"); + putline (" 1. MT 230"); + putline (" 2. MT 340"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (2); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + IF choice = 1 + THEN mt230 inst + ELSE mt340 inst + FI + FI. + + mt230 inst: + putline ("Mannesmann-Tally MT 230"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Der Drucker muß auf den ANSI+EPSON - Modus eingestellt werden."); + putline ("(Siehe: MT 230 Anwenderhandbuch, S. 4-145)"); + show control options ("std speed, paperfeed"); + show material options ("slow, fast, schacht1, schacht2"); + show command options ("schacht1, schacht2, schwarz, magenta, cyan, blau, gelb, rot, grün"); + ask for positioning; + ask for paper feed; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("mt230"); + adjust positioning; + adjust paper feed; + do ("papersize (39.37, 30.48)"); + installed := TRUE + FI. + + mt340 inst: + putline ("Mannesmann-Tally MT 340"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Der Drucker muß auf den ANSI+EPSON - Modus eingestellt werden."); + putline ("(Siehe: MT 340 Anwenderhandbuch, S. 4-104)"); + show control options ("std speed, paperfeed"); + show material options ("slow, fast, schacht1, schacht2"); + show command options ("schacht1, schacht2, schwarz, magenta, cyan, blau, gelb, rot, grün"); + ask for positioning; + ask for paper feed; + IF all right + THEN get fonttable ("fonttab.7.mt"); + generate ("mt340"); + adjust positioning; + adjust paper feed; + do ("papersize (39.37, 30.48)"); + installed := TRUE + FI. + + oki menu: + page; + headline ("OKI - Menü"); + putline (" 1. MICROLINE 182 IBM-kompatibel"); + putline (" 2. MICROLINE 183 IBM-kompatibel"); + putline (" 3. MICROLINE 192 ELITE"); + putline (" 4. MICROLINE 193 ELITE"); + putline (" 5. MICROLINE 292 ELITE"); + putline (" 6. MICROLINE 293 ELITE"); + putline (" 7. MICROLINE 294 IBM-kompatibel"); + putline (" 8. MICROLINE 320"); + putline (" 9. MICROLINE 321"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (9); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + SELECT choice OF + CASE 1, 2: ml182i inst + CASE 3, 4: ml192el inst + CASE 5, 6: ml292el inst + CASE 7 : ml294i inst + CASE 8, 9: ml320 inst + END SELECT + FI. + + ml182i inst: + IF choice = 1 + THEN putline ("OKI Microline 182 IBM-kompatibel") + ELSE putline ("OKI Microline 183 IBM-kompatibel") + FI; + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S-1 S-2 S-3 S-4 S-5 S-6 S-7 S-8"); + putline ("egal egal OFF egal egal OFF egal OFF"); + show control options ("std speed, std quality"); + show material options ("slow, fast, draft, nlq"); + show command options ("draft, nlq"); + ask for positioning; + ask for quality; + IF all right + THEN get fonttable ("fonttab.10"); + generate ("okiml182i"); + adjust positioning; + adjust quality; + IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + ml192el inst: + IF choice = 3 + THEN putline ("OKI Microline 192 ELITE (IBM/EPSON-kompatibel)") + ELSE putline ("OKI Microline 193 ELITE (IBM/EPSON-kompatibel)") + FI; + line; + putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):"); + putline ("- 13: Automatic Line Feed: Nein"); + putline ("- 18: Compatibility: EPSON FX"); + putline ("(Außerdem: Jumper SP5 in Position 'B')"); + show control options ("std speed, paperfeed"); + show material options ("slow, fast"); + ask for positioning; + ask for paper feed; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("okiml192el"); + adjust positioning; + adjust paper feed; + IF choice = 4 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + ml292el inst: + IF choice = 5 + THEN putline ("OKI Microline 292 ELITE (IBM/EPSON-kompatibel)") + ELSE putline ("OKI Microline 293 ELITE (IBM/EPSON-kompatibel)") + FI; + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):"); + putline ("- Automatic Line Feed: NO"); + putline ("- Compatibility: EPSON EX"); + putline ("(Außerdem: Jumper SP5 in Position 'B')"); + show control options ("paperfeed, std quality, std typeface"); + show material options ("draft, nlq, courier, sansserif"); + show command options ("draft, nlq, courier, sansserif"); + putline ("schwarz, rot, blau, violett, gelb, orange, grün"); + ask for paper feed; + ask for quality; + IF all right + THEN get fonttable ("fonttab.20"); + generate ("okiml292el"); + adjust paper feed; + adjust quality; + IF choice = 6 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + ml294i inst: + putline ("OKI Microline 294 IBM-kompatibel"); + putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem"); + putline ("Farbband."); + line; + putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):"); + putline ("- Proportional Spacing: NO"); + putline ("- Automatic Line Feed: NO"); + putline ("- Compatibility: PROPRINTER XL"); + show control options ("paperfeed, std quality"); + show material options ("draft, nlq"); + show command options ("draft, nlq, schwarz, rot, blau, violett, gelb, orange, grün"); + ask for paper feed; + ask for quality; + IF all right + THEN get fonttable ("fonttab.10"); + generate ("okiml294i"); + adjust paper feed; + adjust quality; + do ("papersize (34.544, 30.48)"); + installed := TRUE + FI. + + ml320 inst: + IF choice = 8 + THEN putline ("OKI Microline 320 IBM/EPSON-kompatibel") + ELSE putline ("OKI Microline 321 IBM/EPSON-kompatibel") + FI; + line; + putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):"); + putline ("- Automatic Line Feed: Nein"); + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("okiml320"); + adjust positioning; + IF choice = 9 THEN do ("papersize (34.544, 30.48)") FI; + installed := TRUE + FI. + + schneider menu: + page; + headline ("Schneider - Menü"); + putline (" 1. DMP 4000"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (1); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + dmp4000 inst + FI. + + dmp4000 inst: + putline ("Schneider DMP 4000"); + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("DS1-4 übrige Schalter"); + putline (" OFF egal"); + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("dmp4000"); + adjust positioning; + do ("papersize (39.37, 30.48)"); + installed := TRUE + FI. + + star menu: + page; + headline ("Star - Menü"); + putline (" 1. LC-10 (auch LC-10 Colour)"); + putline (" 2. NX-15"); + putline (" 3. ND-10"); + putline (" 4. ND-15"); + putline (" 5. NR-10"); + putline (" 6. NR-15"); + cursor (1,24); + put ("CR: Eingabe ESC: Zurück zum Hauptmenü"); + ask user (6); + page; + choice := int (inp); + IF was esc + THEN was esc := FALSE + ELSE headline (""); + putline ("Druckertyp:"); + IF choice = 1 + THEN lc10 inst + ELIF choice = 2 + THEN nx15 inst + ELSE nd10 inst + FI + FI. + + lc10 inst: + putline ("Star LC-10 oder LC-10 Colour"); + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S1-1 S1-2 S1-3 S1-4 S1-5 S1-6 S1-7 S1-8 S2-1 S2-2 S2-3 S2-4"); + putline ("egal egal egal *) egal EIN egal EIN egal egal egal egal"); + putline ("*) AUS: Einzelblatteinzug, EIN: kein Einzug"); + show control options ("std quality, std typeface"); + show material options ("draft, nlq, courier, sansserif, orator1, orator2"); + show command options ("draft, nlq, courier, sansserif, orator1, orator2"); + putline ("schwarz, rot, blau, violett, gelb, orange, grün"); + ask for quality; + IF all right + THEN get fonttable ("fonttab.20.lc"); + generate ("starlc10"); + adjust quality; + do ("papersize (21.0, 30.48)"); + installed := TRUE + FI. + + nx15 inst: + putline ("Star NX-15"); + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S1-4 S1-8 S2-5 übrige Schalter"); + putline ("EIN EIN EIN egal"); + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("starnx15"); + adjust positioning; + do ("papersize (36.0, 30.48)"); + installed := TRUE + FI. + + nd10 inst: + IF choice = 3 + THEN putline ("Star ND-10"); + ELIF choice = 4 + THEN putline ("Star ND-15"); + ELIF choice = 5 + THEN putline ("Star NR-10"); + ELSE putline ("Star NR-15"); + FI; + line; + putline ("Die DIP-Schalter müssen so eingestellt sein:"); + putline ("S1-5 S1-6 S2-2 übrige Schalter"); + putline ("EIN EIN EIN egal"); + show control options ("std speed"); + show material options ("slow, fast"); + ask for positioning; + IF all right + THEN get fonttable ("fonttab.7"); + generate ("starnx15"); + adjust positioning; + IF choice = 3 OR choice = 5 + THEN do ("papersize (21.0, 30.48)") + ELSE do ("papersize (36.0, 30.48)") + FI; + installed := TRUE + FI. + +generate printer spool: + IF service opt = 0 + THEN forget (generator name, quiet); + forget (driver name, quiet) + FI; + eumel must advertise; + cursor (1, 10); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (2); + putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer"); + putline (" Drucker eingesetzt werden soll."); + line (2); + put ("Generierung beendet, weiter mit 'SV'"); + break (quiet); + do ("spool manager (PROC printer)"). + + inform about restart: + page; + putline ("Es ist kein Druckertreiber installiert worden!"); + line; + putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """"); + putline ("mit 'treiber einrichten' erneut aufgerufen werden."); + line. + +END PROC treiber einrichten; + +PROC headline (TEXT CONST header): + + cursor (13,1); + putline ("E U M E L - Druckertreiber - Installations - Programm"); + cursor (40 - LENGTH header DIV 2, 2); + put (header); + line (2) +END PROC headline; + +PROC ask user (INT CONST max choice): + + TEXT VAR exit; + inp := ""; + REP + cursor (1,23); + IF inp = "" + THEN put ("Ihre Wahl (Nummer eingeben):") + ELSE put ("FEHLER! Eingabe korrigieren:") + FI; + editget (inp, ""27"", "", exit); + was esc := exit = ""27""; + UNTIL was esc OR ok PER. + + ok: + int (inp) > 0 AND int (inp) <= max choice AND last conversion ok. +END PROC ask user; + +PROC show control options (TEXT CONST options): + + line; + putline ("Steuerprozeduren in der Task """ + name (myself) + """:"); + write ("papersize, top margin"); + IF options <> "" + THEN put (","); + putline (options) + FI +END PROC show control options; + +PROC show material options (TEXT CONST options): + + line; + putline ("Mögliche Materialwerte (#material(""..."")#):"); + putline (options) +END PROC show material options; + +PROC show command options (TEXT CONST options): + + line; + putline ("Mögliche direkte Druckeranweisungen (#""...""#):"); + putline (options) +END PROC show command options; + +PROC ask for positioning: + + line (2); + putline ("Positionierung in x-Richtung:"); + line; + REP out (up); + IF yes ("in Mikroschritten (genauer, aber langsamer)") + THEN positioning := 1; LEAVE ask for positioning + FI; + out (up); + IF yes ("in Blanks (schneller, aber ungenauer)") + THEN positioning := 2; LEAVE ask for positioning + FI; + PER +END PROC ask for positioning; + +PROC ask for quality: + + line (2); + putline ("Standard - Druckqualität:"); + line; + REP out (up); + IF yes ("Draft Quality (schneller, aber nicht so schön)") + THEN quality := 1; LEAVE ask for quality + FI; + out (up); + IF yes ("Near Letter Quality (schöner, aber langsamer)") + THEN quality := 2; LEAVE ask for quality + FI; + PER +END PROC ask for quality; + +PROC ask for paper feed: + + line (2); + putline ("Einzelblatteinzug:"); + line; + REP out (up); + IF yes ("kein Einzelblatteinzug vorhanden") + THEN sheet feeder := 0; LEAVE ask for paper feed + FI; + out (up); + IF yes ("Einzelblatteinzug vorhanden") + THEN sheet feeder := 1; LEAVE ask for paper feed + FI; + PER +END PROC ask for paper feed; + +BOOL PROC all right: + + line (3); + cursor (1,23); + yes ("Soll der ausgewählte Druckertreiber installiert werden") +END PROC all right; + +PROC get fonttable (TEXT CONST name): + + fonttab name := name; + from archive ((description file name & module file name & fonttab name) + - all); + fonttable (fonttab name); + command dialogue (FALSE); + save (fonttab name, /"configurator"); + IF service option = 0 + THEN forget (fonttab name) + FI; + command dialogue (TRUE); +END PROC get fonttable; + +PROC from archive (THESAURUS CONST files): + + IF highest entry (files) > 0 + THEN fetch from archive; + release (archive); + putline ("Archiv abgemeldet !") + FI. + + fetch from archive: + THESAURUS VAR thes :: files; + REP + ask for archive; + reserve archive; + fetch (thes / ALL archive, archive); + thes := thes - all + UNTIL highest entry (thes) = 0 PER. + +ask for archive: + line; + putline ("Bitte Archiv mit den Dateien"); + TEXT VAR buffer; + INT VAR index :: 0; + REP + get (thes, buffer, index); + putline (" " + buffer) + UNTIL index = 0 PER; + putline ("einlegen !"); + line; + putline ("Wenn eingelegt: Taste drücken !"); + inchar (buffer). + +reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop. + +END PROC from archive; + +THESAURUS OP & (TEXT CONST left, right): + THESAURUS VAR result := empty thesaurus; + insert (result, left); + insert (result, right); + result +END OP &; + +THESAURUS OP & (THESAURUS CONST left, TEXT CONST right): + THESAURUS VAR result := left; + insert (result, right); + result +END OP &; + +PROC generate (TEXT CONST name): + + open files; + read description; + build programme; + insert programme; + forget files. + + open files: + line (5); + cursor (1, 20); + putline (""4"Bitte warten !"); + putline (" - Der Treiber wird generiert."); + driver name := "printer." + name + "(generiert)"; + IF exists (driver name) + THEN forget (driver name, quiet) + FI; + FILE VAR des file :: sequential file (modify, description file name), + mod file :: sequential file (modify, module file name), + driver file :: sequential file (output, driver name). + + read description: + to line (des file, 1); + col (des file, 1); + downety (des file, "$" + name + "$"); + IF eof (des file) + THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" + + "Descriptions-File enthalten") + FI; + TEXT VAR description :: "", + record; + BOOL VAR done :: FALSE; + read record (des file, record); + record := subtext (record, col (des file) + LENGTH name + 2); + WHILE NOT eof (des file) AND NOT done REP + treat record + PER. + + treat record: + INT VAR dollar pos :: pos (record, "$"); + IF dollar pos = 0 + THEN description CAT compress (record); + down (des file); + read record (des file, record) + ELSE description CAT compress (subtext (record, 1, dollar pos - 1)); + col (des file, dollar pos); + done := TRUE; + FI. + + build programme: + get module name; + WHILE still modules REP + find module; + transfer module; + get module name + PER. + + get module name: + INT VAR semicol pos :: pos (description, ";"); + TEXT VAR module name; + IF semicol pos > 0 + THEN module name := subtext (description, 1, semicol pos - 1); + description := subtext (description, semicol pos + 1) + ELSE module name := description; + description := "" + FI. + + still modules: + module name <> "" OR description <> "". + + find module: + to line (mod file, 1); + col (mod file, 1); + downety (mod file, "$" + module name + "$"); + IF eof (mod file) + THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" + + "Modul-File enthalten") + FI. + + transfer module: + done := FALSE; + read record (mod file, record); + record := subtext (record, col (mod file) + LENGTH module name + 2); + WHILE NOT eof (mod file) AND NOT done REP + transfer record + PER. + + transfer record: + dollar pos := pos (record, "$"); + IF dollar pos = 0 + THEN write (driver file, compress (record)); + line (driver file); + down (mod file); + read record (mod file, record) + ELSE write (driver file, compress (subtext (record, 1, + dollar pos - 1))); + col (mod file, dollar pos); + done := TRUE; + cout (line no (mod file)) + FI. + + insert programme: + IF online + THEN putline (" - Der Treiber wird insertiert.") + FI; + check off; + insert (driver name). + + forget files: + IF service option = 0 + THEN forget (description file name, quiet); + forget (module file name, quiet) + FI. +END PROC generate; + +PROC adjust positioning: + + IF positioning = 1 + THEN do ("std speed (""slow"")") + ELSE do ("std speed (""fast"")") + FI +END PROC adjust positioning; + +PROC adjust quality: + + IF quality = 1 + THEN do ("std quality (""draft"")") + ELSE do ("std quality (""nlq"")") + FI +END PROC adjust quality; + +PROC adjust paper feed: + + IF sheet feeder = 1 + THEN do ("paper feed (""sheet"")") + ELSE do ("paper feed (""tractor"")") + FI +END PROC adjust paperfeed; + +treiber einrichten + +END PACKET driver inst 9 + diff --git a/system/printer-laser/4/doc/readme b/system/printer-laser/4/doc/readme new file mode 100644 index 0000000..019d75c --- /dev/null +++ b/system/printer-laser/4/doc/readme @@ -0,0 +1,155 @@ +Treiber-Installations-Programm für Laserdrucker 21. 2.1989 + + +1. Installations- und Gebrauchsanleitung + +Einrichten +So wird das Treiber-Installationsprogramm eingerichtet: + + Richten Sie die Task PRINTER als Sohn von SYSUR ein : + + begin ("PRINTER", "SYSUR") + + Geben Sie in der Task PRINTER nacheinander folgende Kommandos + ein, die Sie jeweils mit der ENTER-Taste bestätigen: + + archive ("std.printer") + fetch("laser.inserter",archive) + insert ("laser.inserter") + +Das Programm wird dann insertiert. + + +Menüsystem +Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern. +Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste +der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier +den passenden Typ aus! +Das Installationsprogramm fragt nun nach der Art der Druckerschnittstelle. +Die Druckerhardware muß wie hier angegeben konfiguriert sein, wenn sie +mit dem ausgewählten Treiber betrieben werden soll. + +Das Installationsprogramm kann mit 'treiber einrichten' erneut aufgerufen +werden. Die Druckerschnittstelle kann mit 'printer setup' nachträglich +umkonfiguriert werden. + +2. Druckertreiber-Auswahl + +Verwendung nicht im Menü enthaltener Drucker +Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, +müssen Sie herausfinden (Druckerhandbuch, -händler!), +welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist. +(Die meisten Laserdrucker verfügen über eine HP-Laserjet Emulation). + + +3. Steuerungsmöglichkeiten und Spezialfeatures + +Einige Treiber bieten bestimmte Einstellungsmöglichkeiten. +Die Einstellungen können über +- Steuerprozeduren +- Materialanweisungen bzw. +- direkte Druckeranweisungen +vorgenommen werden. + +Steuerprozeduren +setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten +sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER") +aufgerufen werden. Vor Aufruf der Prozeduren muß das Spoolkommando +'stop spool' gegeben werden! + + + +PROC papersize (REAL CONST breite, länge) + Dient zur Einstellung der Größe der physikalisch beschreibbaren + Fläche. + Beispiel: papersize (21.0, 29.7) + (Standardeinstellung für DIN A4 Format) + +PROC papersize + Informationsprozedur + +Die Änderungen, die Sie in der Druckspooltask vorgenommen haben +werden erst wirksam, nachdem das Spool-Kommando 'start spool' ge +geben und die Druckspooltask verlassen wurde. + + + +Materialanweisungen \#material("...")\# +müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und +setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben +für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge +stellten Standardwerten. Diese werden durch die Materialanweisung aber +nicht geändert.) + +Beispiel: \#material("landscape")\# oder \#material("quer")\# + Der Druckertreiber stellt sich auf Querdruck ein. Für das + Papierformat werden die + durch papersize eingestellten Werte vertauscht angenommen. + Es sollten nur Schrifttypen verwendet werden, die auch im + Landscape-Modus vorhanden sind. + + +- Es darf in einer Datei nur eine Materialanweisung stehen! Sollen meh + rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung + erscheinen. Beispiel: \#material("quer;2")\# + +- Achten Sie bei Materialanweisungen + besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben + berücksichtigt! Also: \#"quer"\# und keinesfalls \#"QUER"\#!!! + +- Bei Laserdruckern gebräuchliche Materialanweisungen sind: + - landscape (quer) + - manual + - tray + +direkte Druckeranweisungen \#"..."\# +gelten ab der Position, an der sie in der Datei auftreten. Sie haben +(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und +Materialeinstellungen. + + +- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und + nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann + daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse + erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen + Reihenfolge an den Drucker sendet, als er in der Datei steht, die + mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B. + für beide Spalten) unerwünscht erhalten bleibt. Direkte + Druckeranweisungen, die das Schriftformat verändern, + sollten grundsätzlich nicht gegeben werden. + + +4. Spezialfeatures: + +Die Druckertreiber für die Drucker APPLE-Laserwriter und NEC LC-08 +verfügen über Anweisungen zum Zeichnen einer Linie, Box oder eines Kuchen- +stücks, die als direkte Druckeranweisungen in ELAN-Syntax gegeben werden +müssen. +Folgende Anweisungen stehen zur Verfügung: + +PROC line (REAL CONST x offset, y offset, width, height, line width) : + +PROC x line (REAL CONST x offset, y offset, width, line width) : + +PROC y line (REAL CONST x offset, y offset, height, line width) : + +PROC box (REAL CONST x offset, y offset, width, height, line width, pattern): + +PROC box shade (REAL CONST x offset, y offset, width, height, pattern) : + +PROC box frame (REAL CONST x offset, y offset, width, height, line width) : + +PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle, + line width, pattern) : + +PROC cake shade (REAL CONST x offset, y offset, radius, start angle, + sweep angle, pattern) : + +PROC cake frame (REAL CONST x offset, y offset, radius, start angle, + sweep angle, line width) : + + + + + + diff --git a/system/printer-laser/4/source-disk b/system/printer-laser/4/source-disk new file mode 100644 index 0000000..d21e78b --- /dev/null +++ b/system/printer-laser/4/source-disk @@ -0,0 +1 @@ +grundpaket/08_std.printer_laser.img diff --git a/system/printer-laser/4/src/fonttab.apple.laserwriter b/system/printer-laser/4/src/fonttab.apple.laserwriter Binary files differnew file mode 100644 index 0000000..bee2d6a --- /dev/null +++ b/system/printer-laser/4/src/fonttab.apple.laserwriter diff --git a/system/printer-laser/4/src/fonttab.canon.lbp-8 b/system/printer-laser/4/src/fonttab.canon.lbp-8 Binary files differnew file mode 100644 index 0000000..45314ac --- /dev/null +++ b/system/printer-laser/4/src/fonttab.canon.lbp-8 diff --git a/system/printer-laser/4/src/fonttab.epson.sq b/system/printer-laser/4/src/fonttab.epson.sq Binary files differnew file mode 100644 index 0000000..a3f7af3 --- /dev/null +++ b/system/printer-laser/4/src/fonttab.epson.sq diff --git a/system/printer-laser/4/src/fonttab.hp.laserjet b/system/printer-laser/4/src/fonttab.hp.laserjet Binary files differnew file mode 100644 index 0000000..4082e46 --- /dev/null +++ b/system/printer-laser/4/src/fonttab.hp.laserjet diff --git a/system/printer-laser/4/src/fonttab.kyocera.f-1010 b/system/printer-laser/4/src/fonttab.kyocera.f-1010 Binary files differnew file mode 100644 index 0000000..9c3fbda --- /dev/null +++ b/system/printer-laser/4/src/fonttab.kyocera.f-1010 diff --git a/system/printer-laser/4/src/fonttab.nec.lc-08 b/system/printer-laser/4/src/fonttab.nec.lc-08 Binary files differnew file mode 100644 index 0000000..f032953 --- /dev/null +++ b/system/printer-laser/4/src/fonttab.nec.lc-08 diff --git a/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic1 b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic1 new file mode 100644 index 0000000..fae8c09 --- /dev/null +++ b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic1 @@ -0,0 +1,30 @@ +#"!"82"! "# +#"CMNT 'dyn1.6 '; GENF 10220, 'DYNAMIC1', 22, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.6.i '; GENF 10224, 'DYNAMIC1', 22, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.8 '; GENF 10280, 'DYNAMIC1', 28, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.8.i '; GENF 10284, 'DYNAMIC1', 28, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.10 '; GENF 10340, 'DYNAMIC1', 34, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.10.i'; GENF 10344, 'DYNAMIC1', 34, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.12 '; GENF 10420, 'DYNAMIC1', 42, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.12.i'; GENF 10424, 'DYNAMIC1', 42, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.14 '; GENF 10500, 'DYNAMIC1', 50, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "# +#"CMNT 'dyn1.14.b'; GENF 10502, 'DYNAMIC1', 50, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "# +#"CMNT 'dyn1.18.b'; GENF 10682, 'DYNAMIC1', 68, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "# +#"CMNT 'dyn1.24.b'; GENF 10922, 'DYNAMIC1', 92, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "# +#"CMNT 'dyn1.36.b'; GENF 11322, 'DYNAMIC1', 132, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "# +#"MAP 0, 0; EXIT;"# + +#type ("dyn1.6") #\#type("dyn1.6")\# +#type ("dyn1.6.i") #\#type("dyn1.6.i")\# +#type ("dyn1.8") #\#type("dyn1.8")\# +#type ("dyn1.8.i") #\#type("dyn1.8.i")\# +#type ("dyn1.10") #\#type("dyn1.10")\# +#type ("dyn1.10.i")#\#type("dyn1.10.i")\# +#type ("dyn1.12") #\#type("dyn1.12")\# +#type ("dyn1.12.i")#\#type("dyn1.12.i")\# +#type ("dyn1.14") #\#type("dyn1.14")\# +#type ("dyn1.14.b")#\#type("dyn1.14.b")\# +#type ("dyn1.18.b")#\#type("dyn1.18.b")\# +#type ("dyn1.24.b")#\#type("dyn1.24.b")\# +#type ("dyn1.36.b")#\#type("dyn1.36.b")\# + diff --git a/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic2 b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic2 new file mode 100644 index 0000000..f425a7f --- /dev/null +++ b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic2 @@ -0,0 +1,30 @@ +#"!"82"! "# +#"CMNT 'dyn2.6 '; GENF 20200, 'DYNAMIC2', 20, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.6.i '; GENF 20204, 'DYNAMIC2', 20, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.8 '; GENF 20260, 'DYNAMIC2', 26, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.8.i '; GENF 20264, 'DYNAMIC2', 26, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.10 '; GENF 20320, 'DYNAMIC2', 32, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.10.i'; GENF 20324, 'DYNAMIC2', 32, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.12 '; GENF 20400, 'DYNAMIC2', 40, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.12.i'; GENF 20404, 'DYNAMIC2', 40, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.14 '; GENF 20480, 'DYNAMIC2', 48, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "# +#"CMNT 'dyn2.14.b'; GENF 20482, 'DYNAMIC2', 48, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "# +#"CMNT 'dyn2.18.b'; GENF 20662, 'DYNAMIC2', 66, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "# +#"CMNT 'dyn2.24.b'; GENF 20902, 'DYNAMIC2', 90, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "# +#"CMNT 'dyn2.36.b'; GENF 21302, 'DYNAMIC2', 130, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "# +#"MAP 0, 0; EXIT;"# + +#type ("dyn2.6") #\#type("dyn2.6")\# +#type ("dyn2.6.i") #\#type("dyn2.6.i")\# +#type ("dyn2.8") #\#type("dyn2.8")\# +#type ("dyn2.8.i") #\#type("dyn2.8.i")\# +#type ("dyn2.10") #\#type("dyn2.10")\# +#type ("dyn2.10.i")#\#type("dyn2.10.i")\# +#type ("dyn2.12") #\#type("dyn2.12")\# +#type ("dyn2.12.i")#\#type("dyn2.12.i")\# +#type ("dyn2.14") #\#type("dyn2.14")\# +#type ("dyn2.14.b")#\#type("dyn2.14.b")\# +#type ("dyn2.18.b")#\#type("dyn2.18.b")\# +#type ("dyn2.24.b")#\#type("dyn2.24.b")\# +#type ("dyn2.36.b")#\#type("dyn2.36.b")\# + diff --git a/system/printer-laser/4/src/laser.inserter b/system/printer-laser/4/src/laser.inserter new file mode 100644 index 0000000..c28766f --- /dev/null +++ b/system/printer-laser/4/src/laser.inserter @@ -0,0 +1,275 @@ +PACKET laserdrucker inserter DEFINES treiber einrichten : + +(**************************************************************************) +(* Installationsprogramm Stand : 12.12.88 *) +(* für Tintenstrahl- Version : 0.9 *) +(* und Laserdrucker Autor : hjh *) +(**************************************************************************) + +LET anzahl firmen = 6 ; +LET apple = "APPLE" , + canon = "CANON" , + epson = "EPSON" , + hp = "HEWLETT PACKARD" , + kyo = "KYOCERA" , + nec = "NEC" ; + +THESAURUS VAR firmen := empty thesaurus ; + +INT VAR i ; +ROW anzahl firmen THESAURUS VAR drucker ; +FOR i FROM 1 UPTO anzahl firmen REP + drucker (i) := empty thesaurus +PER ; +ROW anzahl firmen THESAURUS VAR printer ; +FOR i FROM 1 UPTO anzahl firmen REP + printer (i) := empty thesaurus +PER ; +ROW anzahl firmen THESAURUS VAR fonttables ; +FOR i FROM 1 UPTO anzahl firmen REP + fonttables (i) := empty thesaurus +PER ; + +liste (apple,"LASERWRITER","printer.apple.laserwriter","fonttab.apple.laserwriter"); +liste (canon , "LBP-8" ,"printer.canon.lbp-8" ,"fonttab.canon.lbp-8"); +liste (epson , "SQ 2500" ,"printer.epson.sq" ,"fonttab.epson.sq"); +liste (hp , "HP LASERJET" ,"printer.hp.laserjet" ,"fonttab.hp.laserjet"); +liste (hp , "HP LASERJET+" ,"printer.hp.laserjet" ,"fonttab.hp.laserjet"); +liste (kyo , "F-1010" ,"printer.kyocera.f-1010" ,"fonttab.kyocera.f-1010"); +liste (kyo , "F-2200" ,"printer.kyocera.f-1010" ,"fonttab.kyocera.f-1010"); +liste (nec , "SILENTWRITER LC-08" ,"printer.nec.lc-08" +,"fonttab.nec.lc-08"); + +treiber einrichten; + +PROC liste (TEXT CONST firmenname, druckername , + printername, fonttabname ) : + INT VAR firmnum ; + IF firmen CONTAINS firmenname + THEN firmnum := link (firmen,firmenname) + ELSE insert (firmen,firmenname,firmnum) + FI; + insert (drucker(firmnum), druckername) ; + insert (printer(firmnum), printername) ; + insert (fonttables(firmnum), fonttabname) ; +END PROC liste ; + +PROC treiber einrichten : + INT VAR menu phase := 1 ; + BOOL VAR installed := FALSE ; + BOOL VAR was esc ; + INT VAR firmnum, druckernum ; + TEXT VAR firmenname, druckername, printername, fonttabname ; + + pre menu ; + REP + SELECT menu phase OF + CASE 1 : menu ("Hauptmenü Tintenstrahl und Laserdrucker", firmen, + "CR: Eingabe ESC : Installation abrechen", + firmnum, was esc ) ; + IF was esc + THEN menu phase := 0 + ELSE menu phase := 2 ; + firmenname := name (firmen,firmnum) ; + FI ; + + CASE 2 : menu (firmenname + " - Menü", drucker(firmnum), + "CR: Eingabe ESC : Zurück zum Hauptmenü", + druckernum, was esc) ; + IF was esc + THEN menu phase := 1 + ELSE menu phase := 3 ; + druckername := name (drucker(firmnum),druckernum); + printername := name (printer(firmnum),druckernum); + fonttabname := name (fonttables(firmnum),druckernum); + FI; + + CASE 3 : inst (druckername, printername, fonttabname, installed) ; + IF NOT installed THEN menu phase := 1 FI; + END SELECT + UNTIL installed OR abbruch PER ; + post menu. + + abbruch: + menu phase < 1 . + + pre menu: + line; + IF is single task system + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") + FI; + IF NOT is system task (myself) + THEN errorstop ("Die Druckertask muß im Systemzweig angelegt werden") + FI; + command dialogue (TRUE); + IF name (myself) <> "PRINTER" + THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ + + name (myself) + """ !"); + IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?") + THEN rename myself ("PRINTER") + FI + FI. + + is single task system: (pcb (9) AND 255) = 1. + + post menu: + IF NOT installed + THEN page; + putline ("Es ist kein Druckertreiber installiert worden!"); + line; + putline ("Wenn dieses Installationsprogramm insertiert wurde,"); + putline ("kann es in der Task """ + name (myself) + """ "); + putline ("mit 'treiber einrichten' erneut aufgerufen werden."); + line; + FI. + +END PROC treiber einrichten ; + +PROCEDURE menu (TEXT CONST header, THESAURUS CONST items, TEXT CONST bottom, + INT VAR choice, BOOL VAR was esc) : + INT VAR anzahl ; + page; + headline (header) ; + show list (items,anzahl) ; + bottomline (bottom) ; + ask user (anzahl,choice,was esc); +END PROC menu ; + +PROC headline (TEXT CONST header): + cursor (13,1); + putline ("E U M E L - Druckertreiber - Installations - Programm"); + cursor (40 - LENGTH header DIV 2, 2); + IF header <> "" THEN put (header) FI ; + line (2) +END PROC headline; + +PROC bottomline (TEXT CONST bottom): + cursor (1,24); + IF bottom <> "" THEN put (""5"" + bottom) FI ; +END PROC bottomline; + +PROC show list (THESAURUS CONST items , INT VAR anzahl ) : + INT VAR i ; + anzahl := highest entry (items); + FOR i FROM 1 UPTO anzahl REP + putline ( text(i) + ". " + name (items,i) ) ; + PER; +END PROC show list ; + +PROC ask user (INT CONST max choice, INT VAR choice, BOOL VAR was esc): + TEXT VAR exit; + TEXT VAR inp := ""; + REP + cursor (1,23); + IF inp = "" + THEN put ("Ihre Wahl (Nummer eingeben):") + ELSE put ("FEHLER! Eingabe korrigieren:") + FI; + editget (inp, ""27"", "", exit); + was esc := exit = ""27""; + UNTIL was esc OR ok PER. + + ok: + choice := int (inp) ; + last conversion ok CAND ( choice > 0 AND choice <= max choice) . +END PROC ask user; + +BOOL PROC is system task (TASK CONST task): + TASK VAR tsk := task ; + WHILE NOT (tsk = supervisor OR tsk = niltask) REP + tsk := father (tsk) ; + PER; + tsk = supervisor +END PROC is system task ; + +PROC inst (TEXT CONST druckername, printername, fonttabname, + BOOL VAR success) : + page ; + headline (druckername) ; + fetch from archive if necessary ((empty thesaurus + + printer name + fonttab name) - all ,success); + IF success AND ok + THEN page ; + putline ("Der Drucker wird insertiert"); + insert (printer name) ; + ELSE success := FALSE ; + FI. + +ok: + bottomline (" "); + yes ("Soll der ausgewählte Drucker insertiert werden"). + +END PROC inst ; + +PROC fetch from archive if necessary (THESAURUS CONST files, + BOOL VAR success ): + BOOL VAR was esc ; + THESAURUS VAR thes :: files; + + WHILE highest entry (thes) > 0 REP + ask for archive; + IF NOT was esc + THEN disable stop ; + bottomline ("Bitte warten ! "); + reserve archive; + IF NOT is error + THEN IF highest entry (thes / ALL archive) > 0 + THEN fetch (thes / ALL archive, archive); + ELSE fehler ("Dateien nicht gefunden") + FI; + thes := thes - all; + FI; + IF is error + THEN fehler (errormessage); + clear error + FI; + command dialogue (FALSE); + release (archive); + command dialogue (TRUE); + enable stop ; + FI; + UNTIL was esc PER; + success := highest entry (thes) = 0. + +ask for archive: + headline ("") ; + putline ("Bitte Archiv mit den Dateien"); + TEXT VAR buffer; + INT VAR index :: 0; + REP + get (thes, buffer, index); + putline (" " + buffer) + UNTIL index = 0 PER; + putline ("einlegen !"); + bottomline ("CR: Wenn Archiv eingelegt ESC : Zurück zum Hauptmenü"); + cursor (1,24); + REP + inchar (buffer) ; + UNTIL buffer = ""13"" OR buffer = ""27"" PER ; + was esc := buffer = ""27"". + +reserve archive : + INT VAR p1, p2; + archive (" "31" "); + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI. + +END PROC fetch from archive if necessary ; + +PROC fehler (TEXT CONST fehlermeldung): + bottomline (""7"" + fehlermeldung + " Bitte eine Taste drücken") ; + pause ; + bottomline (" ") ; +END PROC fehler; + +END PACKET laserdrucker inserter; + diff --git a/system/printer-laser/4/src/printer.apple.laserwriter b/system/printer-laser/4/src/printer.apple.laserwriter new file mode 100644 index 0000000..d4c6adf --- /dev/null +++ b/system/printer-laser/4/src/printer.apple.laserwriter @@ -0,0 +1,770 @@ +PACKET apple laser writer printer + +(**************************************************************************) +(* Stand : 24.02.88 *) +(* APPLE LaswerWriter (PostScript) Verison : 4 *) +(* Autor : Rudolf Ruland *) +(**************************************************************************) + + DEFINES open, + close, + execute, + + paper size, + paper x size, + paper y size, + + load positioning procs, + load underline procs, + load italics procs, + load encoding, + + read ps input, + + box commands, + insert box command, + delete box command, + + print error, + : + +LET +(* underline = 1, + bold = 2, + italics = 4, + reverse = 8, +*) + underline linetype = 1, + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8, + + ps input name = "PostScript.input", + ps error = 999, + + tag type = 1; + +INT VAR paper length, font no, underline no, symbol type; +REAL VAR x size, y size; +BOOL VAR is landscape; +TEXT VAR record, char, command, symbol; +FILE VAR ps input; +THESAURUS VAR box cmds := empty thesaurus; + +(*********************************************************************) + +paper size (21.0, 29.7); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + +REAL PROC paper x size : x size END PROC paper x size; + +REAL PROC paper y size : y size END PROC paper y size; + + +THESAURUS PROC box commands : box cmds END PROC box commands; + +PROC insert box command (TEXT CONST new command) : + + command := new command; + change all (command, " ", ""); + insert (box cmds, command) + +END PROC insert box command; + +PROC delete box command (TEXT CONST old command) : + + INT VAR dummy; + command := old command; + change all (command, " ", ""); + delete (box cmds, command, dummy) + +END PROC delete box command; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0 + THEN is landscape := TRUE; + x steps := x step conversion ( y size ); + y steps := y step conversion ( x size ); + ELSE is landscape := FALSE; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + FI; + forget (ps input name, quiet); + ps input := sequential file (output, ps input name); + paper length := y steps; + font no := 0; + underline no := 0; + disable stop; + out (""4""); + read ps input (ps input, 18000, ""4""); + clear error; + enable stop; + out ("initgraphics erasepage statusdict /waittimeout 3000 put "); + load positioning procs; + load underline procs; + load italics procs; + load encoding; + read ps input (ps input, 0, ""); + +. x start : param1 +. y start : param2 +. + open page : + x start := 0; + y start := 0; + IF pos (material, "tray") > 0 + THEN out ("statusdict /manualfeed false put "); + ELIF pos (material, "manual") > 0 + THEN out ("statusdict /manualfeed true put statusdict /manualfeedtimeout 3600 put "); + FI; + IF material contains a number + THEN out ("/#copies "); out (number); out ("def "); + FI; + IF is landscape + THEN out (paper length); + out ("ys 0 translate 90 rotate "); + FI; + read ps input (ps input, 0, ""); + + . material contains a number : + INT VAR number := pos (material, "0", "9", 1); + IF number = 0 + THEN FALSE + ELSE number := max (1, int (subtext (material, number, number + 1))); + TRUE + FI + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page + OTHERWISE : put (param1) +END SELECT; + +. + close document : + disable stop; + out (""4""); + read ps input (ps input, 18000, ""4""); + + +(*. remaining y steps : param1*) +. + close page : + outline ("showpage"); + read ps input (ps input, 0, ""); + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + out ("("); + out subtext (string, from, to); + out (") show "); +. + write cmd : + command := subtext (string, from, to); + IF is box cmd + THEN disable stop; + do (command); + clear error; + ELSE out (command); + out (" "); + FI; + + . is box cmd : + scan (command); + next symbol (symbol, symbol type); + (symbol type = tag type) CAND (box cmds CONTAINS symbol) + + +(*. x steps to left margin : param1*) +. + carriage return : + move to (0, y pos); + line; + read ps input (ps input, 0, ""); + + +. x steps : param1 +. y steps : param2 + +. + move : + move to (x pos, y pos); + +. + draw : + IF y steps <> 0 COR x steps < 0 COR linetype <> underline linetype + THEN stop + ELSE IF underline no <> font no THEN out ("lu ") FI; + out (x steps); + out ("ul "); + FI; + + +. modification : param1 +. + on : + IF on string (modification) <> "" + THEN out (on string (modification)); + out (" "); + ELSE stop + FI + +. + off : + IF off string (modification) <> "" + THEN out (off string (modification)); + out (" "); + ELSE stop + FI + + +. font nr : param1 +. + type : + font no := font nr; + out (fontstring (font nr)); + out (" /af exch def af setfont "); + +END PROC execute; + + +PROC move to (INT CONST x, y) : + + out (x); out ("xs "); + out (paper length - y); out ("ys moveto "); + +END PROC move to; + + +PROC line : out (""13""10"") END PROC line; + +PROC outline (TEXT CONST string) : out (string); out (""13""10"") END PROC outline; + +PROC out (INT CONST value) : out (text (value)); out (" ") END PROC out; + +PROC out (REAL CONST value) : out (text (value)); out (" ") END PROC out; + + +PROC load positioning procs : + + out ("/xs {"); out (72.0 / 2.54 * x step conversion (1)); out ("mul} def "); + out ("/ys {"); out (72.0 / 2.54 * y step conversion (1)); out ("mul} def "); + +END PROC load positioning procs; + + +PROC load underline procs : + + out ("/ul {xs ut setlinewidth 0 up rmoveto dup gsave 0 rlineto stroke grestore up neg rmoveto} def "); + out ("/lu {af /FontMatrix get 3 get af /FontInfo get 2 copy /up 3 1 roll /UnderlinePosition get mul 3 mul def /ut 3 1 roll /UnderlineThickness get mul def} def "); + +END PROC load underline procs; + + +PROC load italics procs : + + out ("/iton {/m matrix def m 2 12 sin 12 cos div put af m makefont setfont} def "); + out ("/itoff {af setfont} def "); + +END PROC load italics procs; + + +PROC load encoding : + + out ("/reencsmalldict 12 dict def "); + out ("/ReEncodeSmall {reencsmalldict begin "); + out ("/newcodesandnames exch def /newfontname exch def /basefontname exch def "); + out ("/basefontdict basefontname findfont def /newfont basefontdict maxlength dict def "); + out ("basefontdict {exch dup /FID ne {dup /Encoding eq {exch dup length array copy newfont 3 1 roll put} {exch newfont 3 1 roll put} ifelse} {pop pop} ifelse} forall "); + out ("newfont /FontName newfontname put newcodesandnames aload pop newcodesandnames length 2 idiv {newfont /Encoding get 3 1 roll put} repeat "); + out ("newfontname newfont definefont pop "); + out ("end} def "); + out ("/eumelencoding[10#128 /Ccedilla 10#129 /udieresis 10#128 /Ccedilla 10#129 /udieresis "); + out ("10#130 /eacute 10#131 /acircumflex 10#132 /adieresis 10#133 /agrave 10#134 /aring 10#135 /ccedilla 10#136 /ecircumflex 10#137 /edieresis 10#138 /egrave 10#139 /idieresis "); + out ("10#140 /icircumflex 10#141 /igrave 10#142 /Adieresis 10#143 /Aring 10#144 /Eacute 10#145 /ae 10#146 /AE 10#147 /ocircumflex 10#148 /odieresis 10#149 /ograve "); + out ("10#150 /ucircumflex 10#151 /ugrave 10#152 /ydieresis 10#153 /Odieresis 10#154 /Udieresis 10#155 /cent 10#156 /sterling 10#157 /yen 10#158 /currency 10#159 /florin "); + out ("10#160 /aacute 10#161 /iacute 10#162 /oacute 10#163 /uacute 10#164 /ntilde 10#165 /Ntilde 10#166 /ordfeminine 10#167 /ordmasculine 10#168 /questiondown 10#169 /quotedblleft "); + out ("10#170 /quotedblright 10#171 /guilsinglleft 10#172 /guilsinglright 10#173 /exclamdown 10#174 /guillemotleft 10#175 /guillemotright 10#176 /atilde 10#177 /otilde 10#178 /Oslash 10#179 /oslash "); + out ("10#180 /oe 10#181 /OE 10#182 /Agrave 10#183 /Atilde 10#184 /Otilde 10#185 /section 10#186 /daggerdbl 10#187 /dagger 10#188 /paragraph 10#189 /space "); + out ("10#190 /space 10#191 /space 10#192 /quotedblbase 10#193 /ellipsis 10#194 /perthousand 10#195 /bullet 10#196 /endash 10#197 /emdash 10#198 /space 10#199 /Aacute "); + out ("10#200 /Acircumflex 10#201 /Egrave 10#202 /Ecircumflex 10#203 /Edieresis 10#204 /Igrave 10#205 /Iacute 10#206 /Icircumflex 10#207 /Idieresis 10#208 /Ograve 10#209 /Oacute "); + out ("10#210 /Ocircumflex 10#211 /Scaron 10#212 /scaron 10#213 /Ugrave 10#214 /Adieresis 10#215 /Odieresis 10#216 /Udieresis 10#217 /adieresis 10#218 /odieresis 10#219 /udieresis "); + out ("10#220 /k 10#221 /hyphen 10#222 /numbersign 10#223 /space 10#224 /grave 10#225 /acute 10#226 /circumflex 10#227 /tilde 10#228 /dieresis 10#229 /ring "); + out ("10#230 /cedilla 10#231 /caron 10#232 /Lslash 10#233 /Oslash 10#234 /OE 10#235 /ordmasculine 10#236 /Uacute 10#237 /Ucircumflex 10#238 /Ydieresis 10#239 /germandbls "); + out ("10#240 /Zcaron 10#241 /zcaron 10#242 /fraction 10#243 /ae "); + out ("10#251 /germandbls 10#252 /section] def "); + out ("/Helvetica /EHelvetica eumelencoding ReEncodeSmall "); + out ("/Helvetica-Bold /EHelvetica-Bold eumelencoding ReEncodeSmall "); + out ("/Helvetica-Oblique /EHelvetica-Oblique eumelencoding ReEncodeSmall "); + out ("/Helvetica-BoldOblique /EHelvetica-BoldOblique eumelencoding ReEncodeSmall "); + out ("/Times-Roman /ETimes-Roman eumelencoding ReEncodeSmall "); + out ("/Times-Bold /ETimes-Bold eumelencoding ReEncodeSmall "); + out ("/Times-Italic /ETimes-Italic eumelencoding ReEncodeSmall "); + out ("/Times-BoldItalic /ETimes-BoldItalic eumelencoding ReEncodeSmall "); + out ("/Courier /ECourier eumelencoding ReEncodeSmall "); + out ("/Courier-Oblique /ECourier-Oblique eumelencoding ReEncodeSmall "); + out ("/Courier-BoldOblique /ECourier-BoldOblique eumelencoding ReEncodeSmall "); + out ("/Courier-Bold /ECourier-Bold eumelencoding ReEncodeSmall "); + line; + +END PROC load encoding; + + +PROC read ps input (FILE VAR input file, INT CONST timeout, TEXT CONST ok) : + + BOOL VAR was cr; + record := ""; + was cr := FALSE; + char := incharety (timeout); + REP IF char = ""10"" CAND was cr + THEN put record; + was cr := FALSE; + ELIF char = ""13"" CAND NOT was cr + THEN was cr := TRUE; + ELSE IF was cr + THEN record CAT """13"""; + was cr := FALSE; + FI; + IF char = ""4"" + THEN IF record <> "" THEN put record FI; + putline (input file, "-- EOF --"); + line (input file); + ELIF char >= " " + THEN record CAT char + ELIF char >= ""0"" + THEN record CAT """"; + record CAT text (code (char)); + record CAT """"; + ELSE IF record <> "" THEN put record FI; + LEAVE read ps input; + FI; + FI; + IF pos (ok, char) > 0 + THEN IF record <> "" THEN put record FI; + LEAVE read ps input; + FI; + cat input (record, char); + IF char = "" THEN char := incharety (min (5, time out)) FI; + PER; + + . put record : + putline (input file, record); + IF NOT is error CAND pos (record, "%%[ Error:") > 0 + THEN errorstop (ps error, record) FI; + record := ""; + +END PROC read ps input; + + +PROC print error (TEXT CONST error message, INT CONST error line) : + + REAL CONST pl := y size * 72.0 / 2.54, + ys := 56.69291, + xs := 51.02362, + h := 12.0; + REAL VAR x := xs, y := ys + h; + outline ("/Courier findfont 10 scalefont setfont"); + move to x and y; + out ("(FEHLER : "); + out (error message); + IF error line > 0 + THEN out (" in Zeile "); + out (error line); + FI; + outline (") show"); + IF exists (ps input name) + THEN ps input := sequential file (input, ps input name); + y INCR 3.0 * h; + move to x and y; + outline ("(PostScript - Input :) show"); + y INCR h; + WHILE NOT eof (ps input) + REP getline (ps input, record); + y INCR h; + move to x and y; + out ("("); + out (record); + outline (") show"); + PER; + output (ps input); + FI; + outline ("showpage"); + out (""4""); + read ps input (ps input, 18000, ""4""); + + . move to x and y : + out (x); out (pl - y); out ("moveto "); + +END PROC print error; + + +END PACKET apple laser writer printer; + + +PACKET apple laserwriter box commands + +(**************************************************************************) +(* *) +(* Kommandos zum Zeichen von Boxen, Linien und Schraffuren *) +(* für den Apple LaserWriter *) +(* *) +(* Autor : Rudolf Ruland *) +(* Stand : 24.02.88 *) +(**************************************************************************) + + DEFINES line, + x line, + y line, + + box, + box frame, + box shade, + + cake, + cake frame, + cake shade, + : + +INT VAR x, y, h, w; + +WHILE highest entry (box commands) > 0 + REP delete box command (name (box commands, highest entry (box commands))) PER; +insert box command ("line"); +insert box command ("xline"); +insert box command ("yline"); +insert box command ("box"); +insert box command ("boxshade"); +insert box command ("boxframe"); +insert box command ("cake"); +insert box command ("cakeshade"); +insert box command ("cakeframe"); + + +PROC line (REAL CONST x offset, y offset, width, height, line width) : + + IF line width > 0.0 + THEN graph on (x offset, y offset, width, height); + out (text (line width / 300.0 * 72.0)); + out (" setlinewidth "); + out (text (w)); + out (" xs "); + out (text (-h)); + out (" ys rlineto stroke "); + graph off; + FI; + +END PROC line; + +PROC x line (REAL CONST x offset, y offset, width, line width) : + + line (x offset, y offset, width, 0.0, line width); + +END PROC x line; + +PROC y line (REAL CONST x offset, y offset, height, line width) : + + line (x offset, y offset, 0.0, height, line width); + +END PROC y line; + + +PROC box (REAL CONST x offset, y offset, width, height, line width, pattern): + + box shade (x offset, y offset, width, height, pattern); + box frame (x offset, y offset, width, height, line width); + +END PROC box; + + +PROC box shade (REAL CONST x offset, y offset, width, height, pattern) : + + graph on (x offset, y offset, width, height); + box path; + out (text (pattern)); + out (" setgray fill "); + graph off; + +END PROC box shade; + + +PROC box frame (REAL CONST x offset, y offset, width, height, line width) : + + IF line width <> 0.0 + THEN graph on (x offset, y offset, width, height); + box path; + out (text (line width / 300.0 * 72.0)); + out (" setlinewidth stroke "); + graph off; + FI; + +END PROC box frame; + + +PROC box path : + + out (text (w)); + out (" xs 0 rlineto 0 "); + out (text (-h)); + out (" ys rlineto "); + out (text (-w)); + out (" xs 0 rlineto closepath "); + +END PROC box path; + + + +PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle, line width, pattern) : + + cake shade (x offset, y offset, radius, start angle, sweep angle, pattern); + cake frame (x offset, y offset, radius, start angle, sweep angle, line width); + +END PROC cake; + + +PROC cake shade (REAL CONST x offset, y offset, radius, start angle, sweep angle, pattern) : + + graph on (x offset, y offset, radius, 0.0); + cake path (start angle, sweep angle); + out (text (pattern)); + out (" setgray fill "); + graph off; + +END PROC cake shade; + + +PROC cake frame (REAL CONST x offset, y offset, radius, start angle, sweep angle, line width) : + + + IF line width <> 0.0 + THEN graph on (x offset, y offset, radius, 0.0); + cake path (start angle, sweep angle); + out (text (line width / 300.0 * 72.0)); + out (" setlinewidth stroke "); + graph off; + FI; + +END PROC cake frame; + + +PROC cake path (REAL CONST start angle, sweep angle) : + + out (text (start angle)); + out (" rotate "); + out ("currentpoint "); + out (text (w)); + out (" xs 0 "); + out (text (sweep angle)); + out (" "); + IF sweep angle < 360.0 + THEN out ("2 setlinejoin arc closepath "); + ELSE out (text (w)); + out (" xs 0 rmoveto arc "); + FI; + +END PROC cake path; + + +PROC graph on (REAL CONST x offset, y offset, width, height) : + + x := x step conversion (x offset); + y := y step conversion (y offset); + w := x step conversion (width); + h := y step conversion (height); + out ("gsave "); + out (text (x)); + out (" xs "); + out (text (-y)); + out (" ys rmoveto "); + +END PROC graph on; + +PROC graph off : + + out ("grestore "); + +END PROC graph off; + + +END PACKET apple laserwriter box commands; + + + +#page# +(******************************************************************) +(*** ***) +(*** Generierung des Printers ***) +(*** ***) +(******************************************************************) +(* +LET up = ""3""13""5""; +*) +LET printer name = "printer.apple.laserwriter"; +TEXT VAR fonttab name := "fonttab.apple.laserwriter"; + +BOOL CONST multi user := (pcb (9) AND 255) <> 1; + +INT VAR pr channel; +TEXT VAR buffer; + +command dialogue (TRUE); +IF NOT multi user + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") +FI; +ask for print channel; +load font table; +forget (printer name, quiet); +IF multi user THEN generate printer spool FI; +command dialogue (TRUE); +check on; +. + ask for print channel : + line; + put ("gib Druckerkanal:"); + get (pr channel); + do ("serverchannel(" + text (pr channel) + ")" ) ; + line; +. + load font table : + IF NOT exists (fonttab name) + THEN REP line (2); + putline ("Bitte Archiv mit der Fonttabelle """ + + fonttab name + """ einlegen!"); + line; + UNTIL yes ("Archiv eingelegt") PER; + reserve archive; + fetch (fonttab name, archive); + release (archive); + FI; + font table (fonttab name); + IF multi user + THEN command dialogue (FALSE); + do ("save(""" + font tab name + """,task(""configurator""))") + FI; + forget (fonttab name, quiet); + + . reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop; + +. generate printer spool : + eumel must advertise; + cursor (1, 12); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (4); + putline ("Generierung beendet, weiter mit 'SV'"); + generate printer server; + do (buffer); + +. generate printer server : + buffer := "break (quiet);"; + buffer CAT "spool manager (PROC printer);"; + buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; + buffer CAT "PROC printer:"; + buffer CAT " disable stop;"; + buffer CAT " continue (server channel);"; + buffer CAT " check error (error message);"; + buffer CAT " ds := nilspace;"; + buffer CAT " REP forget (ds);"; + buffer CAT " execute print;"; + buffer CAT " IF is error AND online THEN clear error; print error (error message, 0); clear error FI;"; + buffer CAT " PER;"; + buffer CAT "END PROC printer;"; + buffer CAT "PROC execute print:"; + buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; + buffer CAT " enable stop;"; + buffer CAT " ds := nilspace;"; + buffer CAT " call (father, fetch code, ds, reply);"; + buffer CAT " IF reply = ack CAND type (ds) = file type"; + buffer CAT " THEN file := sequential file (input, ds);"; + buffer CAT " print (file,"; + buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; + buffer CAT " PROC (INT CONST, INT CONST) close,"; + buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; + buffer CAT " FI;"; + buffer CAT "END PROC execute print;"; + buffer CAT "PROC check error(TEXT CONST message):"; + buffer CAT " IF is error"; + buffer CAT " THEN clear error; rename myself (message);"; + buffer CAT " IF is error THEN end(myself) FI;"; + buffer CAT " pause (9000); end(myself);"; + buffer CAT " FI;"; + buffer CAT "END PROC check error;"; + diff --git a/system/printer-laser/4/src/printer.canon.lbp-8 b/system/printer-laser/4/src/printer.canon.lbp-8 new file mode 100644 index 0000000..4dfe9f8 --- /dev/null +++ b/system/printer-laser/4/src/printer.canon.lbp-8 @@ -0,0 +1,327 @@ +PACKET canon lbp 8 printer + +(*************************************************************************) +(* Stand : 29.07.86 *) +(* CANON LBP-8 A1/A2 Version : 4 *) +(* Autor : Rudolf Ruland *) +(*************************************************************************) + + + DEFINES open, + close, + execute, + + paper size : + +LET underline = 1, +(* bold = 2, + italics = 4, + reverse = 8, + + underline linetype = 1, *) + + csi = ""155"", + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8; + +REAL VAR x size, y size; +BOOL VAR is underline; + +(*********************************************************************) + +paper size (21.0, 29.7); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + is underline := FALSE; + x steps := x step conversion ( x size - 0.8043333 ); + y steps := y step conversion ( y size - 0.508); + out (""27":"27"P"13""); (* Enable - Prop.Type *) + out (""27";"27"<"155"11h"); (* Reset des Druckers *) + out (""27"(B"); (* ACSII-Zeichensatz *) + out (""155"1;4 D"); (* Char.Satz 1 = PICA *) + +. x start : param1 +. y start : param2 +. + open page : + x start := x step conversion (0.4064 ); + y start := y step conversion (0.508 + 0.6345); + out (""13""); + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page + OTHERWISE : put (param1) +END SELECT; + +. + close document : + (* out(""155"0q") von Standard-Cassette Papier holen *) + +(*. remaining y steps : param1*) +. + close page : + out (""13""12""); + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + INT VAR new from, new to; + IF is underline + THEN IF pos (string, " ", from, from) <> 0 + THEN out ("_"); + new from := from + 1; + ELSE new from := from; + FI; + IF from < to AND pos (string, " ", to, to) <> 0 + THEN new to := to - 1; + ELSE new to := to; + FI; + out subtext (string, new from, new to); + IF to <> new to THEN out ("_") FI; + ELSE out subtext (string, from, to) + FI; + +. + write cmd : + out subtext (string, from, to) + + +(*. x steps to left margin : param1*) +. + carriage return : + out (""13"") + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps > 0 + THEN out (csi); out (text ( x steps)); out ("a") + ELIF x steps < 0 + THEN out (csi); out (text (- x steps)); out ("j") + FI; + IF y steps > 0 + THEN out (csi); out (text ( y steps)); out ("e") + ELIF y steps < 0 + THEN out (csi); out (text (- y steps)); out ("k") + FI; + +. + draw : + stop + + +. modification : param1 +. + on : + IF on string (modification) <> "" + THEN out (on string (modification)); + IF modification = underline THEN is underline := TRUE FI; + ELSE stop + FI + +. + off : + IF off string (modification) <> "" + THEN out (off string (modification)); + IF modification = underline THEN is underline := FALSE FI; + ELSE stop + FI + + +. font nr : param1 +. + type : + out (font string (font nr)); + +END PROC execute; + + +END PACKET canon lbp 8 printer; + + + +#page# +(******************************************************************) +(*** ***) +(*** Generierung des Printers ***) +(*** ***) +(******************************************************************) + +LET printer name = "printer.canon.lbp-8"; + +TEXT VAR fonttab name := "fonttab.canon.lbp-8"; + +BOOL CONST multi user := (pcb (9) AND 255) <> 1; + +INT VAR pr channel; +TEXT VAR buffer; + +command dialogue (TRUE); +IF NOT multi user + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") +FI; +ask for print channel; +ask for font cartridge; +load font table; +forget (printer name, quiet); +IF multi user THEN generate printer spool FI; +check on; +. + ask for print channel : + line; + put ("gib Druckerkanal:"); + get (pr channel); + do ("serverchannel(" + text (pr channel) + ")" ) ; + line; +. + ask for font cartridge : +. + load font table : + IF NOT exists (fonttab name) + THEN command dialogue (TRUE); + REP line (2); + putline ("Bitte Archiv mit der Fonttabelle """ + + fonttab name + """ einlegen!"); + line; + UNTIL yes ("Archiv eingelegt") PER; + reserve archive; + fetch (fonttab name, archive); + release (archive); + FI; + font table (fonttab name); + IF multi user + THEN command dialogue (FALSE); + do ("save(""" + font tab name + """,task(""configurator""))") + FI; + forget (fonttab name, quiet); + + . reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop; + +. generate printer spool : + eumel must advertise; + cursor (1, 12); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (4); + putline ("Generierung beendet, weiter mit 'SV'"); + generate printer server; + do (buffer); + +. generate printer server : + buffer := "break (quiet);"; + buffer CAT "spool manager (PROC printer);"; + buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; + buffer CAT "PROC printer:"; + buffer CAT " disable stop;"; + buffer CAT " continue (server channel);"; + buffer CAT " check error (error message);"; + buffer CAT " ds := nilspace;"; + buffer CAT " REP forget (ds);"; + buffer CAT " execute print;"; + buffer CAT " IF is error AND online THEN put error; clear error; FI;"; + buffer CAT " PER;"; + buffer CAT "END PROC printer;"; + buffer CAT "PROC execute print:"; + buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; + buffer CAT " enable stop;"; + buffer CAT " ds := nilspace;"; + buffer CAT " call (father, fetch code, ds, reply);"; + buffer CAT " IF reply = ack CAND type (ds) = file type"; + buffer CAT " THEN file := sequential file (input, ds);"; + buffer CAT " print (file,"; + buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; + buffer CAT " PROC (INT CONST, INT CONST) close,"; + buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; + buffer CAT " FI;"; + buffer CAT "END PROC execute print;"; + buffer CAT "PROC check error(TEXT CONST message):"; + buffer CAT " IF is error"; + buffer CAT " THEN clear error; rename myself (message);"; + buffer CAT " IF is error THEN end(myself) FI;"; + buffer CAT " pause (9000); end(myself);"; + buffer CAT " FI;"; + buffer CAT "END PROC check error;"; + diff --git a/system/printer-laser/4/src/printer.epson.sq b/system/printer-laser/4/src/printer.epson.sq new file mode 100644 index 0000000..63e474f --- /dev/null +++ b/system/printer-laser/4/src/printer.epson.sq @@ -0,0 +1,585 @@ +PACKET epson sq printer + +(**************************************************************************) +(* Stand : 03.12.86 *) +(* EPSON SQ-2500 Version : 4 *) +(* Autor : Rudolf Ruland *) +(**************************************************************************) + + DEFINES open, + close, + execute, + + paper size, + (* paper feed, *) (* <-- nicht getestet *) + std typeface, + std quality: + +LET +(* underline = 1, + bold = 2, + italics = 4, + reverse = 8, *) + + underline linetype = 1, + + c document = 1, + c page = 2, + + c write text = 1, cmd draft = 1, + c write cmd = 2, cmd nlq = 2, + c carriage return = 3, cmd roman = 3, + c move = 4, cmd sansserif = 4, + c draw = 5, cmd courier = 5, + c on = 6, cmd prestige = 6, + c off = 7, cmd script = 7, + c type = 8; + +INT VAR font nr, x rest, high, low, font bits, modification bits, blank pitch, + factor 1, factor 2, steps; +BOOL VAR is nlq, sheet feed; +REAL VAR x size, y size; +TEXT VAR std quality name, std typeface name, buffer, symbol, font text; +THESAURUS VAR commands := empty thesaurus; + +insert (commands, "draft"); +insert (commands, "nlq"); +insert (commands, "roman"); +insert (commands, "sansserif"); +insert (commands, "courier"); +insert (commands, "prestige"); +insert (commands, "script"); + +. is prop : bit (font bits, 1) +. is double : bit (font bits, 5) +.; + +(*********************************************************************) + +paper size (13.6 * 2.54, 12.0 * 2.54); +paper size ( 8.0 * 2.54, 12.0 * 2.54); +paper feed ("tractor"); +std typeface ("roman"); +std quality ("draft"); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + + +PROC paper feed (TEXT CONST paper) : + + IF pos (paper, "sheet") <> 0 + THEN sheet feed := TRUE; + ELIF pos (paper, "tractor") <> 0 + THEN sheet feed := FALSE; + ELSE errorstop ("unzulaessige Papiereinfuehrung") + FI; + +END PROC paper feed; + +TEXT PROC paper feed : + + IF sheet feed + THEN "sheet" + ELSE "tractor" + FI + +END PROC paper feed; + + +PROC std typeface (TEXT CONST typeface) : + + buffer := typeface; + changeall (buffer, " ", ""); + IF link (commands, buffer) >= cmd roman + THEN std typeface name := buffer + ELSE errorstop ("unzulaessige Schriftart") + FI; + +END PROC std typeface; + +TEXT PROC std typeface : std typeface name END PROC std typeface; + + +PROC std quality (TEXT CONST quality) : + + IF quality = "nlq" OR quality = "draft" + THEN std quality name := quality; + ELSE errorstop ("unzulaessige Betriebsart") + FI; + +END PROC std quality; + +TEXT PROC std quality : std quality name END PROC std quality; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + y steps := (y steps DIV 30) * 30; + modification bits := 0; + out (""24""27""64""); (* Reset des Druckers *) + out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *) + out (""27"x"0""); (* Entwurfsqualität *) + out (""27"R"0""); (* Amerikanischer Zeichensatz *) + out (""27"t"1""27"6"); (* Erweiterung des Zeichensatzes *) + IF sheet feed THEN out (""27""25"4") FI; (* Sheetmode ein *) + IF pos (material, "roman") <> 0 + THEN out (""27"k"0"") + ELIF pos (material, "sansserif") <> 0 + THEN out (""27"k"1"") + ELIF pos (material, "courier") <> 0 + THEN out (""27"k"2"") + ELIF pos (material, "prestige") <> 0 + THEN out (""27"k"3"") + ELIF pos (material, "script") <> 0 + THEN out (""27"k"4"") + ELSE out (""27"k" + code (link (commands, std typeface) - cmd roman)); + FI; + IF pos (material, "nlq") <> 0 + THEN is nlq := TRUE; + ELIF pos (material, "draft") <> 0 + THEN is nlq := FALSE; + ELSE is nlq := std quality = "nlq" + FI; + + +. x start : param1 +. y start : param2 +. + open page : + x start := 0; + IF sheet feed + THEN y start := y step conversion (8.466667e-1) (* 2/6 Inch *) + ELSE y start := 0; + FI; + x rest := 0; + out (""13""); + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page +END SELECT; + +. + close document : + + +. remaining y steps : param1 +. + close page : + IF sheet feed + THEN out (""27""25"R") + ELIF remaining y steps > 0 + THEN out (""12"") + FI; + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + out subtext (string, from, to) + +. + write cmd : + buffer := subtext (string, from, to); + scan (buffer); + next symbol (symbol); + SELECT link (commands, symbol) OF + CASE cmd draft : IF is nlq THEN switch to draft FI; is nlq := FALSE; + CASE cmd nlq : IF NOT is nlq THEN switch to nlq FI; is nlq := TRUE; + CASE cmd roman : out (""27"k"0"") + CASE cmd sansserif : out (""27"k"1"") + CASE cmd courier : out (""27"k"2"") + CASE cmd prestige : out (""27"k"3"") + CASE cmd script : out (""27"k"4"") + OTHERWISE : out (buffer); + END SELECT; + + +(*. x steps to left margin : param1*) +. + carriage return : + x rest := 0; + out (""13""); + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps < 0 OR y steps < 0 + THEN stop + ELSE IF x steps > 0 THEN x move FI; + IF y steps > 0 THEN y move FI; + FI; + + . x move : + x rest INCR x steps; + IF not is underline + THEN simple x move + ELSE underline x move + FI; + + . not is underline : + NOT bit (modification bits, 7) + + . simple x move : + high := x rest DIV factor 1; + x rest := x rest MOD factor 1; + out (""27"\"); + out (code (high MOD 256)); + out (code (high DIV 256)); + + . underline x move : + high := x rest DIV factor 2; + x rest := x rest MOD factor 2; + IF high < blank pitch + THEN stop + ELSE low := high MOD 127; + high := high DIV 127; + IF low >= blank pitch + THEN low DECR blankpitch; + ELSE high DECR 1; + low DECR (blankpitch - 127); + FI; + IF high > 0 + THEN out (""27" "); + out (code (127 - blankpitch)); + high TIMESOUT " "; + FI; + out (""27" "); + out (code (low)); + out (" "27" "0""); + FI; + + . y move : + low := y steps MOD 255; + high := y steps DIV 255; + IF high > 0 THEN high TIMESOUT (""27"J"255"") FI; + IF low > 0 THEN out (""27"J"); out (code (low)) FI; +. + draw : + IF x steps < 0 OR y steps <> 0 OR linetype <> underline linetype + THEN stop + ELIF x steps > 0 + THEN x draw + FI; + + . x draw : + x rest INCR x steps; + steps := x rest DIV 6; + x rest := x rest MOD 6; + IF steps > 0 + THEN low := steps MOD 256; + high := steps DIV 256; + out (""27"L"); + out (code (low)); + out (code (high)); + steps TIMESOUT ""1""; + FI; + + +. modification : param1 +. + on : + buffer := on string (modification); + IF buffer <> "" + THEN modification bits := modification bits OR code (buffer); + switch to font; + ELSE stop + FI + +. + off : + buffer := off string (modification); + IF buffer <> "" + THEN modification bits := modification bits XOR code (buffer); + switch to font; + ELSE stop + FI + +. + type : + font nr := param1; + buffer := font string (font nr); + font bits := code (buffer SUB 1); + font text := subtext (buffer, 2); + IF is prop + THEN factor 1 := 4; + factor 2 := 4; + ELSE factor 1 := 6; + factor 2 := 6; + FI; + IF is double THEN factor 2 INCR factor 2 FI; + blank pitch := char pitch (font nr, " ") DIV factor 2; + switch to font; + IF is nlq THEN switch to nlq FI; + +END PROC execute; + + +PROC switch to font : + + out (""27"!"); + out (code (font bits OR modification bits)); + out (font text); + +END PROC switch to font; + + +PROC switch to nlq : + + IF NOT is prop + THEN factor 1 := 4; + factor 2 := (4 * factor 2) DIV 6; + blankpitch := (6 * blankpitch) DIV 4; + out (""27"x"1""); + ELSE out (""27"x"0""); + FI; + +END PROC switch to nlq; + + +PROC switch to draft : + + IF NOT is prop + THEN factor 1 := 6; + factor 2 := (6 * factor 2) DIV 4; + blankpitch := (4 * blankpitch) DIV 6; + out (""27"x"0""); + FI; + +END PROC switch to draft; + + +END PACKET epson sq printer; + + + +#page# +(******************************************************************) +(*** ***) +(*** Generierung des Printers ***) +(*** ***) +(******************************************************************) + +LET printer name = "printer.epson.sq", + up = ""3""13""5""; + +TEXT VAR fonttab name := "fonttab.epson.sq"; + +BOOL CONST multi user := (pcb (9) AND 255) <> 1; + +INT VAR pr channel; +TEXT VAR buffer; + +command dialogue (TRUE); +IF NOT multi user + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") +FI; +ask for print channel; +ask for paper format; +ask for typeface; +ask for print quality; +load font table; +forget (printer name, quiet); +IF multi user THEN generate printer spool FI; +check on; +. + ask for print channel : + line; + put ("gib Druckerkanal:"); + get (pr channel); + do ("serverchannel(" + text (pr channel) + ")" ) ; + line; +. + ask for paper format : + SELECT paper format OF + CASE 1 : papersize ( 8.0 * 2.54, 12.0 * 2.54) + CASE 2 : papersize (13.6 * 2.54, 12.0 * 2.54) + CASE 3 : papersize (21.0, 29.7) + END SELECT + + . paper format : + line; + REP out (up); + IF yes ("Papierformat : endlos, 8 Zoll breit") + THEN LEAVE paper format WITH 1 FI; + out (up); + IF yes ("Papierformat : endlos, 13.6 Zoll breit") + THEN LEAVE paper format WITH 2 FI; + out (up); + IF yes ("Papierformat : DINA 4") + THEN LEAVE paper format WITH 3 FI; + PER; + 0 +. + ask for typeface : + line; + std typeface (typeface) + + . typeface : + REP out (up); + IF yes ("standardmäßige Schriftart : roman") + THEN LEAVE typeface WITH "roman" FI; + out (up); + IF yes ("standardmäßige Schriftart : sansserif") + THEN LEAVE typeface WITH "sansserif" FI; + out (up); + IF yes ("standardmäßige Schriftart : courier") + THEN LEAVE typeface WITH "courier" FI; + out (up); + IF yes ("standardmäßige Schriftart : prestige") + THEN LEAVE typeface WITH "prestige" FI; + out (up); + IF yes ("standardmäßige Schriftart : script") + THEN LEAVE typeface WITH "script" FI; + PER; + "" +. + ask for print quality : + line; + std quality (quality); + + . quality : + REP out (up); + IF yes ("standardmäßige Druckqualität : draft quality") + THEN LEAVE quality WITH "draft" FI; + out (up); + IF yes ("standardmäßige Druckqualität : near letter quality") + THEN LEAVE quality WITH "nlq" FI; + PER; + "" +. + load font table : + IF NOT exists (fonttab name) + THEN command dialogue (TRUE); + REP line (2); + putline ("Bitte Archiv mit der Fonttabelle """ + + fonttab name + """ einlegen!"); + line; + UNTIL yes ("Archiv eingelegt") PER; + reserve archive; + fetch (fonttab name, archive); + release (archive); + FI; + font table (fonttab name); + IF multi user + THEN command dialogue (FALSE); + do ("save(""" + font tab name + """,task(""configurator""))") + FI; + forget (fonttab name, quiet); + + . reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop; + +. generate printer spool : + eumel must advertise; + cursor (1, 12); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (4); + putline ("Generierung beendet, weiter mit 'SV'"); + generate printer server; + do (buffer); + +. generate printer server : + buffer := "break (quiet);"; + buffer CAT "spool manager (PROC printer);"; + buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; + buffer CAT "PROC printer:"; + buffer CAT " disable stop;"; + buffer CAT " continue (server channel);"; + buffer CAT " check error (error message);"; + buffer CAT " ds := nilspace;"; + buffer CAT " REP forget (ds);"; + buffer CAT " execute print;"; + buffer CAT " IF is error AND online THEN put error; clear error; FI;"; + buffer CAT " PER;"; + buffer CAT "END PROC printer;"; + buffer CAT "PROC execute print:"; + buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; + buffer CAT " enable stop;"; + buffer CAT " ds := nilspace;"; + buffer CAT " call (father, fetch code, ds, reply);"; + buffer CAT " IF reply = ack CAND type (ds) = file type"; + buffer CAT " THEN file := sequential file (input, ds);"; + buffer CAT " print (file,"; + buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; + buffer CAT " PROC (INT CONST, INT CONST) close,"; + buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; + buffer CAT " FI;"; + buffer CAT "END PROC execute print;"; + buffer CAT "PROC check error(TEXT CONST message):"; + buffer CAT " IF is error"; + buffer CAT " THEN clear error; rename myself (message);"; + buffer CAT " IF is error THEN end(myself) FI;"; + buffer CAT " pause (9000); end(myself);"; + buffer CAT " FI;"; + buffer CAT "END PROC check error;"; + diff --git a/system/printer-laser/4/src/printer.hp.laserjet b/system/printer-laser/4/src/printer.hp.laserjet new file mode 100644 index 0000000..152ee8e --- /dev/null +++ b/system/printer-laser/4/src/printer.hp.laserjet @@ -0,0 +1,417 @@ +PACKET hp laserjet printer + +(**************************************************************************) +(* Stand : 03.02.88 *) +(* HP 2686A LaserJet / LaserJet+ Verison : 4 *) +(* Autor : Rudolf Ruland *) +(**************************************************************************) + + DEFINES open, + close, + execute, + + paper size, + printer type : + +LET +(* underline = 1, + bold = 2, + italics = 4, + reverse = 8, + + underline linetype = 1, *) + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8; + +INT VAR abs x pos +REAL VAR x size, y size; +BOOL VAR is laser jet plus, is landscape; + +(*********************************************************************) + +paper size (21.0, 29.7); +printer type ("LaserJet"); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + +PROC printer type (TEXT CONST type) : + + is laser jet plus := pos (type, "+") <> 0 + +END PROC printer type; + +TEXT PROC printer type : + + IF is laser jet plus + THEN "LaserJet+" + ELSE "LaserJet" + FI + +END PROC printer type; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + out (""27"E"); (* Reset des Druckers *) + out (""27"&s1C"); (* 'end of line wrap' aus *) + out (""27"&l0L"); (* 'perforation skip' aus *) + out (""27"&l1X"); (* eine Kopie *) + out (""27"&l1H"); (* upper tray *) + IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0 + THEN is landscape := TRUE; + x steps := x step conversion ( y size ); + y steps := y step conversion ( x size ); + out (""27"&l1O"); + ELSE is landscape := FALSE; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + FI; + +. x start : param1 +. y start : param2 +. + open page : + IF is landscape + THEN x start := x step conversion (0.508); (* 0.200*2.54 *) + y start := y step conversion (1.693333); (* 0.500*2.54 + 2.54/6.0 *) + ELSE x start := x step conversion (0.39878); (* 0.157*2.54 *) + y start := y step conversion (1.693333); (* 0.500*2.54 + 2.54/6.0 *) + FI; + IF pos (material, "lower tray") > 0 COR pos (material, "lowertray") > 0 + THEN out (""27"&l4H"); + ELIF pos (material, "tray") > 0 COR pos (material, "upper tray") > 0 COR pos (material, "uppertray") > 0 + THEN out (""27"&l1H"); + ELIF pos (material, "manual") > 0 + THEN out (""27"&l2H"); + ELIF pos (material, "envelope") > 0 + THEN out (""27"&l3H"); + FI; + IF material contains a number + THEN out (""27"&l" + text (number) + "X"); + FI; + out (""13""); + + . material contains a number : + INT VAR number := pos (material, "0", "9", 1); + IF number = 0 + THEN FALSE + ELSE number := max (1, int (subtext (material, number, number + 1))); + TRUE + FI + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page + OTHERWISE : put (param1) +END SELECT; + +. + close document : + + +(*. remaining y steps : param1*) +. + close page : + out (""12"") + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + out subtext (string, from, to) + +. + write cmd : + out subtext (string, from, to) + + +(*. x steps to left margin : param1*) +. + carriage return : + out (""13"") + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps <> 0 + THEN x move + ELIF y steps > 0 + THEN out (""27"&a+" + text (y steps) + "V"); + ELIF y steps < 0 + THEN out (""27"&a" + text (y steps) + "V"); + FI; + + . x move : + IF is laser jet plus + THEN laser jet plus x move + ELSE laser jet x move + FI; + + . laser jet plus x move : + IF x steps >= 0 + THEN out (""27"*p+" + text (x steps) + "X"); + ELSE out (""27"*p" + text (x steps) + "X"); + FI; + + . laser jet x move : + abs x pos := x pos; + IF abs x pos >= 0 + THEN out (""27"&a"); + out (text ((abs x pos DIV 5) * 12 + ((abs x pos MOD 5) * 12 + 4) DIV 5)); + out ("H"); + ELSE stop + FI; + +. + draw : + stop + + +. modification : param1 +. + on : + IF on string (modification) <> "" + THEN out (on string (modification)) + ELSE stop + FI + +. + off : + IF off string (modification) <> "" + THEN out (off string (modification)) + ELSE stop + FI + + +. font nr : param1 +. + type : + out (font string (font nr)); + +END PROC execute; + + +END PACKET hp laserjet printer; + + +#page# +(******************************************************************) +(*** ***) +(*** Generierung des Printers ***) +(*** ***) +(******************************************************************) + +LET printer name = "printer.hp.laserjet", + up = ""3""13""5""; + +TEXT VAR fonttab name := "fonttab.hp.laserjet"; + +BOOL CONST multi user := (pcb (9) AND 255) <> 1; + +INT VAR pr channel; +TEXT VAR buffer; + +command dialogue (TRUE); +IF NOT multi user + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") +FI; +ask for print channel; +ask for printer type; +load font table; +forget (printer name, quiet); +IF multi user THEN generate printer spool FI; +check on; +. + ask for print channel : + line; + put ("gib Druckerkanal:"); + get (pr channel); + do ("serverchannel(" + text (pr channel) + ")" ) ; + line; +. + ask for printer type : + printer type (laser jet); + + . laser jet : + line; + REP out (up); + IF yes ("Druckertyp : HP LaserJet") + THEN LEAVE laser jet WITH "LaserJet" FI; + out (up); + IF yes ("Druckertyp : HP LaserJet+") + THEN LEAVE laser jet WITH "LaserJet+" FI; + PER; + "" +. + load font table : + line (2); + write (""13""4""); + putline ("Die Fonttabelle """ + fonttab name + + """ enthält die Schrifttypen der"); + putline ("Font Cartriges:"); + putline (" 92286A Courier 1"); + putline (" 92286C International 1"); + putline (" 92286D Prestige Elite"); + putline (" 92286E Letter Gothic"); + putline (" 92286F TMS Proportional 2"); + putline (" 92286L Courier P&L"); + putline (" 92286M Prestige Elite P&L"); + putline (" 92286N Letter Gothic P&L"); + putline (" 92286P TMS RMN P&L"); + putline (" 92286Q Memo 1"); + line; + putline ("Für ein korrektes Druckbild dürfen immer nur die Schrifttypen angesprochen"); + putline ("werden, deren Cartrige eingeschoben ist!"); + IF printer type = "LaserJet" + THEN line; + putline ("ELAN-Listings können nur gedruckt werden, wenn ein Cartrige mit dem"); + putline ("Schrifttyp 'LINE PRINTER' eingeschoben ist!"); + FI; + line (2); + putline ("Weiter nach Eingabe einer Taste"); + pause; + IF NOT exists (fonttab name) + THEN command dialogue (TRUE); + REP line (2); + putline ("Bitte Archiv mit der Fonttabelle """ + + fonttab name + """ einlegen!"); + line; + UNTIL yes ("Archiv eingelegt") PER; + reserve archive; + fetch (fonttab name, archive); + release (archive); + FI; + font table (fonttab name); + IF multi user + THEN command dialogue (FALSE); + do ("save(""" + font tab name + """,task(""configurator""))") + FI; + forget (fonttab name, quiet); + + . reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop; + +. generate printer spool : + eumel must advertise; + cursor (1, 12); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (4); + putline ("Generierung beendet, weiter mit 'SV'"); + generate printer server; + do (buffer); + +. generate printer server : + buffer := "break (quiet);"; + buffer CAT "spool manager (PROC printer);"; + buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; + buffer CAT "PROC printer:"; + buffer CAT " disable stop;"; + buffer CAT " continue (server channel);"; + buffer CAT " check error (error message);"; + buffer CAT " ds := nilspace;"; + buffer CAT " REP forget (ds);"; + buffer CAT " execute print;"; + buffer CAT " IF is error AND online"; + buffer CAT " THEN out (""""27""(8U""27""(s0p10h12v0s0b3T"");"; + buffer CAT " put error; clear error; out (""""12"""");"; + buffer CAT " FI;"; + buffer CAT " PER;"; + buffer CAT "END PROC printer;"; + buffer CAT "PROC execute print:"; + buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; + buffer CAT " enable stop;"; + buffer CAT " ds := nilspace;"; + buffer CAT " call (father, fetch code, ds, reply);"; + buffer CAT " IF reply = ack CAND type (ds) = file type"; + buffer CAT " THEN file := sequential file (input, ds);"; + buffer CAT " print (file,"; + buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; + buffer CAT " PROC (INT CONST, INT CONST) close,"; + buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; + buffer CAT " FI;"; + buffer CAT "END PROC execute print;"; + buffer CAT "PROC check error(TEXT CONST message):"; + buffer CAT " IF is error"; + buffer CAT " THEN clear error; rename myself (message);"; + buffer CAT " IF is error THEN end(myself) FI;"; + buffer CAT " pause (9000); end(myself);"; + buffer CAT " FI;"; + buffer CAT "END PROC check error;"; + diff --git a/system/printer-laser/4/src/printer.kyocera.f-1010 b/system/printer-laser/4/src/printer.kyocera.f-1010 new file mode 100644 index 0000000..a46f7b3 --- /dev/null +++ b/system/printer-laser/4/src/printer.kyocera.f-1010 @@ -0,0 +1,373 @@ +PACKET kyocera f 1010 printer + +(**************************************************************************) +(* Stand : 03.12.86 *) +(* KYOCERA F - 1010 Verison : 4 *) +(* Autor : Rudolf Ruland *) +(**************************************************************************) + +(**************************************************************************) +(* Hinweis : Die 'time-out' Zeit, nach der der Eingabepuffer ausgegeben *) +(* wird, wenn keine Eingabe mehr erfolgt, sollte moeglichst *) +(* gross gewaehlt werden, *) +(* z.B. mit FRPO H9, 60; wird sie auf 5 Min. gesetzt *) +(**************************************************************************) + + + DEFINES open, + close, + execute, + + paper size : + +LET underline = 1, +(* bold = 2, + italics = 4, + reverse = 8, + + underline linetype = 1, *) + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8; + +INT VAR blankpitch, high, low; +REAL VAR x size, y size; +BOOL VAR is landscape, is underline; + +(*********************************************************************) + +paper size (21.0, 29.7); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + out ("!"82"! RES; UNIT D; EXIT;"); (* Reset des Druckers *) + IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0 + THEN is landscape := TRUE; + x steps := x step conversion ( y size ); + y steps := y step conversion ( x size ); + out (""27"&l1O"); + ELSE is landscape := FALSE; + x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + FI; + is underline := FALSE; + IF y size < 29.7 OR x size < 21.0 + THEN out ("!"82"! SLM "); + IF is landscape + THEN out (text (x step conversion (29.7 - y size))); + out ("; STM "); + out (text (y step conversion ((21.0 - x size) * 0.5))); + ELSE out (text (x step conversion ((21.0 - x size) * 0.5))); + FI; + out ("; EXIT;"); + FI; + +. x start : param1 +. y start : param2 +. + open page : + out ("!"82"! MZP 0, 0; EXIT;"); (* Positionierung zum Nullpunkt *) + IF is landscape + THEN x start := x step conversion (0.19); + y start := y step conversion (0.70); + ELSE x start := x step conversion (0.56); + y start := y step conversion (0.60); + FI; + IF pos (material, "tray") > 0 + THEN out (""27"&l1H"); + ELIF pos (material, "manual") > 0 + THEN out (""27"&l2H"); + FI; + out (""13""); + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page + OTHERWISE : put (param1) +END SELECT; + +. + close document : + + +(*. remaining y steps : param1*) +. + close page : + out (""12""); + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + out subtext (string, from, to) + +. + write cmd : + out subtext (string, from, to) + + +(*. x steps to left margin : param1*) +. + carriage return : + out (""13"") + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps > 0 + THEN IF is underline + THEN underline x move + ELSE out (""27"*p+" + text (x steps) + "X"); + FI; + ELIF x steps < 0 + THEN out (""27"*p" + text (x steps) + "X"); + ELIF y steps > 0 + THEN out (""27"*p+" + text (y steps) + "Y"); + ELIF y steps < 0 + THEN out (""27"*p" + text (y steps) + "Y"); + FI; + + . underline x move : + high := x steps DIV blankpitch; + low := x steps MOD blankpitch; + IF high > 0 THEN high TIMESOUT " " FI; + IF low > 0 THEN out (" "27"*p" + text (low - blank pitch) + "X") FI; + +. + draw : + stop + + +. modification : param1 +. + on : + IF on string (modification) <> "" + THEN out (on string (modification)); + IF modification = underline THEN is underline := TRUE FI; + ELSE stop + FI + +. + off : + IF off string (modification) <> "" + THEN out (off string (modification)); + IF modification = underline THEN is underline := FALSE FI; + ELSE stop + FI + + +. font nr : param1 +. + type : + out (font string (font nr)); + blankpitch := char pitch (font nr, " "); + +END PROC execute; + + +END PACKET kyocera f 1010 printer; + + + +#page# +(******************************************************************) +(*** ***) +(*** Generierung des Printers ***) +(*** ***) +(******************************************************************) + +LET printer name = "printer.kyocera.f-1010"; + +TEXT VAR fonttab name := "fonttab.kyocera.f-1010"; + +BOOL CONST multi user := (pcb (9) AND 255) <> 1; + +INT VAR pr channel; +TEXT VAR buffer; + +command dialogue (TRUE); +IF NOT multi user + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") +FI; +ask for print channel; +dynamic font hint; +load font table; +forget (printer name, quiet); +IF multi user THEN generate printer spool FI; +check on; +command dialogue (TRUE); +. + ask for print channel : + line; + put ("gib Druckerkanal:"); + get (pr channel); + do ("serverchannel(" + text (pr channel) + ")" ) ; + line; +. + dynamic font hint : + line (3); + putline (""4"Hinweis zur Benutzung der dynamischen Schrifttypen:"); + line; + putline (" In der Fonttabelle """ + fonttab name + """ sind einige dynamische"); + putline (" Schrifttypen angepaßt. Diese müssen nach jedem Einschalten des"); + putline (" Druckers neu generiert werden."); + putline (" Zur Generierung dieser Schrifttypen befinden sich auf dem Standard-"); + putline (" archive die folgenden Dateien:"); + line; + putline (" ""genfont.kyocera.f-1010.dynamic1"""); + putline (" ""genfont.kyocera.f-1010.dynamic2"""); + line; + putline (" Nach Einschalten des Druckers müssen diese Dateien zuerst ausgedruckt"); + putline (" werden."); + putline (" Die Generierung benötigt pro Schriftart etwa 15 Minuten."); + line (2); + putline ("Weiter nach Eingabe einer Taste"); + pause; +. + load font table : + IF NOT exists (fonttab name) + THEN REP line (2); + putline ("Bitte Archiv mit der Fonttabelle """ + + fonttab name + """ einlegen!"); + line; + UNTIL yes ("Archiv eingelegt") PER; + reserve archive; + fetch (fonttab name, archive); + release (archive); + FI; + font table (fonttab name); + IF multi user + THEN command dialogue (FALSE); + do ("save(""" + font tab name + """,task(""configurator""))") + FI; + forget (fonttab name, quiet); + + . reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop; + +. generate printer spool : + eumel must advertise; + cursor (1, 12); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (4); + putline ("Generierung beendet, weiter mit 'SV'"); + generate printer server; + do (buffer); + +. generate printer server : + buffer := "break (quiet);"; + buffer CAT "spool manager (PROC printer);"; + buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; + buffer CAT "PROC printer:"; + buffer CAT " disable stop;"; + buffer CAT " continue (server channel);"; + buffer CAT " check error (error message);"; + buffer CAT " ds := nilspace;"; + buffer CAT " REP forget (ds);"; + buffer CAT " execute print;"; + buffer CAT " IF is error AND online"; + buffer CAT " THEN out (""""27""(8U""27""(s0p10h12v0s0b3T"");"; + buffer CAT " put error; clear error; out (""""12"""");"; + buffer CAT " FI;"; + buffer CAT " PER;"; + buffer CAT "END PROC printer;"; + buffer CAT "PROC execute print:"; + buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; + buffer CAT " enable stop;"; + buffer CAT " ds := nilspace;"; + buffer CAT " call (father, fetch code, ds, reply);"; + buffer CAT " IF reply = ack CAND type (ds) = file type"; + buffer CAT " THEN file := sequential file (input, ds);"; + buffer CAT " print (file,"; + buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; + buffer CAT " PROC (INT CONST, INT CONST) close,"; + buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; + buffer CAT " FI;"; + buffer CAT "END PROC execute print;"; + buffer CAT "PROC check error(TEXT CONST message):"; + buffer CAT " IF is error"; + buffer CAT " THEN clear error; rename myself (message);"; + buffer CAT " IF is error THEN end(myself) FI;"; + buffer CAT " pause (9000); end(myself);"; + buffer CAT " FI;"; + buffer CAT "END PROC check error;"; + diff --git a/system/printer-laser/4/src/printer.nec.lc-08 b/system/printer-laser/4/src/printer.nec.lc-08 new file mode 100644 index 0000000..9ee2837 --- /dev/null +++ b/system/printer-laser/4/src/printer.nec.lc-08 @@ -0,0 +1,626 @@ +PACKET nec lc 08 printer + +(**************************************************************************) +(* Stand : 29.01.88 *) +(* NEC Silentwriter LC-08 Verison : 4 *) +(* Autor : Rudolf Ruland *) +(**************************************************************************) + + DEFINES open, + close, + execute, + + box commands, + insert box command, + delete box command, + + paper size, + paper x size, + paper y size: + +LET +(* underline = 1, + bold = 2, + italics = 4, + reverse = 8, + + underline linetype = 1, *) + + c document = 1, + c page = 2, + + c write text = 1, + c write cmd = 2, + c carriage return = 3, + c move = 4, + c draw = 5, + c on = 6, + c off = 7, + c type = 8, + + tag type = 1; + +INT VAR symbol type; +REAL VAR x size, y size; +BOOL VAR is landscape, was cr; +TEXT VAR bold buffer, mod string, command, symbol; +THESAURUS VAR box cmds := empty thesaurus; + +(*********************************************************************) + +paper size (21.0, 29.7); + +PROC paper size (REAL CONST x, y) : + + x size := x; + y size := y; + +END PROC paper size; + +PROC paper size : + + line; + putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); + putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); + +END PROC paper size; + +REAL PROC paper x size : x size END PROC paper x size; +REAL PROC paper y size : y size END PROC paper y size; + + +THESAURUS PROC box commands : box cmds END PROC box commands; + +PROC insert box command (TEXT CONST new command) : + + command := new command; + change all (command, " ", ""); + insert (box cmds, command) + +END PROC insert box command; + +PROC delete box command (TEXT CONST old command) : + + INT VAR dummy; + command := old command; + change all (command, " ", ""); + delete (box cmds, command, dummy) + +END PROC delete box command; + +(*********************************************************************) + +PROC open (INT CONST op code, INT VAR param1, param2) : + +SELECT op code OF + CASE c document : open document + CASE c page : open page +END SELECT; + + +. x steps : param1 +. y steps : param2 +. + open document : + out (""28"Cz"); (* Diablo 630 Emulation *) + out (""27""13"P"); (* Reset *) + out (""28"$"); (* Formatlaenge loeschen *) + out (""28"Ca"27"6"28"Cz"); (* Zeichensatz 2 *) + out (""28"Ra"); (* USA-Zeichensatz *) + out (""27""25"1"); (* Sheet 1 *) + is landscape := pos (material, "landscape") > 0; + IF is landscape + THEN x steps := x step conversion ( y size ); + y steps := y step conversion ( x size ); + out (""28")"128""0""); (* Landscape-Mode *) + ELSE x steps := x step conversion ( x size ); + y steps := y step conversion ( y size ); + out (""28")"001""0""); (* Portait -Mode *) + FI; + was cr := FALSE; + bold buffer := ""; + +. x start : param1 +. y start : param2 +. + open page : + IF is landscape + THEN x start := x step conversion (0.45); + y start := y step conversion (0.9); + ELSE x start := x step conversion (0.7); + y start := y step conversion (0.9); + FI; + IF pos (material, "sheet1") > 0 + THEN out (""27""25"1") + ELIF pos (material, "sheet2") > 0 + THEN out (""27""25"2") + ELIF pos (material, "manual") > 0 + THEN out (""27""25"E") + FI; + out (""28"'a"0""0""28"&a"0""0""); (* Positionierung auf den Nullpunkt *) + +END PROC open; + + +PROC close (INT CONST op code, INT CONST param1) : + +SELECT op code OF + CASE c document : close document + CASE c page : close page + OTHERWISE : put (param1) +END SELECT; + +. + close document : + + +(*. remaining y steps : param1*) +. + close page : + out (""12"") + +END PROC close; + + +PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : + +SELECT op code OF + CASE c write text : write text + CASE c write cmd : write cmd + CASE c carriage return : carriage return + CASE c move : move + CASE c draw : draw + CASE c on : on + CASE c off : off + CASE c type : type +END SELECT + + +. from : param1 +. to : param2 +. + write text : + IF was cr + THEN was cr := FALSE; + out (bold buffer); + FI; + out subtext (string, from, to) + +. + write cmd : + IF was cr + THEN was cr := FALSE; + out (bold buffer); + FI; + command := subtext (string, from, to); + IF is box cmd + THEN disable stop; + do (command); + clear error; + ELSE out (command); + FI; + + . is box cmd : + scan (command); + next symbol (symbol, symbol type); + (symbol type = tag type) CAND (box cmds CONTAINS symbol) + + +(*. x steps to left margin : param1*) +. + carriage return : + out (""13""); + was cr := TRUE; + + +. x steps : param1 +. y steps : param2 +. + move : + IF x steps <> 0 THEN x move FI; + IF y steps <> 0 THEN y move FI; + + . x move : + IF x steps > 0 THEN out (""28"&c") ELSE out (""28"&d") FI; + out (x steps low); + out (x steps high); + + . x steps low : code (abs (x steps) MOD 256) + . x steps high : code (abs (x steps) DIV 256) + + . y move : + IF y steps > 0 THEN out (""28"'c") ELSE out (""28"'d") FI; + out (y steps low); + out (y steps high); + + . y steps low : code (abs (y steps) MOD 256) + . y steps high : code (abs (y steps) DIV 256) +. + draw : + stop + + +. modification : param1 +. + on : + mod string := on string (modification); + IF mod string <> "" + THEN out (mod string); + IF pos (""27"W"27"O", mod string) > 0 + THEN bold buffer CAT mod string; + FI; + ELSE stop + FI + +. + off : + mod string := off string (modification); + IF mod string <> "" + THEN out (mod string); + IF pos (""27"&", mod string) > 0 + THEN bold buffer := subtext (bold buffer, 1, LENGTH bold buffer - 2); + out (bold buffer); + FI; + ELSE stop + FI + + +. font nr : param1 +. + type : + out (""28")"); (* Font Identifikation *) + command := font string (font nr); + IF is landscape + THEN out subtext (command, 3, 4); + ELSE out subtext (command, 1, 2); + FI; + out (""28"E"); (* Zeilenvorschub (VMI) *) + out (code (font height (font nr) + font depth (font nr) + font lead (font nr))); + out (""28"F"); (* Zeichenabstand (HMI) *) + out (code (char pitch (font nr, " "))); + out (""27"P"); (* proportional ein *) + out subtext (command, 5); + +END PROC execute; + +END PACKET nec lc 08 printer; + + +PACKET nec lc 08 box commands + +(**************************************************************************) +(* *) +(* Kommandos zum Zeichen von Boxen, Linien und Schraffuren *) +(* für den NEC Laserdrucker LC-08 *) +(* *) +(* Autor : Rudolf Ruland *) +(* Stand : 29.01.88 *) +(**************************************************************************) + + DEFINES line, + x line, + y line, + + box, + box frame, + box shade, + + cake, + cake frame, + cake shade, + : + +INT VAR x, y, h, w; + +WHILE highest entry (box commands) > 0 + REP delete box command (name (box commands, highest entry (box commands))) PER; +insert box command ("line"); +insert box command ("xline"); +insert box command ("yline"); +insert box command ("box"); +insert box command ("boxshade"); +insert box command ("boxframe"); +insert box command ("cake"); +insert box command ("cakeshade"); +insert box command ("cakeframe"); + + +PROC line (REAL CONST x offset, y offset, width, height, INT CONST line width) : + + IF line width > 0 + THEN graph on (x offset, y offset, width, height); + out ("LW" + text (line width) + ";"); + out ("PR;"); + out ("PD" + text (+w) + "," + text (-h) + ";"); + graph off; + FI; + +END PROC line; + +PROC x line (REAL CONST x offset, y offset, width, INT CONST line width) : + + IF line width > 0 + THEN graph on (x offset, y offset, width, 0.0); + out ("LW" + text (line width) + ";"); + out ("PR;"); + out ("PD" + text (+w) + "," + "0;"); + graph off; + FI; + +END PROC x line; + +PROC y line (REAL CONST x offset, y offset, height, INT CONST line width) : + + IF line width > 0 + THEN graph on (x offset, y offset, 0.0, height); + out ("LW" + text (line width) + ";"); + out ("PR;"); + out ("PD0," + text (-h) + ";"); + graph off; + FI; + +END PROC y line; + + +PROC box (REAL CONST x offset, y offset, width, height, + INT CONST pattern type, line width) : + + IF pattern type = 0 + THEN box frame (x offset, y offset, width, height, line width) + ELIF line width = 0 + THEN box shade (x offset, y offset, width, height, pattern type) + ELSE graph on (x offset, y offset, width, height); + out ("LW" + text (line width) + ";"); + set pattern (pattern type); + out ("ER" + text (+w) + "," + text (-h) + ";"); + graph off; + FI; + +END PROC box; + + +PROC box shade (REAL CONST x offset, y offset, width, height, + INT CONST pattern type) : + + IF pattern type <> 0 + THEN graph on (x offset, y offset, width, height); + set pattern (pattern type); + out ("RR" + text (+w) + "," + text (-h) + ";"); + graph off; + FI; + +END PROC box shade; + + +PROC box frame (REAL CONST x offset, y offset, width, height, + INT CONST line width) : + + IF line width <> 0 + THEN graph on (x offset, y offset, width, height); + out ("LW" + text (line width) + ";"); + out ("PR;"); + out ("PD"); + out (text (+w) + "," + "0,"); + out ( "0," + text (-h) + ","); + out (text (-w) + "," + "0,"); + out ( "0," + text (+h) + ";"); + graph off; + FI; + +END PROC box frame; + + +PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle, + INT CONST pattern type, line width) : + + IF pattern type = 0 + THEN cake frame (x offset, y offset, radius, start angle, sweep angle, line width) + ELIF line width = 0 + THEN cake shade (x offset, y offset, radius, start angle, sweep angle, pattern type) + ELSE graph on (x offset, y offset, radius, 0.0); + out ("LW" + text (line width) + ";"); + set pattern (pattern type); + out ("EW" + text (+w) + "," + text (start angle) + "," + text (sweep angle) + ";"); + graph off; + FI; + +END PROC cake; + + +PROC cake shade (REAL CONST x offset, y offset, radius, start angle, sweep angle, + INT CONST pattern type) : + + IF pattern type > 0 CAND w > 0 + THEN graph on (x offset, y offset, radius, 0.0); + set pattern (pattern type); + out ("WG" + text (+w) + "," + text (start angle) + "," + text (sweep angle) + ";"); + graph off; + FI; + +END PROC cake shade; + + +PROC cake frame (REAL CONST x offset, y offset, radius, start angle, sweep angle, + INT CONST line width) : + + + IF line width <> 0 + THEN REAL CONST xs := real (x) + cos (start angle*pi/180.0) * real (w), + ys := real (y) + sin (start angle*pi/180.0) * real (w); + graph on (x offset, y offset, radius, 0.0); + out ("LW" + text (line width) + ";"); + out ("MA"+ text (xs) + "," + text (ys) + ";"); + out ("FA"+ text ( x) + "," + text ( y) + "," + text (sweep angle) + ";"); + out ("MA"+ text ( x) + "," + text ( y) + ";"); + graph off; + FI; + +END PROC cake frame; + + +PROC graph on (REAL CONST x offset, y offset, width, height) : + + x := x pos + x step conversion (x offset); + y := plot y size - (y pos + y step conversion (y offset)); + w := x step conversion (width); + h := y step conversion (height); + out (""28"Aa"); + out ("DF;"); + out ("MA"+ text (x) + "," + text (y) + ";"); + + . plot y size : 3389 - y step conversion (1.0) + +END PROC graph on; + +PROC graph off : + + out (""28"Az"); + +END PROC graph off; + + +PROC set pattern (INT CONST pattern type) : + + out ("XX1;"); + out (pattern); + + . pattern : + SELECT pattern type OF + CASE 1 : "FT2,1,0;" + CASE 2 : "FT2,1,90;" + CASE 3 : "FT2,1,45;" + CASE 4 : "FT3,1,0;" + CASE 5 : "FT3,1,45;" + CASE 6 : "FT2,100,0;" + CASE 7 : "FT2,100,90;" + CASE 8 : "FT2,100,45;" + CASE 9 : "FT3,100,0;" + CASE 10 : "FT3,100,45;" + OTHERWISE : "FT1;" + END SELECT + +END PROC set pattern; + + +END PACKET nec lc 08 box commands; + + + +#page# +(******************************************************************) +(*** ***) +(*** Generierung des Printers ***) +(*** ***) +(******************************************************************) + +LET printer name = "printer.nec.lc-08"; + +TEXT VAR fonttab name := "fonttab.nec.lc-08"; + +BOOL CONST multi user := (pcb (9) AND 255) <> 1; + +INT VAR pr channel; +TEXT VAR buffer; + +command dialogue (TRUE); +IF NOT multi user + THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") +FI; +ask for print channel; +load font table; +forget (printer name, quiet); +IF multi user THEN generate printer spool FI; +command dialogue (TRUE); +check on; +. + ask for print channel : + line; + put ("gib Druckerkanal:"); + get (pr channel); + do ("serverchannel(" + text (pr channel) + ")" ) ; + line; +. + load font table : + IF NOT exists (fonttab name) + THEN REP line (2); + putline ("Bitte Archiv mit der Fonttabelle """ + + fonttab name + """ einlegen!"); + line; + UNTIL yes ("Archiv eingelegt") PER; + reserve archive; + fetch (fonttab name, archive); + release (archive); + FI; + font table (fonttab name); + IF multi user + THEN command dialogue (FALSE); + do ("save(""" + font tab name + """,task(""configurator""))") + FI; + forget (fonttab name, quiet); + + . reserve archive : + INT VAR p1, p2; + archive (" "31" "); + disable stop; + list (archive); + IF is error + THEN buffer := errormessage; + p1 := pos (buffer, """", 1 ) + 1; + p2 := pos (buffer, """", p1) - 1; + IF p1 > 0 AND p2 > 0 + THEN clear error; + buffer := subtext (buffer, p1, p2); + archive (buffer); + FI; + FI; + enable stop; + +. generate printer spool : + eumel must advertise; + cursor (1, 12); + putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); + putline ("die Fonttabelle mit dem Kommando"); + line; + putline (" font table (""" + font tab name + """)"); + line; + putline ("eingestellt werden!!!"); + line (4); + putline ("Generierung beendet, weiter mit 'SV'"); + generate printer server; + do (buffer); + +. generate printer server : + buffer := "break (quiet);"; + buffer CAT "spool manager (PROC printer);"; + buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; + buffer CAT "PROC printer:"; + buffer CAT " disable stop;"; + buffer CAT " continue (server channel);"; + buffer CAT " check error (error message);"; + buffer CAT " ds := nilspace;"; + buffer CAT " REP forget (ds);"; + buffer CAT " execute print;"; + buffer CAT " IF is error AND online THEN put error; clear error; FI;"; + buffer CAT " PER;"; + buffer CAT "END PROC printer;"; + buffer CAT "PROC execute print:"; + buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; + buffer CAT " enable stop;"; + buffer CAT " ds := nilspace;"; + buffer CAT " call (father, fetch code, ds, reply);"; + buffer CAT " IF reply = ack CAND type (ds) = file type"; + buffer CAT " THEN file := sequential file (input, ds);"; + buffer CAT " print (file,"; + buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; + buffer CAT " PROC (INT CONST, INT CONST) close,"; + buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; + buffer CAT " FI;"; + buffer CAT "END PROC execute print;"; + buffer CAT "PROC check error(TEXT CONST message):"; + buffer CAT " IF is error"; + buffer CAT " THEN clear error; rename myself (message);"; + buffer CAT " IF is error THEN end(myself) FI;"; + buffer CAT " pause (9000); end(myself);"; + buffer CAT " FI;"; + buffer CAT "END PROC check error;"; + diff --git a/system/setup/3.1/source-disk b/system/setup/3.1/source-disk new file mode 100644 index 0000000..1421205 --- /dev/null +++ b/system/setup/3.1/source-disk @@ -0,0 +1 @@ +setup/setup-src-3.1_shard-4.9_1989-04-18.img diff --git a/system/setup/3.1/src/AT-4.x b/system/setup/3.1/src/AT-4.x Binary files differnew file mode 100644 index 0000000..86962e3 --- /dev/null +++ b/system/setup/3.1/src/AT-4.x diff --git a/system/setup/3.1/src/SHARD b/system/setup/3.1/src/SHARD Binary files differnew file mode 100644 index 0000000..c1619b3 --- /dev/null +++ b/system/setup/3.1/src/SHARD diff --git a/system/setup/3.1/src/SHard Basis b/system/setup/3.1/src/SHard Basis Binary files differnew file mode 100644 index 0000000..60800a1 --- /dev/null +++ b/system/setup/3.1/src/SHard Basis diff --git a/system/setup/3.1/src/bootblock b/system/setup/3.1/src/bootblock Binary files differnew file mode 100644 index 0000000..00b56a2 --- /dev/null +++ b/system/setup/3.1/src/bootblock diff --git a/system/setup/3.1/src/configuration b/system/setup/3.1/src/configuration new file mode 100644 index 0000000..139597f --- /dev/null +++ b/system/setup/3.1/src/configuration @@ -0,0 +1,2 @@ + + diff --git a/system/setup/3.1/src/neu b/system/setup/3.1/src/neu new file mode 100644 index 0000000..a89779c --- /dev/null +++ b/system/setup/3.1/src/neu @@ -0,0 +1,34 @@ +TEXT VAR t1 :: "SHardmodul Floppy", t2 :: "FLOPPY.EXE"; +reserve ("ds", /"DOS"); +IF yes("init",FALSE) + THEN init modules list; +FI; +THESAURUS VAR th1 :: all modules, th2 :: empty thesaurus; +WHILE yes ("noch Module holen", TRUE) REP +t2 := ONE /"DOS"; +t1 := ONE (th1); +editget (t1); line; +forget (t1); +fetch (t2, /"DOS"); +copy (t2, t1); last param (t1); +th2 := th2 + t1 +PER; +WHILE yes ("jetzt noch andere holen", FALSE) REP + t2 := ONE /"DOS"; + t1 := ONE all; +editget (t1); line; +forget (t1); +fetch (t2, /"DOS"); +copy (t2, t1); last param (t1); +PER; +release (/"DOS"); + +linkshard module (th2); + + + + + + + + diff --git a/system/setup/3.1/src/setup eumel -1: mini eumel dummies b/system/setup/3.1/src/setup eumel -1: mini eumel dummies new file mode 100644 index 0000000..a1fa2b5 --- /dev/null +++ b/system/setup/3.1/src/setup eumel -1: mini eumel dummies @@ -0,0 +1,28 @@ + +PACKET setup eumel mini eumel dummies (* Stand : 08.04.88 *) +DEFINES FILE, + sequentialfile, + output, + putline, + :=, + run : + +TYPE FILE = INT; + +INT CONST output :: 0; + +OP := (FILE VAR a, FILE CONST b): + +END OP :=; +FILE PROC sequentialfile (INT CONST a, TEXT CONST b) : + FILE : (0). +END PROC sequentialfile; + +PROC putline (FILE CONST a, TEXT CONST b): +END PROC putline; + +PROC run (TEXT CONST a): +END PROC run; + +END PACKET setup eumel mini eumel dummies; + diff --git a/system/setup/3.1/src/setup eumel 0: -M b/system/setup/3.1/src/setup eumel 0: -M new file mode 100644 index 0000000..bad5028 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 0: -M @@ -0,0 +1,32 @@ +PACKET setup eumel multiuserspecials (* Copyright (C) 1985, 1988 *) +DEFINES terminal setup, (* Martin Schönbeck, Spenge *) + indirect list, (* Lutz Prechelt, Karlsruhe *) + setup testing : (* Stand: 07.05.88 2.1 *) + +LET sysout file = "sysout"; + +BOOL VAR setup test version :: FALSE; + +PROC terminal setup: + (* It took about 2 manmonths to debug this procedure ! *) +END PROC terminal setup; + +PROC indirect list (BOOL CONST make indirection) : + IF make indirection + THEN sysout (sysout file); + ELSE sysout (""); + print (sysout file); + forget (sysout file, quiet) + FI. +END PROC indirect list; + +PROC setup testing (BOOL CONST new ): + setup test version := new; +END PROC setup testing; + +BOOL PROC setup testing : + setup test version. +END PROC setup testing; + +END PACKET setup eumel multiuserspecials; + diff --git a/system/setup/3.1/src/setup eumel 0: -S b/system/setup/3.1/src/setup eumel 0: -S new file mode 100644 index 0000000..50a8330 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 0: -S @@ -0,0 +1,35 @@ +PACKET setup eumel singleuserspecials (* Copyright (C) 1985, 1988 *) +DEFINES terminal setup, (* Martin Schönbeck, Spenge *) + break, (* Lutz Prechelt, Karlsruhe *) + indirect list, (* Stand: 07.05.88 2.1 *) + setup testing : + +LET printer channel = 15, + screen channel = 1; + + +PROC break (QUIET CONST quiet): +END PROC break; + +PROC terminal setup: + setup +END PROC terminal setup; + +PROC indirect list (BOOL CONST make indirection) : + (* Man beachte, daß es nicht besonders sinnvoll ist, auf einem Drucker + cout zu machen... + *) + IF make indirection + THEN continue (printer channel) + ELSE continue (screen channel) FI. +END PROC indirect list; + +PROC setup testing (BOOL CONST new): +END PROC setup testing; + +BOOL PROC setup testing : + FALSE. +END PROC setup testing; + +END PACKET setup eumel singleuserspecials; + diff --git a/system/setup/3.1/src/setup eumel 1: basisoperationen b/system/setup/3.1/src/setup eumel 1: basisoperationen new file mode 100644 index 0000000..a705ff4 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 1: basisoperationen @@ -0,0 +1,1071 @@ + +(**************************************************************************) +(***** Grundoperationen für den Setup-Eumel (Modul-SHard) *****************) +(***** Copyright (c) 1985 - 1988 by *****************) +(***** Martin Schönbeck, Spenge / Lutz Prechelt, Karlsruhe ****************) +(**************************************************************************) + +(* Fünf Pakete : + 1. setup eumel basisoperationen + Handhabung von 16-Bit unsigned Werten in INTs und Editierfunktionen + 2. splitting + Worttrennung von REALs und Bytetrennung von INTs + 3. basic block io + blockin und blockout auf Datenräume mit retrys und Fehlermeldungen + 4. write file + Direktes Schreiben/Lesen eines Datenraums in/aus eine(r) Partition + 5. thesaurus utilities + ONE,CERTAIN,certain zum Aussuchen aus Thesauri ohne Editor +*) + + +PACKET setup eumel basisoperationen (* (C) 1987 Lutz Prechelt, Karlsruhe *) +DEFINES editget, editgetchar, (* Stand: 08.04.88 Version 1.1 *) + yes, no, (* Eumel 1.8.0 *) + direction, reset direction, + data error, write head, + LIST, list, CAT, emptylist, + (*UNSIGNED,*) unsigned, int, text, + RANGE, range, everywhere, + ANDXOR, andxor, + dec, hex, bin, + IN, + := , + put : + +(* Dieses Paket stellt die Basisfunktionen für den Elanteil des Setup-SHard + zur Verfügung. + Es ist dies im Wesentlichen die Handhabung von INT-Werten auch in Binär- + und Hexdarstellung, sowie die Plausibilitätsprüfung mit Fehleranzeigen. +*) + +TYPE LIST = TEXT, (* TEXT aus mehreren UNSIGNEDen (replace/ISUB) *) + RANGE = STRUCT (UNSIGNED low, high), + ANDXOR = STRUCT (UNSIGNED and mask, xor mask); + +LET UNSIGNED = INT; (* 16 bit *) + +TYPE REPRESENTATION = INT; + +REPRESENTATION CONST dec :: REPRESENTATION : (10), + hex :: REPRESENTATION : (16), + bin :: REPRESENTATION : (2); + +(* Diese Typen dienen zur Wertprüfung bei der Eingabe. *) + +LET up = ""3"", + down = ""10"", + right = ""2"", + error = ""0""; (* fuer current direction *) + +TEXT VAR current direction :: ""; (* enthaelt up oder down oder "" *) +BOOL VAR direction valid :: FALSE; + +TEXT CONST hex digits :: "0123456789abcdef"; + +(********************* Zuweisungen *************************************) + +OP := (LIST VAR a, LIST CONST b) : + CONCR (a) := CONCR (b) +END OP := ; + +OP := (RANGE VAR a, RANGE CONST b) : + a.low := b.low; + a.high := b.high +END OP := ; + +OP := (ANDXOR VAR a, ANDXOR CONST b) : + a.and mask := b.and mask; + a.xor mask := b.xor mask +END OP := ; + +OP := (REPRESENTATION VAR a, REPRESENTATION CONST b) : + CONCR (a) := CONCR (b) +END OP := ; + +(************************** IN ******************************************) + +BOOL OP IN (UNSIGNED CONST a, LIST CONST l) : + INT CONST p :: pos (CONCR (l), textform (a)); + p > 0 AND p MOD 2 = 1 (* enthalten und word-aligned *) +END OP IN; + +BOOL OP IN (UNSIGNED CONST a, RANGE CONST b) : + (* RANGES sind inklusiv ihrer Grenzen *) + reverse (textform (a)) <= reverse (textform (b.high)) AND + reverse (textform (a)) >= reverse (textform (b.low)) +END OP IN; + +BOOL OP IN (UNSIGNED CONST a, ANDXOR CONST mask) : + (* Es muss (Bitweise) (a AND andmask) XOR xormask = 0 sein *) + ((a AND mask.and mask) XOR mask.xor mask) = 0 +END OP IN; + +(************************* Konstruktoren ********************************) + +LIST CONST emptylist :: LIST : (""); + +LIST PROC list (TEXT CONST list text) : + (* Konstruiert aus einer in Textform gegebenen Liste von Unsigneds eine + LIST. Die einzelnen Werte sind durch Komma getrennt und dürfen in + dezimaler, sedezimaler oder binärer Darstellung notiert sein. + *) + TEXT VAR t :: compress (list text); + IF t = "" THEN emptylist + ELSE TEXT VAR result :: ""; + REPEAT + INT VAR first comma pos :: pos (t, ","); + IF first comma pos = 0 THEN first comma pos := LENGTH t + 1 FI; + result CAT textform (unsigned (subtext (t, 1, first comma pos - 1))); + t := subtext (t, first comma pos + 1) + UNTIL t = "" PER; + LIST : (result) + FI +END PROC list; + +(*UNSIGNED PROC unsigned (INT CONST sixteen bits) : + sixteen bits +END PROC unsigned;*) + +UNSIGNED PROC unsigned (TEXT CONST number) : + INT VAR result :: 0, i; + TEXT VAR t :: compress (to lower (number)), type :: t SUB LENGTH t; + IF pos ("hb" + hex digits, type) = 0 + THEN set conversion (FALSE); + LEAVE unsigned WITH 0 + FI; + IF type = "h" + THEN convert hex + ELIF type = "b" + THEN convert binary + ELSE convert decimal FI; + result. + +convert hex : + FOR i FROM 1 UPTO LENGTH t - 1 REP + TEXT CONST c :: t SUB i; + IF pos (hex digits, c) = 0 + THEN set conversion (FALSE); + LEAVE unsigned WITH 0 + FI; + rotate (result, 4); + result INCR pos (hex digits, c) - 1 + PER. + +convert binary : + FOR i FROM 1 UPTO LENGTH t - 1 REP + TEXT CONST bit :: t SUB i; + IF bit <> "0" AND bit <> "1" + THEN set conversion (FALSE); + LEAVE unsigned WITH 0 + FI; + rotate (result, 1); + result INCR int (bit) + PER. + +convert decimal : + REAL VAR x :: real (t); + IF NOT last conversion ok THEN LEAVE unsigned WITH 0 FI; + IF x < 32768.0 + THEN result := int (x) + ELSE result := int (x - 65536.0) FI. +END PROC unsigned; + +RANGE CONST everywhere :: RANGE : (0, -1); + +RANGE PROC range (UNSIGNED CONST low, high) : + RANGE : (low, high) +END PROC range; + +ANDXOR PROC andxor (UNSIGNED CONST and mask, xor mask) : + ANDXOR : (and mask, xor mask) +ENDPROC andxor; + + +(******* weitere Operationen für UNSIGNED, LIST, RANGE, ANDXOR **************) + +INT PROC int (UNSIGNED CONST a) : + (* falls jemand noch exotische Dinge damit tun will *) + a +END PROC int; + +OP CAT (LIST VAR l, UNSIGNED CONST a) : + (* Liste nachtraeglich erweitern *) + CONCR (l) CAT textform (a) +END OP CAT; + +(********************* editget(char), yes, no *****************************) + +PROC editget (INT CONST spalte, zeile, TEXT CONST prompt, INT VAR i) : + cursor (spalte, zeile); + editget (prompt, i) +END PROC editget; + +PROC editget (INT CONST spalte, zeile, TEXT CONST prompt, UNSIGNED VAR a, + REPRESENTATION CONST r) : + cursor (spalte, zeile); + editget (prompt, a, r) +END PROC editget; + +PROC editget (TEXT CONST prompt, INT VAR i) : + TEXT VAR t :: text (i); + test up or down (prompt, t); + IF current direction <> "" THEN LEAVE editget FI; + editget (t,7,7); + i := int (t); + IF NOT last conversion ok + THEN data error ("Eingabe unerlaubt als Zahl") FI +END PROC editget; + +PROC editget (TEXT CONST prompt, UNSIGNED VAR a, REPRESENTATION CONST r) : + TEXT VAR t :: text (a, r); + test up or down (prompt, t); + IF current direction <> "" THEN LEAVE editget FI; + editget (t,18,18); + a := unsigned (t); + IF NOT last conversion ok + THEN data error ("Eingabe unerlaubt") FI +END PROC editget; + +BOOL PROC yes (TEXT CONST frage, BOOL CONST std antwort) : + (* Achtung: hierdrin kann nicht die alte "yes" Prozedur benutzt werden, da + diese kein getchar benutzt. + Die alten yes/no werden unten durch Resultatlose ueberdeckt. + *) + LET allowed = "NnJj"; + INT VAR x,y; get cursor (x,y); + IF NOT command dialogue THEN LEAVE yes WITH std antwort FI; + REP UNTIL getcharety = "" PER; + REP + cursor (x,y); + test up or down (frage + " ? (j/n)", standard antwort text); + IF current direction <> "" THEN LEAVE yes WITH std antwort FI; + TEXT VAR t; + getchar (t); + IF t = ""13"" + THEN t := standard antwort text FI; + IF pos (allowed, t) = 0 + THEN out (""7"") ELSE out (t); out (""13""10"") FI + UNTIL pos (allowed, t) <> 0 PER; + t = "j" OR t = "J". + +standard antwort text: + IF std antwort + THEN "j" + ELSE "n" + FI. +END PROC yes; + +BOOL PROC yes (INT CONST spalte, zeile, TEXT CONST frage, + BOOL CONST std antwort) : + cursor (spalte, zeile); + yes (frage, std antwort). +END PROC yes; + +PROC yes (TEXT CONST dummy): END PROC yes; + +PROC no (TEXT CONST dummy): END PROC no; + +PROC editgetchar (INT CONST spalte, zeile, TEXT CONST prompt, allowed, + UNSIGNED VAR a) : + cursor (spalte, zeile); + editgetchar (prompt, allowed, a) +END PROC editgetchar; + +PROC editgetchar (TEXT CONST prompt, allowed, UNSIGNED VAR a) : + (* Bietet Zeichen an (nehmen mit RETURN), nimmt nur die in allowed. + obere 8 Bit der Vorbesetzung werden abgeschnitten. + *) + TEXT VAR t; + test up or down (prompt, perhaps a); + a := a MOD 256; + IF current direction <> "" THEN LEAVE editgetchar FI; + getchar (t); + IF t = ""13"" + THEN (* Vorbesetzung behalten *) + out (right) + ELIF pos (allowed, t) <> 0 + THEN a := code (t); + out (t) + ELSE out (t); + data error ("unzulässiges Zeichen") + FI. + +perhaps a: + IF a > 31 THEN code (a) ELSE "" FI. +END PROC editgetchar; + +(********* data error, write head, (reset) direction *********************) + +PROC data error (TEXT CONST fehlermeldung) : + cursor (1, 24); + out (""7"Fehler : " + fehlermeldung + " (Bitte Taste) "); + REP UNTIL incharety (2) = "" PER; pause; + cursor (1, 24); out (""4""); + current direction := error +END PROC data error; + +PROC write head (TEXT CONST headtext) : + TEXT CONST text :: subtext (headtext, 1, 77); + INT CONST luecke :: (79 - LENGTH text) DIV 2 - 1; + out (""1""4""15""); + luecke TIMESOUT " "; + out (text); + luecke TIMESOUT " "; + out (""14""13""10""10""). +END PROC write head; + +TEXT PROC direction : + current direction +END PROC direction; + +PROC reset direction (BOOL CONST manouvres possible) : + (* Hiermit kann die letzte Manövrierbewegung nach der Auswertung gelöscht + werden. Mit NOT manouvres possible wird der ganze Manövriermechanismus + außer Betrieb gesetzt. + *) + direction valid := manouvres possible; + current direction := "" +END PROC reset direction; + +(*********************** put *******************************************) + +PROC put (INT CONST spalte, zeile, UNSIGNED CONST a, REPRESENTATION CONST r): + cursor (spalte, zeile); + put (a, r) +END PROC put; + +PROC put (INT CONST spalte, zeile, LIST CONST l, REPRESENTATION CONST r): + cursor (spalte, zeile); + put (l, r) +END PROC put; + +PROC put (INT CONST spalte, zeile, RANGE CONST a, REPRESENTATION CONST r): + cursor (spalte, zeile); + put (a, r) +END PROC put; + +PROC put (UNSIGNED CONST a, REPRESENTATION CONST r) : + put (text (a, r)) +END PROC put; + +PROC put (LIST CONST a, REPRESENTATION CONST r) : + INT VAR i, l :: LENGTH CONCR (a) DIV 2; + write ("("); + FOR i FROM 1 UPTO l REP + put (text (CONCR (a) ISUB i, r)); + IF i < l THEN put (",") FI + PER; + IF l > 0 THEN out (""8"") FI; + put (")") +END PROC put; + +PROC put (RANGE CONST a, REPRESENTATION CONST r) : + write (text (a.low, r)); + write ("..."); + write (text (a.high, r)) +END PROC put; +(*** ist put auf RANGE in dieser Weise sinnvoll ? + vielleicht lieber die Maske bitweise mit x, 1, 0 darstellen ? +***) + +PROC put (BOOL CONST b): + IF b + THEN put ("Ja "); + ELSE put ("Nein"); + FI +END PROC put; + + +(********************* interne Hilfsprozeduren ****************************) + +TEXT PROC text (UNSIGNED CONST a, REPRESENTATION CONST r) : + TEXT VAR result :: ""; + INT VAR i; + set conversion (TRUE); + IF CONCR (r) = 10 THEN decimal form + ELIF CONCR (r) = 2 THEN binary form + ELSE hex form FI. + +decimal form : + IF bit (a, 15) (* dann kriegt man im Eumel negatives Vorzeichen *) + THEN result := text (real (text (a)) + 65536.0); (* Der Umweg ueber + Text ist noetig, wegen (1.8.0) real (-32767-1) --> stack overflow *) + subtext (result, 1, pos (result, ".") - 1) (* Dezimalpunkt weghauen *) + ELSE text (a) FI. + +binary form : + FOR i FROM 15 DOWNTO 0 REP + IF bit (a, i) THEN result CAT "1" ELSE result CAT "0" FI + PER; + result + "b". + +hex form : + INT VAR help :: a; + FOR i FROM 1 UPTO 4 REP + rotate (help, 4); (* oberste 4 bit zu untersten 4 machen *) + result CAT (hex digits SUB nibble + 1); (* oberste 4 bit darstellen *) + PER; + result + "h". + +nibble : + help MOD 16. (* unterste 4 bit *) +END PROC text; + +TEXT PROC textform (UNSIGNED CONST a) : + (* speichert das INT in einen TEXT (mit ISUB lesbar) *) + TEXT VAR ta :: " "; + replace (ta, 1, a); + ta +END PROC textform; + +TEXT PROC reverse (TEXT CONST a) : + (* Text umdrehen. Das braucht man, um die ISUBS direkt vergleichen zu + koennen. + *) + IF LENGTH a <= 1 THEN a + ELSE reverse (subtext (a, 2)) + (a SUB 1) FI +END PROC reverse; + +PROC test up or down (TEXT CONST prompt, data) : + IF current direction <> "" AND NOT direction valid + THEN current direction := ""; + LEAVE test up or down + FI; + out (prompt); + out (" "8""8""8""8""8""8""); (* nächste 6 Zeichen Löschen *) + out (data); LENGTH data TIMESOUT ""8""; + IF NOT direction valid THEN LEAVE test up or down FI; + getchar (current direction); + IF current direction = up OR current direction = down + THEN (* verschlucken, spaeter auswerten *) + ELSE push (current direction); + current direction := "" + FI +END PROC test up or down; + +TEXT PROC to lower (TEXT CONST text) : + TEXT VAR t :: text; + INT VAR i; + FOR i FROM 1 UPTO LENGTH t REP + IF (t SUB i) >= ""65"" AND (t SUB i) <= ""90"" + THEN replace (t, i, code (code (t SUB i) + 32)) FI + PER; + t +END PROC to lower; + +END PACKET setup eumel basisoperationen; + + + +PACKET splitting DEFINES low byte, (* Copyright (C) 1985 *) + high byte, (* Martin Schönbeck, Spenge *) + low word, (* Stand: 13.09.85 *) + high word: + +INT PROC high byte (INT CONST value): + + TEXT VAR x := " "; + replace (x, 1, value); + code (x SUB 2) + +END PROC high byte; + +INT PROC low byte (INT CONST value): + + TEXT VAR x := " "; + replace (x, 1, value); + code (x SUB 1) + +END PROC low byte; + +INT PROC high word (REAL CONST double precission int): + + int (double precission int / 65536.0) + +END PROC high word; + +INT PROC low word (REAL CONST double precission int): + + string of low bytes ISUB 1. + +string of low bytes: + code (int (double precission int MOD 256.0)) + + code (int ((double precission int MOD 65536.0) / 256.0)). + +END PROC low word; + +END PACKET splitting; + + + +PACKET basic block io DEFINES + verify track, + read block, + write 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 block no, + INT VAR return code): + write block; + retry if write error. + +write block: + block out (ds, ds page no, 0, 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; + +PROC read block (DATASPACE VAR ds, INT CONST ds page, + REAL CONST archive block): + + enable stop; + read block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht gelesen werden"); + CASE 2: error stop ("Lesefehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + +END PROC read block; + +PROC write block (DATASPACE CONST ds, INT CONST ds page, + REAL CONST archive block): + + enable stop; + write block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht geschrieben werden"); + CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + +END PROC write block; + +PROC read block (DATASPACE VAR ds, + INT CONST ds page no, + REAL CONST block no, + INT VAR return code): + read block; + retry if read error. + +read block: + block in (ds, ds page no, high word (block no) OR -512, + low word (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, + REAL CONST block no, + INT VAR return code): + write block; + retry if write error. + +write block: + block out (ds, ds page no, high word (block no) OR -512, + low word (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; + +PROC verify track (DATASPACE VAR ds, INT CONST ds page no, + REAL CONST startblock no, INT VAR return code): + block in (ds, ds page no, high word (startblock no) OR -256, + low word (startblock no), return code); +END PROC verify track; + +END PACKET basic block io; + + + +PACKET write file DEFINES write file, (* Copyright (C) 1985, 1987 *) + read file : (* Martin Schönbeck, Spenge *) + (* Lutz Prechelt, Karlsruhe *) + (* Stand: 07.06.87 *) + +PROC write file (TEXT CONST file name, REAL CONST start block, + INT CONST number of blocks): + + INT VAR count; + disable stop; + DATASPACE VAR ds := old (file name); + FOR count FROM 0 UPTO (number of blocks - 1) REP + write block (ds, count + 3, start block + real (count)) + UNTIL is error PER; + forget (ds). + +END PROC write file; + +PROC write file (TEXT CONST file name, REAL CONST start block, + INT CONST number of blocks, write channel): + + enable stop; + INT VAR old channel := channel; + IF old channel <> write channel THEN continue (write channel) FI; + disable stop; + write file (file name, start block, number of blocks); + IF old channel <> write channel + THEN break (quiet); + continue (old channel) + FI. +END PROC write file; + +PROC read file (DATASPACE VAR file, REAL CONST start block, + INT CONST number of blocks): + INT VAR count; + disable stop; + forget (file); file := nilspace; + FOR count FROM 0 UPTO (number of blocks - 1) REP + read block (file, count + 3, start block + real (count)) + UNTIL is error PER. +END PROC read file; + +PROC read file (DATASPACE VAR file, REAL CONST start block, + INT CONST number of blocks, read channel): + enable stop; + INT VAR old channel := channel; + IF old channel <> read channel THEN continue (read channel) FI; + disable stop; + read file (file, start block, number of blocks); + IF old channel <> channel + THEN break (quiet); + continue (old channel) + FI. +END PROC read file; + +END PACKET write file; + +PACKET thesaurus utilities +DEFINES ONE, certain : (* Stand: 21.03.88 *) + (* Korr : Lutz Prechelt *) +LET max entries = 200; + +LET oben unten rubout return = ""3""10""12""13""; + +INT VAR anzahl, + firstline, size, (* erste Bildschirmz./Anz. Zeilen für Vorgang *) + realc, virtc; (* akt. Zeile in Fenster/Eintragsnummer *) + +TEXT VAR string; + +THESAURUS PROC certain (THESAURUS CONST in, pre) : + einzelne (in, pre, TRUE). +END PROC certain; + +TEXT OP ONE (THESAURUS CONST t): + name (einzelne (t, empty thesaurus, FALSE),1) +END OP ONE; + +THESAURUS PROC einzelne (THESAURUS CONST thes, preselections, + BOOL CONST viele): + (* Benutzt nur den Rest des Bildschirms ab der aktuellen Zeile nach unten. + Die in preselections enthaltenen Namen aus t sind bereits zu Beginn + angekreuzt. + Ein Aufruf mit NOT viele und preselections/t <> empty thesaurus ist + nicht sinnvoll. + Die Cursorposition nach Verlassen ist wieder in der "aktuellen" Zeile + auf Position 1, so daß mit out (""4"") der Kram selektiv gelöscht + werden kann. + *) + ROW maxentries TEXT VAR eintrag; + THESAURUS VAR ausgabe :: empty thesaurus, + t :: empty thesaurus + thes; (* Leereinträge entfernen! *) + INT VAR i; + initialisiere ankreuzen; + IF anzahl = 0 THEN LEAVE einzelne WITH empty thesaurus FI; + bildschirm vorbereiten; + bild (1, eintrag); + virtc := 1; + realc := 1; + realcursor setzen; + kreuze an (viele, eintrag); + ausgabe erzeugen; + cursor (1, firstline - 2); out (""4""); + ausgabe. + +initialisiere ankreuzen: + anzahl := highest entry (t); + string := ""; + (* t enthält keine Leereinträge mehr ! *) + FOR i FROM 1 UPTO anzahl REP + eintrag [i] := name (t,i) + PER; + FOR i FROM 1 UPTO highest entry (preselections) REP + INT CONST preselection link :: link (t, name (preselections, i)); + IF preselection link > 0 + THEN string CAT textstr (preselection link) FI + PER. + +bildschirm vorbereiten: + get cursor (i, firstline); + out (""13""4""); (* Restbildschirm löschen *) + IF viele + THEN putline ("Wählen <CR> Löschen <RUBOUT> " + + "alle Löschen <HOP><RUBOUT> Beenden <ESC>q") + ELSE putline ("Auswählen <CR>") FI; + putline ("Marke bewegen <RUNTER> <RAUF> <HOP><RUNTER> <HOP><RAUF>"); + firstline INCR 2; + size := 24 - firstline + 1. + +ausgabe erzeugen: + WHILE string <> "" REP + insert (ausgabe, eintrag [string ISUB 1]); + string := subtext (string, 3); + PER +END PROC einzelne; + +PROC realcursor setzen: + TEXT CONST mark :: marke (virtc, TRUE); + cursor (1, firstline + realc - 1); + out (mark + LENGTH mark * ""8""). +END PROC real cursor setzen; + +TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor): + INT VAR pl :: nr (zeiger); + IF pl = 0 + THEN leer + ELSE mit zahl + FI. + +mit zahl: + IF mit cursor + THEN (3 - length (text (pl))) * "-" + text (pl) + "-> " + ELSE text (pl, 3) + " > " + FI. + +leer: + IF mit cursor + THEN ">>>>> " + ELSE " " + FI +END PROC marke; + +PROC bild (INT CONST anfang, ROW maxentries TEXT CONST eintrag): + cursor (1, firstline); + out (""4""3""); (* Restschirm löschen, 1 Zeile rauf *) + INT VAR i; + FOR i FROM anfang UPTO grenze REP + out (""13""10""); + out (marke (i, FALSE)); + out (eintrag [i]) + PER. + +grenze: + min (anzahl, anfang + size - 1) +END PROC bild; + +PROC kreuze an (BOOL CONST viele, ROW maxentries TEXT CONST eintrag) : + REP zeichen lesen; + zeichen interpretieren + PER. + +zeichen lesen: + TEXT VAR zeichen; + inchar (zeichen, ""1""27""3""10""13"1Xx+"11""12"Oo0-"). + +zeichen interpretieren: + SELECT code (zeichen) OF + CASE 1 (* hop *) : hoppen (eintrag) + CASE 27 (* ESC *) : IF incharety (600) = "q" THEN LEAVE kreuze an FI + CASE 3 (* rauf *) : nach oben (eintrag) + CASE 10 (* runter *) : nach unten (eintrag) + CASE 13 (* Return *) : ankreuzen (eintrag, TRUE); evtl aufhoeren + CASE 49,(* 1 *) + 88,(* X *) + 120,(* x *) + 43,(* + *) + 11 (* Rubin *) : ankreuzen (eintrag, FALSE); evtl aufhoeren + CASE 12,(* Rubout *) + 79,(* O *) + 111,(* o *) + 48,(* 0 *) + 45 (* - *) : auskreuzen (eintrag) + END SELECT. + +evtl aufhoeren: + IF NOT viele THEN LEAVE kreuze an FI. + +END PROC kreuze an; + +PROC hoppen (ROW maxentries TEXT CONST eintrag) : + zweites zeichen lesen; + zeichen interpretieren. + +zweites zeichen lesen: + TEXT VAR zz; + inchar (zz). + +zeichen interpretieren: + SELECT pos (oben unten rubout return, zz) OF + CASE 1 : hop nach oben + CASE 2 : hop nach unten + CASE 3 : alles loeschen + CASE 4 : rest ankreuzen + OTHERWISE out (""7"") + END SELECT. + +rest ankreuzen: + INT VAR i; + FOR i FROM 1 UPTO anzahl REP (* alles *) + IF nr (i) = 0 (* was noch nicht angekreuzt ist *) + THEN string CAT textstr (i) (* ankreuzen *) + FI + PER; + bild aktualisieren. + +alles loeschen: + string := ""; + bild aktualisieren. + +hop nach oben: + IF ganz oben + THEN out (""7"") + ELIF oben im fenster + THEN raufblaettern + ELSE top of page + FI. + +ganz oben: + virtc = 1. + +oben im fenster: + realc = 1. + +raufblaettern: + virtc DECR size; + virtc := max (virtc, 1); + bild (virtc, eintrag); + realcursor setzen. + +top of page: + loesche marke; + virtc DECR (realc - 1); + realc := 1; + realcursor setzen. + +hop nach unten: + IF ganz unten + THEN out (""7"") + ELIF unten im fenster + THEN runterblaettern + ELSE bottom of page + FI. + +ganz unten: + virtc = anzahl. + +unten im fenster: + firstline + realc > 24. + +runterblaettern: + INT VAR alter virtc :: virtc; + virtc INCR size; + virtc := min (virtc, anzahl); + realc := virtc - alter virtc; + bild (alter virtc + 1, eintrag); + realcursor setzen. + +bottom of page: + loesche marke; + alter virtc := virtc; + virtc INCR (size - realc); + virtc := min (anzahl, virtc); + realc INCR (virtc - alter virtc); + realcursor setzen +END PROC hoppen; + +PROC ankreuzen (ROW maxentries TEXT CONST eintrag, BOOL CONST ggf auskreuzen): + (* bei ggf auskreuzen wird der Eintrag, falls er schon angekreuzt ist, + ausgekreuzt, andernfalls normal angekreuzt. + *) + INT VAR pl :: nr (virtc); + IF pl <> 0 + THEN schon angekreuzt + FI; + string CAT textstr (virtc); + IF virtc < anzahl THEN nach unten (eintrag) ELSE realcursor setzen FI. + +schon angekreuzt : + IF ggf auskreuzen THEN auskreuzen (eintrag) ELSE out (""7"") FI; + LEAVE ankreuzen. +END PROC ankreuzen; + +PROC auskreuzen (ROW maxentries TEXT CONST eintrag) : + INT VAR posi :: nr (virtc); + IF posi = 0 + THEN out (""7""); LEAVE auskreuzen + FI; + rausschmeissen; + loesche marke; + bild aktualisieren; + IF virtc < anzahl THEN nach unten (eintrag) FI. + +rausschmeissen: + string := subtext (string,1, 2*posi-2) + subtext (string,2*posi+1) +END PROC auskreuzen; + +PROC bild aktualisieren: + INT VAR ob, un, i; + ob := virtc - realc + 1; + un := min (ob + size - 1, anzahl); + cursor (1, firstline - 1); + FOR i FROM ob UPTO un REP + out (""13""10""); out (marke (i, FALSE)) + PER; + realcursor setzen. +END PROC bild aktualisieren; + +PROC nach oben (ROW maxentries TEXT CONST eintrag) : + IF noch nicht oben (* virtuell *) + THEN gehe nach oben + ELSE out (""7"") + FI; + realcursor setzen. + +noch nicht oben: + virtc > 1. + +gehe nach oben: + IF realc = 1 + THEN scroll down + ELSE cursor up + FI. + +scroll down: + virtc DECR 1; + bild (virtc, eintrag). + +cursor up: + loesche marke; + virtc DECR 1; + realc DECR 1. +END PROC nach oben; + +PROC nach unten (ROW maxentries TEXT CONST eintrag) : + IF noch nicht unten (* virtuell *) + THEN gehe nach unten + ELSE out (""7"") + FI. + +noch nicht unten: + virtc < anzahl. + +gehe nach unten: + IF realc > size - 1 + THEN scroll up + ELSE cursor down + FI. + +scroll up: + virtc INCR 1; + bild (virtc - size + 1, eintrag); + realcursor setzen. + +cursor down: + loesche marke; + virtc INCR 1; + realc INCR 1; + realcursor setzen +END PROC nach unten; + +PROC loesche marke: + out (marke (virtc, FALSE)) +END PROC loesche marke; + +TEXT PROC textstr (INT CONST nr): + TEXT VAR help :: " "; + replace (help, 1, nr); + help. +END PROC textstr; + +INT PROC nr (INT CONST zeiger): + IF pos (string, textstr (zeiger)) = 0 (* haut hin, da zeiger < 255 *) + THEN 0 + ELSE (pos (string,textstr (zeiger)) DIV 2) + 1 + FI +END PROC nr; + +PROC inchar (TEXT VAR t, TEXT CONST allowed) : + REP + getchar (t); + IF pos (allowed, t) = 0 THEN out (""7"") FI + UNTIL pos (allowed, t) > 0 PER. +END PROC inchar; + +END PACKET thesaurus utilities; + diff --git a/system/setup/3.1/src/setup eumel 2: modulzugriffe b/system/setup/3.1/src/setup eumel 2: modulzugriffe new file mode 100644 index 0000000..42163f4 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 2: modulzugriffe @@ -0,0 +1,441 @@ + +(* Pakete: + 1. setup eumel modulzugriffe + Abstrakter Datentyp MODUL : Typ, Datenraumtyp, Zugriffsoperationen + 2. setup eumel modul und shard zugriffe + Zugriffe in Module und SHards (Datentyp MODUL) mit Strukturwissen +*) + +(**************************************************************************) +(***** Datentyp MODUL und Zugriffsoperationen dafür ****************) +(***** Copyright (c) 1987, 1988 by ****************) +(***** Lutz Prechelt, Karlsruhe ****************) +(**************************************************************************) + +PACKET setup eumel modulzugriffe (* Copyright (c) 1987 by *) +DEFINES int, byte, text, unsigned, (* Lutz Prechelt, Karlsruhe *) + dtcb abfragen, ccb abfragen, (* Stand : 12.03.88 1.1 *) + dtcb refinements, ccb refinements, (* Eumel 1.8.1 *) + info, + page, + copy, + datenraumtyp modul, + MODUL : + + +(* Dies Paket realisiert gezielte Zugriffe in einen Struct vom Typ MODUL. + Dies ist das Format eines SHard Moduls. Der Typ wird auch verwendet, um + das SHard-Hauptmodul oder einzelne ccbs zu handhaben! + Für die Adressierung der Bytes werden REAL-Werte verwendet, damit die + Größe nicht auf maxint beschränkt ist. Dies ist normalerweise sicher + (wegen der BCD-Arithmetik des Eumel), jedoch sind sinnlose nichtganzzahlige + Adressen dadurch möglich. Das wird aus Effizienzgründen nicht abgefangen, + die korrekte Benutzung liegt in der Verantwortung des Aufrufers. + Es sollen alle Zugriffe auf Module nur mit den Prozeduren dieses Pakets + abgewickelt werden. +*) + + +INT CONST high only ::-256, + low only :: 255; + +LET max page = 128; + +TYPE MODUL = STRUCT (ALIGN dummy, ROW 256 INT header, + ROW max page ROW 256 INT b, + INT dtcb abfragen, ccb abfragen, + TEXT dtcb ref, ccb ref, info); + +(* Der Typ kann wegen des ALIGN direkt auf einen Datenraum (für ein Modul) + gelegt werden. Der Teil b fasst 64kB Daten und kann direkt für blockout + verwendet werden. Die restlichen Teile sind nur für Module relevant. +*) + +INT CONST datenraumtyp modul :: 5687; (* Typ eines MODUL als Datenraum *) + +(*********************** INT ********************************************) + +INT PROC int (MODUL CONST m, REAL CONST byte nr) : + (* liefert das INT aus dem Modul m, das bei Byte "byte nr" beginnt *) + INT VAR page :: int (byte nr DIV 512.0) + 1, + nr :: int (byte nr MOD 512.0) DIV 2 + 1; + INT VAR whole int :: m.b[page][nr]; + IF byte nr MOD 2.0 <> 0.0 + THEN rotate (whole int, 8); (* high und low byte vertauschen *) + (whole int AND low only) + next byte in high + ELSE whole int FI. + +next byte in high : + IF nr = 256 THEN nr := 1; page INCR 1 ELSE nr INCR 1 FI; + INT VAR help :: m.b[page][nr] AND low only; + rotate (help, 8); + help. +END PROC int; + +INT PROC int (MODUL CONST m, INT CONST byte nr) : + int (m, real (byte nr)) +END PROC int; + +PROC int (MODUL VAR m, REAL CONST byte nr, INT CONST new) : + (* schreibt den neuen 16-Bit Wert new ab dem Byte "byte nr" in den Teil b + des Moduls m. Hier kommt es nicht sehr aufs Tempo an, deshalb benutzen + wir hier einfach "byte". + *) + INT VAR value :: new; + rotate (value, 8); (* high byte zu low byte machen *) + byte (m, byte nr, new AND low only); + byte (m, byte nr + 1.0, value AND low only); +END PROC int; + +PROC int (MODUL VAR m, INT CONST byte nr, INT CONST new) : + int (m, real (byte nr), new) +END PROC int; + +(************************** BYTE *******************************************) + +INT PROC byte (MODUL CONST m, REAL CONST byte nr) : + (* liefert das Byte mit der Nummer "byte nr" aus dem Teil b des Moduls m. + Das erste Byte hat die Nummer 0 + *) + INT CONST page :: int (byte nr DIV 512.0) + 1, + nr :: int (byte nr MOD 512.0) DIV 2 + 1; + INT VAR whole int :: m.b[page][nr]; + IF byte nr MOD 2.0 <> 0.0 + THEN rotate (whole int, 8); (* high und low byte vertauschen *) FI; + whole int AND low only. +END PROC byte; + +INT PROC byte (MODUL CONST m, INT CONST byte nr) : + byte (m, real (byte nr)) +END PROC byte; + +PROC byte (MODUL VAR m, REAL CONST byte nr, INT CONST new) : + (* Schreibt die unteren 8 bit von new an das Byte der Stelle byte nr im + Modul m + *) + INT CONST page :: int (byte nr DIV 512.0) + 1, + nr :: int (byte nr MOD 512.0) DIV 2 + 1; + INT VAR new byte :: new AND low only, + whole int :: m.b[page][nr]; + m.b[page][nr] := new int. + +new int : + IF byte nr MOD 2.0 = 0.0 (* low byte ändern ? *) + THEN (whole int AND high only) + new byte + ELSE rotate (new byte, 8); (* new nach high rotieren *) + new byte + (whole int AND low only) + FI. +END PROC byte; + +PROC byte (MODUL VAR m, INT CONST byte nr, INT CONST new) : + byte (m, real (byte nr), new) +END PROC byte; + +(*********************** TEXT ********************************************) + +TEXT PROC text (MODUL CONST m, REAL CONST first byte nr, INT CONST length) : + (* Extrahiert die naechsten length bytes aus m ab byte nr als TEXT *) + REAL VAR i :: first byte nr; + TEXT VAR result :: ""; + WHILE i < first byte nr + real (length) REP + result CAT code (byte (m, i)); + i INCR 1.0 + PER; + result. +END PROC text; + +TEXT PROC text (MODUL CONST m, INT CONST first byte nr, INT CONST length) : + text (m, real (first byte nr), length) +END PROC text; + +(* Ein schreibendes Analogon zu "text" gibt es nicht. *) + +(*********************** unsigned *****************************************) + +REAL PROC unsigned (INT CONST sixteen bits) : + (* hiermit kann man die Vorzeichenprobleme umschiffen, die der Eumel bei + INTs über maxint macht. + Liefert das INT als 16-Bit unsigned Wert interpretiert im REAL-Format. + *) + real (text (sixteen bits, dec)) +END PROC unsigned; + +INT PROC unsigned (REAL CONST sixteen bit value) : + (* Umkehrung des obigen : REAL 0..65536 rein, passenden 16 bit unsigned + Wert raus + *) + TEXT CONST t :: text (sixteen bit value); + int (unsigned (value text)). + +value text : + IF pos (t, ".") <> 0 + THEN subtext (t, 1, pos (t, ".") - 1) + ELSE t + FI. +END PROC unsigned; + +(******************** dtcb, ccb, info **************************************) + +INT PROC dtcb abfragen (MODUL CONST m) : + m.dtcb abfragen +END PROC dtcb abfragen; + +PROC dtcb abfragen (MODUL VAR m, INT CONST neu) : + m.dtcb abfragen := neu +END PROC dtcb abfragen; + +TEXT PROC dtcb refinements (MODUL CONST m) : + m.dtcb ref +END PROC dtcb refinements; + +PROC dtcb refinements (MODUL VAR m, TEXT CONST neu) : + m.dtcb ref := neu +END PROC dtcb refinements; + +INT PROC ccb abfragen (MODUL CONST m) : + m.ccb abfragen +END PROC ccb abfragen; + +PROC ccb abfragen (MODUL VAR m, INT CONST neu) : + m.ccb abfragen := neu +END PROC ccb abfragen; + +TEXT PROC ccb refinements (MODUL CONST m) : + m.ccb ref +END PROC ccb refinements; + +PROC ccb refinements (MODUL VAR m, TEXT CONST neu) : + m.ccb ref := neu +END PROC ccb refinements; + +TEXT PROC info (MODUL CONST m) : + m.info +END PROC info; + +PROC info (MODUL VAR m, TEXT CONST neu) : + m.info := neu +END PROC info; + +(********************* page **********************************************) + +(* Die Prozedur page dient dazu, aus dem Datenbereich b eines MODULs + einzelne Seiten (512 Byte Blöcke) in Form eines ROW 256 INT anzusprechen + um damit blockin/blockout zu machen. + Die Seitennummern gehen von 1 bis max page +*) + +ROW 256 INT PROC page (MODUL CONST m, INT CONST page nr) : + m.b[page nr] +END PROC page; + +PROC page (MODUL VAR m, INT CONST page nr, ROW 256 INT CONST new page) : + m.b[page nr] := new page +END PROC page; + +(*********************** copy ********************************************) + +PROC copy (MODUL CONST from, REAL CONST origin, + MODUL VAR to, REAL CONST destination, INT CONST length) : + (* Kopiert schnell eine Anzahl von Bytes aus einem Modul in ein anderes + die Optimierung klappt nur, wenn von einer geraden Adresse an eine + gerade Adresse kopiert wird oder von ungerade nach ungerade. + Macht cout. + *) + INT VAR i, interval :: cout interval; + REAL VAR offset :: 0.0; + IF length < 0 THEN errorstop ("copy : length = " + text (length)) FI; + IF origin MOD 2.0 <> destination MOD 2.0 + THEN copy slow + ELSE copy fast FI; + cout (length). + +cout interval : + IF length > 1024 THEN 32 + ELIF length > 64 THEN 8 + ELSE 1 FI. + +copy slow : + FOR i FROM 1 UPTO length REP + IF i MOD 2*interval = 0 THEN cout (i) FI; + byte (to, destination + offset, byte (from, origin + offset)); + offset INCR 1.0 + PER. + +copy fast : + IF origin MOD 2.0 <> 0.0 AND length > 0 + THEN byte (to, destination, byte (from, origin)); + offset := 1.0 + FI; + FOR i FROM 1 UPTO (length - int (origin MOD 2.0)) DIV 2 REP + INT CONST page1 :: int ((origin+offset) DIV 512.0) + 1, + nr1 :: int ((origin+offset) MOD 512.0) DIV 2 + 1, + page2 :: int ((destination+offset) DIV 512.0) + 1, + nr2 :: int ((destination+offset) MOD 512.0) DIV 2 + 1; + to.b[page2][nr2] := from.b[page1][nr1]; + IF i MOD interval = 0 THEN cout (2*i) FI; + offset INCR 2.0 + PER; + IF length - int (offset) = 1 + THEN byte (to, destination + offset, byte (from, origin + offset)) FI. +END PROC copy; + +(************************ Hilfsprozeduren ********************************) + +REAL OP DIV (REAL CONST a, b) : + floor (a/b) +END OP DIV; + +END PACKET setup eumel modulzugriffe; + + +(**************************************************************************) +(***** Zugriffe in Module mit Strukturwissen ****************) +(***** Copyright (c) 1988 by ****************) +(***** Lutz Prechelt, Karlsruhe ****************) +(**************************************************************************) + +PACKET setup eumel modul und shard zugriffe (* Copyright (c) 1988 by *) +DEFINES sh dtcb offset, (* Lutz Prechelt, Karlsruhe *) + sh ccb offset, (* Stand : 23.04.88 1.2 *) + get new channel table, (* Eumel 1.8.1 *) + init modules list, + all modules, + module type, + module name: + +(* Dieses Paket definiert Operationen zum Zugriff auf bestimmte Daten in + SHardmodulen und SHards. Es ist hierin Wissen über die Struktur dieser + Teile enthalten. + Beschreibung des SHardformats siehe setup eumel 4: modulkonfiguration +*) + +LET nr of channels total = 40, + offset channel table pointer = 10; + +THESAURUS VAR all the beautiful modules we know :: emptythesaurus; + +(******************* Kanaltabelle lesen/schreiben **************************) + +(* Hier geht schöne Struktur (und damit zugleich einfache Programmierung) + über gute Performance. (Wir lesen einiges mehrfach) +*) + +REAL PROC sh dtcb offset (MODUL CONST shard, INT CONST kanal) : + unsigned (int (shard, ct + 4 * kanal)). + +ct : + int (shard, offset channel table pointer). +END PROC sh dtcb offset; + +REAL PROC sh ccb offset (MODUL CONST shard, INT CONST kanal) : + unsigned (int (shard, ct + 4 * kanal + 2)). + +ct : + int (shard, offset channel table pointer). +END PROC sh ccb offset; + +PROC sh dtcb offset (MODUL VAR shard, INT CONST kanal, REAL CONST value) : + int (shard, ct + 4 * kanal, unsigned (value)). + +ct : + int (shard, offset channel table pointer). +END PROC sh dtcb offset; + +PROC sh ccb offset (MODUL VAR shard, INT CONST kanal, REAL CONST value) : + int (shard, ct + 4 * kanal + 2, unsigned (value)). + +ct : + int (shard, offset channel table pointer). +END PROC sh ccb offset; + +PROC get new channel table (MODUL CONST new shard, + ROW 256 INT VAR channel table of new shard) : + (* Kopiert die Kanaltabelle aus new shard nach + channel table of new shard + *) + INT VAR offset :: int (new shard, offset channel table pointer); + INT VAR i; + FOR i FROM 1 UPTO 2 * nr of channels total REP + channel table of new shard [i] := int (new shard, offset); + offset INCR 2 + PER. +END PROC get new channel table; + +(********************* modules list handling *****************************) + +TEXT VAR m list; + +PROC init modules list : + (* Baut in der Variablen m list einen "Assoziativspeicher" für + Modulnamen <--> Modultyp auf und erstellt eine Liste aller + Shardmoduldateinamen für "all modules" + Der Text m list enthält für jede Datei, die ein SHardmodul enthält, + einen Eintrag folgender Form : + ""0"", modultyp, ""0"", Dateiname, ""0"" + Dabei ist modultyp genau 4 Byte lang. + Diese Eintragsform ermöglicht ein (auf dem Eumel) sehr effizientes + Suchen, sowohl von Modultypen zu Modulnamen als auch umgekehrt. + Die Prozedur macht cout (dateinummer) + *) + INT VAR i; + TEXT VAR t; + m list := ""; all the beautiful modules we know := empty thesaurus; + FOR i FROM 1 UPTO highest entry (all) REP + cout (i); + t := name (all, i); + IF t <> "" CAND type (old (t)) = datenraumtyp modul + THEN add t FI + PER. + +add t : + insert (all the beautiful modules we know, t); + TEXT CONST typ :: read module type (t); + m list cat typmarker; + m list CAT t; + m list CAT ""0"". + +m list cat typmarker : + m list CAT ""0""; + m list CAT typ; + m list CAT ""0"". +END PROC init modules list; + +THESAURUS PROC all modules : + all the beautiful modules we know. +END PROC all modules; + +TEXT PROC read module type (TEXT CONST datei) : + (* Liefert den 4-Byte Modultyp des in der Datei datei enthaltenen + SHardmoduls, falls möglich, andernfalls "" + *) + IF NOT exists (datei) COR type (old (datei)) <> datenraumtyp modul + THEN "" + ELSE BOUND MODUL CONST m :: old (datei); + text (m, int (m, 8), 4) + FI. +END PROC read module type; + +TEXT PROC module type (TEXT CONST module name) : + (* Liefert den 4-Byte Modultyp zu module name aus m list, sofern vorhanden + andernfalls "" + *) + INT CONST p :: pos (m list, ""0"" + module name + ""0""); + IF p = 0 + THEN "" + ELSE subtext (m list, p - 4, p - 1) FI. +END PROC module type; + +TEXT PROC module name (TEXT CONST module type) : + (* Liefert den Moduldateinamen zum 4-Byte Modultyp module type, oder + "" falls kein solches Modul vorhanden. + *) + INT VAR p :: pos (m list, ""0"" + module type + ""0""); + IF p = 0 + THEN "" + ELSE p INCR 6; + subtext (m list, p, pos (m list, ""0"", p) - 1) + FI. +END PROC module name; + +END PACKET setup eumel modul und shard zugriffe; + diff --git a/system/setup/3.1/src/setup eumel 3: modulkonfiguration b/system/setup/3.1/src/setup eumel 3: modulkonfiguration new file mode 100644 index 0000000..529d0de --- /dev/null +++ b/system/setup/3.1/src/setup eumel 3: modulkonfiguration @@ -0,0 +1,854 @@ + +(**************************************************************************) +(***** Ergänzung des SHards um ein Modul (mit Dialog) *****************) +(***** Copyright (c) 1987, 1988 by *****************) +(***** Lutz Prechelt, Karlsruhe *****************) +(**************************************************************************) + +PACKET setup eumel modulkonfiguration (* Copyright (c) by *) +DEFINES configurate module, (* Lutz Prechelt, Karlsruhe *) + print configuration, (* Eumel 1.8.1 *) + give me, take you, (* Stand : 12.07.88 3.2 *) + new index, + perform dtcb dialogue, + perform ccb dialogue, + (* für Modulprogrammierer : *) + write info, + channel free, + reserve channel, + channels of this module, + buffer address : + +(* Dieses Modul führt den kompletten Dialog mit dem Benutzer durch, der + nötig ist, um alle Kanäle, die mit demselben Modul laufen sollen, zu + konfigurieren. + Verfahren : + im alten SHard den dtcb suchen + dtcb und Modul im neuen SHard eintragen + dtcb mit oder ohne Vorbild konfigurieren + alle ccbs zu dem Modul im alten SHard suchen und Kanalnummern merken + Auswahl einer Kanalmenge durch Benutzer mit alten als Vorschlag + ccbs in neuen SHard kopieren + ccbs mit oder ohne Vorbild konfigurieren + Kanaltabelle auf den neuen Stand bringen + neuen Shard und seine geänderte Länge zurückgeben + + Dabei kann der "Dialog" bei geeigneten Rahmenbedingungen durch bloßes + Übertragen der Werte aus einem Vorlage-SHard ersetzt werden, wenn der + Benutzer dies wünscht (want automatic mode). Dann geht alles von selbst. + (....kaufen Sie Setup-Eumel und es geht alles wie von selbst !) + +Format des SHard-Hauptmoduls : + 1. (Byte 0-2) jmp boot (3 Byte) + 2. (Byte 3) reserviert + 3. (Byte 4) SHard-Version + 4. (Byte 5) SHard-Release + 5. (Byte 6/7) SHardlänge (2 Byte) + 6. (Byte 8/9) Verweis auf Bad-Block Tabelle (2 Byte) + 7. (Byte 10/11) Verweis auf Kanaltabelle + 8. (Byte 16-175) Eumelleiste + 9. (Byte 176-299) SHardleiste + 10. (ab Byte 300) Shardhauptmodulroutinen und -daten + 11. (danach) Rumpf des Hauptmoduls mit Bad-Block-Tabelle, + Kanaltabelle, Routinen und Daten + 12. (danach) Folge der Module (bis Byte SHardlänge - 1) + +Kanaltabelle: + feste Länge 40 Einträge "nr of channels total" (Kanal 0 bis Kanal 39) + jeder Eintrag besteht aus : (alles 2 Byte) + offset dtcb, offset ccb + +Achtung : Dieses Programm schmiert bei SHards über 32767 Byte Länge + eventuell ab (es hat noch niemand probiert) ! + +Abkürzungen: cb steht für control block und meint entweder ccb oder dtcb + +Implementationsanmerkung : +Bei der Verwendung von THESAURUS wird von dem Wissen über die Art der +Implementation derselben Gebrauch gemacht, indem folgende Annahmen in den +Code eingehen: +1. Bei einem THESAURUS, in dem nicht gelöscht wurde, ist highest entry gleich + der Kardinalität +2. außerdem entspricht dann die Nummer (link) eines Eintrags seinem + Eintragszeitpunkt, d.h. der Position in der Eintragsfolge +3. + und - liefert THESAURi, in denen nicht gelöscht wurde und die Eintrags- + reihenfolge ist wie von den Parametern vorgegeben (bei + links zuerst) +4. certain und ONE liefern THESAURi, in denen nicht gelöscht wurde. +*) + +(************************* Daten ********************************) + +LET nr of channels total = 40, (* SHard Tabellenlänge *) + mdts = 40, (* max dialogtable size in INTs *) + mchm = 20, (* max channels for module *) + offset sh version = 4, + offset sh structureversion = 5, + offset shardlength = 6, + + do name = "PrOgRaM tO Do"; + +LET UNSIGNED = INT, + VARIABLES = ROW mdts ROW mchm INT; +TEXT CONST variables var xxv :: "ROW " + text (mdts) + " ROW "+ + text (mchm) + " INT VARxxv;"; + +VARIABLES VAR v; (* siehe give me / take you *) + +INT VAR max index; (* Information für new index *) + +INT VAR channels of module; (* Information für channels of this module *) + +TEXT VAR actual info; (* fuer write info *) + +ROW 256 INT VAR channel table of new shard; (* für channel free *) + +DATASPACE VAR dummy ds; (* für print configuration *) + +REAL VAR new shard length; + +(***************************************************************************) +(************* Hier geht's los...... ***************************************) +(***************************************************************************) + +(******************** configurate module **********************************) + +PROC configurate module (MODUL VAR new shard, MODUL CONST old shard, + BOOL CONST old shard valid, want automatic mode, + TEXT CONST modulname) : + do configurate module (new shard, old shard, old shard valid, + want automatic mode, modulname, FALSE) +END PROC configurate module; + +(********************** print configuration *******************************) + +PROC print configuration (MODUL CONST old shard, TEXT CONST modulname) : + (* Es ist hier schon sichergestellt, daß old shard valid ist und das Modul + auch im SHard enthalten + *) + forget (dummy ds); dummy ds := nilspace; + BOUND MODUL VAR dummy :: dummy ds; + do configurate module (dummy, old shard, TRUE, FALSE, modulname, TRUE); + forget (dummy ds). +END PROC print configuration; + + +(******************* do configurate module *********************************) + +PROC do configurate module (MODUL VAR new shard, MODUL CONST old shard, + BOOL CONST old shard valid, want automatic mode, + TEXT CONST modulname, + BOOL CONST print configuration only): + (* In dieser Prozedur ist die Beschränkung auf Module mit unter 32kB + Länge ausgenutzt. + Ist kein alter SHard vorhanden, so muss ein leerer SHard übergeben + werden (d.h. alle Einträge in der Kanaltabelle sind 0). + Ein alter SHard darf keinesfalls unterschiedliche releases desselben + Modultyps enthalten. + Resultierende SHardgesamtlängen von über 32k sind noch nicht getestet. + *) + BOUND MODUL VAR m; + INT VAR (***** Daten über das neue Modul *****) + sh version, sh structure version, release, + max ccb, nr of ccbs, + dtcb table entries, offset dtcb table, (* Variablentabellen *) + ccb table entries, offset ccb table, + muster ccb length, offset muster ccb, (* Muster-ccb im Modul *) + module body length, (* Länge des zu kopierenden Modulrumpfs *) + offset module body, offset dtcb; + TEXT VAR modultyp; (* 4 Byte *) + INT VAR (***** Daten über den alten SHard *****) + old release :: -2; (* garantiert inkompatibel *) + REAL VAR offset old dtcb :: 0.0; + ROW nr of channels total REAL VAR offset old ccb; + BOOL VAR old cbs valid :: FALSE; + THESAURUS VAR old channels :: empty thesaurus; + (***** Daten über den neuen SHard *****) + REAL VAR dtcb location; + ROW nr of channels total REAL VAR ccb location; + (***** Sonstige Daten *****) + INT VAR i, k, kanal, ccb count; + BOOL VAR automatic mode, configurate :: NOT print configuration only; + reset direction (FALSE); (* zur Sicherheit *) + IF configurate + THEN new shard length := unsigned (int (new shard, offset shard length)) FI; + connect module; + get module data; + test sh version compatibility; (* ggf. LEAVE *) + (* Bisher wurde nur gelesen, ab jetzt darf nicht mehr abgebrochen werden *) + search old shard for module and find all old ccbs; + test release compatibility; (* ggf. LEAVE *) + IF configurate + THEN write module with dtcb to shard; + perhaps set automatic mode; + FI; + configurate dtcb; + IF configurate + THEN kopf; + select channels; + write ccbs to shard; + ELSE nr of ccbs := highest entry (old channels) + FI; + configurate ccbs; + IF configurate + THEN make entries in channeltable of new shard; + int (new shard, offset shardlength, unsigned (new shard length)) + FI. + +connect module : + m := old (modulname); + actual info := info (m); + IF configurate + THEN kopf + ELSE put ("-----"); put (modulname); putline ("-----") + FI. + +get module data : + (* Format des Moduls in den ersten Bytes: + Byte Entry + 0/1 offset dtcb variablen tabelle + 2/3 offset ccb variablen tabelle + 4/5 offset muster-ccb + 6/7 offset modulrumpf + 8/9 offset dtcb + 10/11 max anzahl ccbs + die tabellen enthalten im ersten Wort die Anzahl ihrer Einträge + der modulrumpf und der ccb ihre Länge in Byte + die Länge der Tabellen ergibt sich aus den offset-Differenzen. + dtcb-Format : Modultyp (4 Byte) + SHardversion (1 Byte) + SHardstrukturversion (1 Byte) + Modulrelease (2 Byte) .... + *) + max ccb := int (m, 10); + offset dtcb table := int (m, 0); + dtcb table entries := int (m, offset dtcb table); + offset ccb table := int (m, 2); + ccb table entries := int (m, offset ccb table); + offset muster ccb := int (m, 4); + muster ccb length := int (m, offset muster ccb); + offset module body := int (m, 6); + module body length := int (m, offset module body); + offset dtcb := int (m, 8); +(***** +put (" offset dtcb table:"); put( offset dtcb table); line; +put (" dtcb table entrie:"); put( dtcb table entries); line; +put (" offset ccb table :"); put( offset ccb table); line; +put (" ccb table entrie:"); put( ccb table entries); line; +put (" offset muster ccb:"); put( offset muster ccb); line; +put (" muster ccb length:"); put( muster ccb length); line; +put (" offset module bod:"); put( offset module body); line; +put (" module body lengt:"); put( module body length); line; +put (" offset dtcb :"); put( offset dtcb); line;*****) + modultyp := text (m, offset dtcb, 4); + sh version := byte (m, offset dtcb + 4); + sh structureversion := byte (m, offset dtcb + 5); + release := int (m, offset dtcb + 6). + +test sh version compatibility : + IF configurate AND NOT version is compatible + THEN putline ("Das Modul ist mit dieser SHard-Version nicht mehr verträglich."); + putline (""10""10""15" Installation des Moduls wird abgebrochen. "14""7""13""10""); + go on; + LEAVE do configurate module + FI. + +version is compatible: + (* Kompatibel, wenn das Modul eine ältere oder gleiche sh version verlangt + und die gleiche sh structureversion + *) + sh version <= byte (new shard, offset sh version) CAND + sh structure version = byte (new shard, offset sh structureversion). + +search old shard for module and find all old ccbs : + (* Es werden alle Kanäle des alten SHard untersucht, ob der dortige Treiber + den gleichen Modultyp hat und in diesem Fall die Kanalnummer in + "old channels" gesammelt, sowie offset old ccb gemerkt, im Nichterfolgs- + falle wird offset old ccb auf diesem Kanal 0 gesetzt. + Es werden auch alle verketteten Treiber untersucht. + Auch old cbs valid und offset old dtcb werden ggf. gesetzt. + *) + IF NOT old shard valid + THEN LEAVE search old shard for module and find all old ccbs FI; + IF configurate THEN put ("Ich untersuche den alten SHard :") FI; + FOR kanal FROM 0 UPTO nr of channels total - 1 REP + IF configurate THEN cout (kanal) FI; + collect ccbs on this channel + PER; + IF configurate THEN put (""13""5"") FI. (* Zeile löschen *) + +collect ccbs on this channel : + REAL VAR p dtcb :: sh dtcb offset (old shard, kanal), + p ccb :: sh ccb offset (old shard, kanal); + WHILE p dtcb <> 0.0 AND p ccb <> 0.0 REP + BOOL CONST success :: text (old shard, p dtcb, 4) = modultyp; + IF success + THEN offset old dtcb := p dtcb; + old release := int (old shard, p dtcb + 6.0); + insert (old channels, text (kanal)); + offset old ccb [kanal+1] := p ccb + ELSE p dtcb := unsigned (int (old shard, p ccb + 2.0)); (* verkettet *) + p ccb := unsigned (int (old shard, p ccb + 4.0)) + FI + UNTIL success PER; + old cbs valid := old shard valid AND offset old dtcb <> 0.0 AND + (release = old release + 1 OR release = old release). + +test release compatibility: + IF print configuration only AND NOT old cbs valid + THEN putline ("Kein Zugriff auf die Konfigurationsdaten möglich"); + LEAVE do configurate module + FI. + +write module with dtcb to shard : + put ("Modul """ + modulname + """ wird in den SHard eingetragen :"); + IF int (new shard length MOD 2.0) <> offset module body MOD 2 + THEN new shard length INCR 1.0 FI; (* kopiert so schneller *) + dtcb location := new shard length + + real (offset dtcb - offset module body); + copy (m, real (offset module body), new shard, new shard length, + module body length); + new shard length INCR real (module body length). + +perhaps set automatic mode : + IF old cbs valid AND old release = release + THEN automatic mode := want automatic mode + ELSE automatic mode := FALSE FI. + +configurate dtcb : + IF configurate + THEN kopf; + putline ("Konfiguration des Treibers :"); + get new channel table (new shard, channel table of new shard); + FI; + perform dtcb dialogue (m, real (offset dtcb table+2), dtcb table entries, + new shard, dtcb location, + old shard, offset old dtcb, + old cbs valid, release = old release, + dtcb refinements (m), dtcb abfragen (m), + automatic mode, print configuration only). + +select channels : + ccb count := highest entry (old channels); + k := min (ccb count, max ccb); (* .... Mutter der Porzellankiste *) + nr of ccbs := max (k, 1); + IF automatic mode THEN LEAVE select channels FI; + IF max ccb > 1 + THEN REP + editget ("Wieviele Kanäle mit diesem Treiber (1 bis " + + text (max ccb) + ") : ", nr of ccbs); + out (""13"") + UNTIL nr of ccbs IN range (1, max ccb) PER; + out (""10""10"") + ELSE nr of ccbs := 1 FI; + IF nr of ccbs < ccb count (* weniger als früher *) + THEN put ("Wählen Sie mindestens"); putline (x kanäle aus deren); + putline ("Werte nicht als Vorbesetzung angeboten werden sollen"10""); + REP + THESAURUS CONST help :: certain (old channels, empty thesaurus); + IF NOT enough refused THEN out (""7"") FI + UNTIL enough refused PER; + old channels := old channels - help; + out (""3""3""3""4"") (* clear screen from incl. "Wählen..." on *) + FI. + +x kanäle aus deren : + IF ccb count - nr of ccbs > 1 + THEN text (ccb count - nr of ccbs) + " Kanäle aus, deren" + ELSE "einen Kanal aus, dessen" FI. + +enough refused : + highest entry (help) >= ccb count - nr of ccbs. + +write ccbs to shard : + (* Ausserdem wird hier ccb location vorbereitet *) + out ("Die Kanäle werden in den neuen SHard eingetragen : "); + FOR i FROM 1 UPTO nr of ccbs REP + ccb location [i] := new shard length; + copy (m, real (offset muster ccb + 2), new shard, new shard length, + muster ccb length); + new shard length INCR real (muster ccb length) + PER. + +configurate ccbs : + (*put (old shard valid); put ("Release:"); put (release); put (" old release:"); put (old release); + put (old cbs valid); pause;*) + IF configurate + THEN out (""13""10"Konfiguration der Kanäle:"13""10""); + get new channel table (new shard, channel table of new shard) + FI; + ccb count := 0; + FOR kanal FROM 0 UPTO nr of channels total REP + IF old channels CONTAINS text (kanal) + THEN ccb count INCR 1; + offset old ccb [ccb count] := offset old ccb [kanal+1] + FI + PER; + FOR i FROM ccb count + 1 UPTO nr of ccbs REP + offset old ccb [i] := 0.0 + PER; + perform ccb dialogue (m, real (offset ccb table+2), ccb table entries, + new shard, ccb location, + old shard, offset old ccb, + nr of ccbs, + offset old dtcb <> 0.0, release = old release, + ccb refinements (m), ccb abfragen (m), + automatic mode, print configuration only). + +make entries in channeltable of new shard : + kopf; + out ("Konfigurationsdaten werden in den neuen SHard eingetragen : "); + FOR i FROM 1 UPTO nr of ccbs REP + cout (i); + kanal := (*v[1][i]falsch???!!!*) byte (new shard, ccb location [i]); + make entry in channeltable of new shard + PER. + +make entry in channeltable of new shard : + IF NOT channel free (kanal) + THEN (* dtcb/ccb Adresse aus channel table nach neuem ccb umtragen. *) + int (new shard, ccb location [i] + 2.0, + unsigned (sh dtcb offset (new shard, kanal))); + int (new shard, ccb location [i] + 4.0, + unsigned (sh ccb offset (new shard, kanal))); + ELSE (* Folge-dtcb/ccb Adresse auf 0 setzen *) + int (new shard, ccb location [i] + 2.0, 0); + int (new shard, ccb location [i] + 4.0, 0); + FI; + (* Jetzt neue Adresse in channel table eintragen *) + sh dtcb offset (new shard, kanal, dtcb location); + sh ccb offset (new shard, kanal, ccb location [i]); + k := byte (new shard, ccb location [i] + 1.0); (* Zusatzkanalnummer *) + IF k <> 255 (* 255 = kein Zusatzkanal vorhanden *) + THEN (* IF NOT channel free (k) THEN alter eintrag futsch !!! *) + sh dtcb offset (new shard, k, dtcb location); + sh ccb offset (new shard, k, ccb location [i]) + FI. + +kopf : + write head ("""" + modulname + """ in den SHard aufnehmen"); + out (actual info); + out (""13""10""). +END PROC do configurate module; + + +(********************* perform dialogue ************************************) + +PROC perform dtcb dialogue + (MODUL VAR m, REAL CONST offset dialogue table, + INT CONST dialogue table entries, + MODUL VAR dtcb, REAL CONST offset dtcb, + MODUL CONST old dtcb, REAL CONST offset old dtcb, + BOOL CONST old dtcb valid, same release, + TEXT CONST refinements, INT CONST count, + BOOL CONST automatic mode, print configuration only): + ROW nr of channels total REAL VAR offset cb, offset old cb; + offset cb [1] := offset dtcb; + offset old cb [1] := offset old dtcb; + perform dialogue (TRUE, m, offset dialogue table, dialogue table entries, + dtcb, offset cb, old dtcb, offset old cb, 1, + old dtcb valid, same release, refinements, count, + automatic mode, print configuration only). +END PROC perform dtcb dialogue; + +PROC perform ccb dialogue + (MODUL VAR m, REAL CONST offset dialogue table, + INT CONST dialogue table entries, + MODUL VAR ccb, ROW nr of channels total REAL CONST offset ccb, + MODUL CONST old ccb, ROW nr of channels total REAL CONST offset old ccb, + INT CONST nr of ccbs, BOOL CONST old ccbs valid, same release, + TEXT CONST refinements, INT CONST count, + BOOL CONST automatic mode, print configuration only) : + perform dialogue (FALSE, m, offset dialogue table, dialogue table entries, + ccb, offset ccb, old ccb, offset old ccb, nr of ccbs, + old ccbs valid, same release, refinements, count, + automatic mode, print configuration only). +END PROC perform ccb dialogue; + + +PROC perform dialogue + (BOOL CONST is dtcb, + MODUL VAR m, REAL CONST offset dialogue table, + INT CONST dialogue table entries, + MODUL VAR cb, ROW nr of channels total REAL CONST offset cb, + MODUL CONST old cb, ROW nr of channels total REAL CONST offset old cb, + INT CONST nr of cbs, BOOL CONST old cb valid, same release, + TEXT CONST refinements, INT CONST refinement count, + BOOL CONST automatic mode, print configuration only) : + (* Konfigurationsdialog für einen (Satz von) Kontrollblock(s) oder bloßes + Anzeigen der Konfigurationsdaten derselben. + + 1. bei NOT print configuration only: + Führt den Dialog für eine Tabelle (also ccb oder dtcb Variablentabelle) + durch und bestückt den controlblock entsprechend. + Es wird gleich eine ganze Tabelle von controlblocks (max. mchm Stück) + abgearbeitet und zwar nr of cbs Stück; im Falle is dtcb wird natürlich + nur der Eintrag 1 der Tabellen benutzt (vom Aufrufer). + Das Eingabemodul ist m mit der zu bearbeitenden Tabelle an der Stelle + offset dialogue table. Die Tabelle enthält dialogue table entries + Einträge (max. mdts Stück !) + Die Ausgabe des Prozesses landet im Modul cb ab den Stellen offset cb. + cb ist dabei jeweils der neue SHard, damit man nicht das Modul ändert. + Die Vorlagen zum Abgucken liefert, falls old cb valid ist, das + Modul old cb (der alte SHard) ab offset old cb, dabei ist die Struktur + gleich der neuen, wenn same release gilt, andernfalls sind die + Vorversionsoffsets zu benutzen (Versionsnummer um genau 1 erhöht). + Bei automatic mode werden nur still diese Vorgabewerte übernommen. + Die Elan-Teile für den Dialog liefert schliesslich der Text refinements, + er enthält refinement count Abfragen der Namen r1, r2, ..... + Wenn refinent count = 0 ist, passiert hier eigentlich nichts, + deshalb sollte dann + für eine korrekte Initialisierung auch die Variablentabelle leer sein; + ist sie es allerdings doch nicht, werden hier noch die Standardwerte in + die ccbs eingetragen und nur der leere Dialog unterdrückt. + Vor Beginn/Nach Ende des gesamten Dialogs wird das refinement + dialoguestart/dialogueend aufgerufen; bei NOT is dtcb vor/nach dem Dialog + jedes Kanals auch noch channelstart/channelend. + + 2. bei print configuration only: + Die Daten zum new shard werden überhaupt nicht benutzt, von den + refinements wird nur für jeden Kanal einmal "print configuration" + aufgerufen. + *) + REAL VAR table byte :: offset dialogue table; + ROW mdts INT VAR offset, old offset, length; + INT VAR i, k; + BOOL VAR configurate :: NOT print configuration only; + TEXT VAR program, t; + IF print configuration only (* Hier wird evtl. schon verlassen *) + THEN startup for print + ELSE startup for dialogue FI; + IF refinement count > 0 THEN build program FI; + build data in v; + IF refinement count > 0 THEN do program FI; + IF configurate THEN put values in cb FI. + +startup for print : + IF refinement count = 0 OR dialogue table entries = 0 + THEN LEAVE perform dialogue FI. + +startup for dialogue: + IF refinement count = 0 + THEN putline ("Keine Konfiguration notwendig."); + IF dialogue table entries = 0 + THEN pause (20); LEAVE perform dialogue FI + ELSE putline ("Die Konfiguration wird vorbereitet.") FI. + +build program: + max index := refinement count; (* damit new index bescheid weiss *) + program := variables var xxv; + program cat main part; + perhaps program cat data refinements; + program CAT refinements. + +program cat main part : + program CAT "LET UNSIGNED=INT;giveme(xxv);INT VARxxi::1,actchannel;"; + IF print configuration only OR automatic mode + THEN program cat main part for print or automatic mode + ELSE program cat main part for dialogue FI. + +program cat main part for print or automatic mode: + (* Leider muss man, wenn man den Modulprogrammierer bei den .ccb und .dtcb + Teilen nicht zu stark reglementieren will, einiges mitübersetzen, was + dann gar nicht benutzt wird (z.B. alle Refinements). + Und der Gedanke macht ihn blaß, + wenn er fragt: was kostet das ? + Wilhelm Busch + *) + program CAT "FORactchannelFROM 1 UPTOchannelsofthismoduleREP"; + IF print configuration only + THEN program CAT "printconfigurationPER." + ELSE (* automatic mode: *) program CAT "automaticPER;takeyou(xxv)." + FI; + program CAT " xxa:actchannel. thischannel:"; + IF NOT is dtcb THEN program CAT "channelstart;" FI; + FOR i FROM 1 UPTO refinement count REP + program CAT "r"; (* Alle in this channel aufrufen, damit *) + program CAT text (i); (* "LEAVE this channel" kein Fehler ist. *) + program CAT ";" + PER; + IF NOT is dtcb + THEN program CAT "channelend" FI; + program CAT ". ". + +program cat main part for dialogue: + program CAT "dialoguestart;FORactchannelFROM 1 UPTOchannelsofthismoduleREP"; + program CAT "thischannelPER;dialogueend;takeyou(xxv). "; + program CAT "xxa:actchannel. thischannel:"; + IF NOT is dtcb THEN program CAT "channelstart;" FI; + program CAT "REP SELECTxxiOF "; + FOR i FROM 1 UPTO refinement count REP + program CAT "CASE "; + program CAT text (i); + program CAT ":r"; + program CAT text (i); + program CAT " " + PER; + program CAT "ENDSELECT UNTIL NOTnewindex(xxi)PER"; + IF NOT is dtcb + THEN program CAT ";channelend;reservechannel(xxv[1][xxa])" FI; + program CAT ". ". + +perhaps program cat data refinements : + FOR i FROM 1 UPTO dialogue table entries REP + IF configurate THEN cout (i) FI; + read start of next table entry; (* must be done in autom. mode, too, *) + t := next variable name; (* to get offset/oldoffset/length [i] *) + program CAT t; + program CAT ":xxv["; + program CAT text (i); + program CAT "][xxa]. "; (* Das war der normale Eintrag "varname" *) + program CAT t; (* Jetzt der für alle Kanäle "varname k" *) + program CAT "k:xxv["; + program CAT text (i); + program CAT "]. " + PER. + +read start of next table entry : + (* Format der Einträge in den Variablentabellen: + dw offset in cb + dw offset in old cb (oder ffffh falls neu) + db Typ (d.h. Länge und ist 1 oder 2) + db Namenslänge + db ...(Name)... + *) + INT CONST length of variable :: byte (m, table byte + 4.0), + length of name :: byte (m, table byte + 5.0); + old offset [i] := int (m, table byte + 2.0); (* Diese Sammlung *) + offset [i] := int (m, table byte); (* bereitet das Datenholen vor *) + length [i] := length of variable; + IF length of variable < 1 OR length of variable > 2 + THEN errorstop ("invalid variablelength : " + text (length of variable)) + FI; + table byte INCR 6.0. + +next variable name: + table byte INCR real (length of name); + text (m, table byte - real (length of name), length of name). + +build data in v : + FOR k FROM 1 UPTO nr of cbs REP (* Kanäle *) + IF configurate THEN cout (k) FI; + FOR i FROM 1 UPTO dialogue table entries REP (* Variablen *) + v[i][k] := next init value + PER + PER. + +next init value : + IF old cb valid CAND old cb present CAND value accessible + THEN value from old cb + ELSE value from new cb FI. + +old cb present : + offset old cb [k] > 0.0. + +value accessible : + same release OR + (* Ein release zuvor und Variable gibts schon: *) old offset [i] <> -1. + +value from old cb : + IF length [i] = 1 + THEN byte (old cb, offset old cb [k] + real (offset of old value)) + ELSE int (old cb, offset old cb [k] + real (offset of old value)) + FI. + +value from new cb : + IF length [i] = 1 + THEN byte (cb, offset cb [k] + real (offset [i])) + ELSE int (cb, offset cb [k] + real (offset [i])) FI. + +offset of old value : + IF same release + THEN offset [i] + ELSE old offset [i] FI. + +do program : + reset direction (TRUE); + channels of module := nr of cbs; + IF setup testing + THEN (* für diesen THEN-Teil beim abgespeckten Eumel + setup eummel mini eumel dummies insertieren *) + forget (do name, quiet); + FILE VAR f := sequentialfile (output, do name); + putline (f, program); + (*edit (do name);*) + run (do name); + forget(do name, quiet); + ELSE do (program); + FI; + program := ""; (* Platz sparen *) + reset direction (FALSE). + +put values in cb : + FOR k FROM 1 UPTO nr of cbs REP + cout (k); + FOR i FROM 1 UPTO dialogue table entries REP + IF length [i] = 1 THEN put byte ELSE put int FI + PER; + PER. + +put byte : + byte (cb, offset cb [k] + real (offset [i]), v[i][k]). + +put int : + int (cb, offset cb [k] + real (offset [i]), v[i][k]). +END PROC perform dialogue; + +(****************** give me, take you, new index ***************************) + +(* Diese Prozeduren werden aus dem do beim perform dialogue heraus aufgerufen + Sie dienen zur Kommunikation mit den Paketdaten dieses Pakets (give me, + take you) oder zur Verkleinerung des do-Programms (new index) +*) + +PROC give me (VARIABLES VAR variables) : + (* Der Sinn dieser Prozedur besteht in Folgendem : + bei perform dialogue wird in dem do, das die refinements des + SHard-Moduls ausführt, eine Datenstruktur vom Typ VARIABLES aufgebaut, + die alle in den Variablentabellen des Moduls aufgeführten Variablen + enthält und einzeln über passend benannte refinements zugänglich macht. + Diese Datenstruktur wird zuvor in diesem Paket hier initialisiert mit + Initwerten aus der Variablentabelle oder wenn möglich mit den + entsprechenden Werten aus dem alten SHard. Mit give me fordert das + do-Programm die initialisierte Datenstruktur aus diesem Paket hier an. + Im do wird am Schluss mit take you diese Datenstruktur an dieses Paket + (und damit an perform dialogue) zurückgegeben, damit die durch den + Dialog gesetzten Werte in den neuen SHard eingetragen werden können. + Eine alternative Methode, diese Kommunikation zu realisieren, wäre die + Benutzung von BOUND VARIABLES VARs mit demselben Datenraum. + *) + variables := v +END PROC give me; + +PROC take you (VARIABLES CONST variables) : + (* Gegenstück zu give me, siehe dort *) + v := variables +END PROC take you; + +BOOL PROC new index (INT VAR index) : + (* Verändert den Index je nach der direction und fragt bei down am Ende, + ob fertig. Liefert, ob es noch weitergehen soll (falls nein: index = 1) + *) + LET up = ""3"", + down = ""10"", + error = ""0""; + TEXT CONST old direction :: direction; + reset direction (TRUE); + IF old direction = error (* Bei Fehlern immer stehenbleiben *) + THEN TRUE + ELIF index = max index (* am Schluss aufhören oder nach 1 springen *) + THEN perhaps end + ELIF index = 1 AND old direction = up (* bei 1 und up an den Schluss *) + THEN index := max index; TRUE + ELSE normal new index (* sonst je nach direction up oder down *) + FI. + +perhaps end : (* index = max index *) + IF old direction = up AND max index > 1 (* hoch vom Ende *) + THEN index DECR 1; + TRUE + ELIF old direction = up + THEN TRUE + ELIF old direction = down (* runter am Ende *) + THEN index := 1; + TRUE + ELSE reset direction (FALSE); (* normal oder runter ans Ende *) + index := 1; + BOOL CONST ready :: yes (1, 23, "Fertig", FALSE); + reset direction (TRUE); + NOT ready + FI. + +normal new index : + IF old direction = up + THEN index DECR 1; TRUE + ELSE index INCR 1; TRUE FI. +END PROC new index; + +(******************** channel (table) handling *****************************) + +BOOL PROC channel free (INT CONST nr, + ROW 256 INT CONST channel table of shard) : + IF nr < 0 OR nr > nr of channels total + THEN FALSE + ELSE channel table of shard [index ccb offset] = 0 FI. + +index ccb offset : + 2 * nr + 1 + 1. +END PROC channel free; + +BOOL PROC channel free (INT CONST nr) : + channel free (nr, channel table of new shard). +END PROC channel free; + +PROC reserve channel (INT CONST nr, + ROW 256 INT VAR channel table of shard) : + IF nr >= 0 AND nr < nr of channels total + THEN channel table of shard [index ccb offset] := 1 (* nichtnull *) FI. + +index ccb offset : + 2 * nr + 1 + 1. (* Start nicht bei 0 und ccb hinter dtcb *) +END PROC reserve channel; + +PROC reserve channel (INT CONST nr) : + reserve channel (nr, channel table of new shard). +END PROC reserve channel; + +(*THESAURUS PROC free channels (ROW 256 INT VAR channel table of shard): + (* Liefert einen THESAURUS, der die Klartextform genau aller in + channel table of shard als frei angegebenen Kanäle enthält. + *) + INT VAR i; + THESAURUS VAR result :: empty thesaurus; + FOR i FROM 1 UPTO nr of channels total REP + IF channel free (i, channel table of shard) + THEN insert (result, text (i)) FI + PER; + result. +END PROC free channels;*) + +INT PROC channels of this module : + channels of module. +END PROC channels of this module; + +(********************* write info, buffer adress **************************) + +PROC write info : + putline (actual info) +END PROC write info; + +INT PROC buffer address (INT CONST buffer size): + IF new shard length MOD 2.0 <> 0.0 THEN new shard length INCR 1.0 FI; + INT CONST buf adr := unsigned (new shard length); + new shard length INCR real (buffer size); + IF new shard length >= 65536.0 OR buffer size > 1024 + THEN errorstop ("zu großer Puffer verlangt") + FI; + buf adr +END PROC buffer address; + +(************************* Hilfsprozeduren *******************************) + +PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line, + INT VAR start module nr, BOOL CONST new init, ins, dump, lst, + sys, coder, rt check, sermon) : + EXTERNAL 256 +END PROC elan; + +PROC do (TEXT CONST long line) : + DATASPACE VAR ds; + INT VAR module nr :: 0; + elan (2, ds, long line, module nr, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE); + forget (ds); + no do again +END PROC do; + +PROC go on : + put (" >>>>> Taste drücken zum Weitermachen "); + REPEAT UNTIL incharety (2) = "" PER; + pause; + line. +END PROC go on; + +END PACKET setup eumel modulkonfiguration; + diff --git a/system/setup/3.1/src/setup eumel 4: dienstprogramme b/system/setup/3.1/src/setup eumel 4: dienstprogramme new file mode 100644 index 0000000..9ce9ca3 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 4: dienstprogramme @@ -0,0 +1,218 @@ + +(**************************************************************************) +(***** Dienstprogramme für Modulprogrammierer *****************) +(***** Copyright (c) 1987, 1988 *****************) +(***** Lutz Prechelt, Karlsruhe *****************) +(**************************************************************************) + +PACKET setup eumel dienstprogramme (* Copyright (c) 1987 by *) +DEFINES (* Lutz Prechelt, Karlsruhe *) + file as one text, (* Stand : 07.05.88 1.4 *) + ich schreibe jetzt ein neues shard modul, (* Eumel 1.8.1 *) + link shard module, + all modules: + +(* Dies sind Dienstprogramme, die der Modul-Programmierer braucht *) + +(* Das Format der Refinementdateien für den dtcb- und ccb-Setupdialog ist wie + folgt: + 1. Zeile: INT-Denoter für die Anzahl von Abfragerefinements, die drin sind + Rest der Zeile muß leer sein. + Danach : lauter ELAN-Refinements mit den Namen r1, r2 usw. + evtl. weitere Refinements zur Hilfe mit beliebigen Namen (es + gibt ein paar Ausnahmen, über die man beim ersten Test dann aber + stolpert.) + In den Refinements dürfen Variablen vereinbart werden. Vor dem ersten + refinement der Datei darf KEIN Punkt sein (es ist sowieso schlechter + Stil, die Punkte nicht hinter die vorherige Zeile zu setzen, sondern + vor den refinementnamen.), hingegen MUSS nach dem letzten Refinement der + Datei ein Punkt stehen. + Wer das für nötig hält, kann auch Prozeduren definieren und verwenden, + was allerdings nicht geht, sind Pakete. + Wenn man mit Kommentaren und sonstigen Bytefressern sparsam + umgeht, läuft der Dialog beim Setup später etwas schneller an. +*) + +LET modul namentyp = "SHardmodul *"; + +DATASPACE VAR ds; + +(***************************************************************************) + +THESAURUS PROC all modules (THESAURUS CONST th): + (* Hier wird schlabberig nach Namen ausgewählt, während der Setup Eumel + im Betrieb die Datenraumtypen als Auswahlkriterium verwendet. + Die Schwierigkeiten, die bei Nichteinhalten der Namenskonventionen + entstehen, veranlassen hoffentlich jeden zur nötigen Disziplin... + *) + (th LIKE "SHardmodul *") - (th LIKE "SHardmodul *.ccb") + - (th LIKE "SHardmodul *.dtcb") - (th LIKE "SHardmodul *.info") +END PROC all modules; + +(*****THESAURUS PROC all modules: wird sauber in Teil 2 realisiert + all modules (all) +END PROC all modules; +*****) + +(********************* link shard module *********************************) + +PROC link shard module: + TEXT VAR module :: std; + REPEAT + page; + putline (" L I N K S H A R D - M O D U L E"); line (2); + put ("Modulname:"); editget (module); line (2); + link shard module (module); line; + UNTIL NOT yes ("noch ein Modul linken", FALSE) PER +END PROC link shard module; + +PROC link shard module (THESAURUS CONST th): + do (PROC (TEXT CONST) link shard module, th); +END PROC link shard module; + +PROC link shard module (TEXT CONST module): + (* Ruft link shard module (modul, dtcb, ccb, info) unter Anwendung von + Namenskonventionen (nämlich entsprechende Suffixe ".dtcb" etc.) auf. + *) + TEXT VAR dtcb, ccb, info; + BOOL VAR elan neu; + dtcb := module + ".dtcb"; + ccb := module + ".ccb"; + info := module + ".info"; + perhaps change filenames; + elan neu := yes (module + ": neue Elan Teile machen", FALSE); + IF elan neu THEN neue elan teile machen FI; + link shard module (module, dtcb, ccb, info); + IF elan neu THEN check syntax FI. + +neue elan teile machen: + edit (dtcb); line (2); + edit (ccb); line (2); + edit (info); page. + +perhaps change filenames: +(*put ("Datei mit dtcb-refinements :"); editget (dtcb); line; + put ("Datei mit ccb-refinements :"); editget (ccb); line; + put ("Datei mit Infotext :"); editget (info); line (2)*) . + +check syntax : + line (2); put (module); putline (": Syntax-Check"); + forget (ds); + ds := nilspace; + BOUND MODUL VAR m :: old (module), old shard :: ds, new shard :: ds; + INT VAR offset dtcb table :: int (m, 0), + dtcb table entries :: int (m, offset dtcb table), + offset ccb table :: int (m, 2), + ccb table entries :: int (m, offset ccb table); + (* Jetzt einen total verkrüppelten automatischen "perform dialogue" für + die Probeübersetzung der .dtcb und .ccb refinements aufrufen. + *) + perform dtcb dialogue (m, real (offset dtcb table+2), dtcb table entries, + new shard, 0.0, + old shard, 0.0, + FALSE, FALSE, + dtcb refinements (m), dtcb abfragen (m), + TRUE, FALSE); + putline ("dtcb refinements O.K."); + ROW 40 REAL VAR x :: ROW 40 REAL : (0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0); + perform ccb dialogue (m, real (offset ccb table+2), ccb table entries, + new shard, x, + old shard, x, + 1, + FALSE, FALSE, + ccb refinements (m), ccb abfragen (m), + TRUE, FALSE); + putline ("ccb refinements O.K."); + forget (ds). +END PROC link shard module; + +PROC link shard module (TEXT CONST module, dtcb, ccb, infofile) : + IF type (old (module)) <> datenraumtyp modul CAND NOT typ aendern + THEN LEAVE link shard module + ELSE type (old (module), datenraumtyp modul) FI; + IF NOT (module LIKE modul namentyp) + THEN errorstop ("Module MÜSSEN Namen der Art """ + modul namentyp + + """ haben") + FI; + line; + BOUND MODUL VAR m :: old (module); + TEXT VAR dtcb ref :: file as one text (dtcb, FALSE), + ccb ref :: file as one text (ccb, FALSE), + info text:: file as one text (infofile, TRUE); + INT CONST pos dtcb :: pos (dtcb ref, " "), (* Ende der ersten Zeile, die *) + pos ccb :: pos (ccb ref, " "); (* die Abfragezahl enthält *) + INT VAR dtcb count, ccb count; + dtcb count := int (subtext (dtcb ref, 1, pos dtcb)); + IF NOT last conversion ok OR dtcb count < 0 OR dtcb count > 1000 + THEN errorstop ("keine vernünftige Zahl von dtcb Abfragen gefunden") FI; + ccb count := int (subtext (ccb ref, 1, pos ccb)); + IF NOT last conversion ok OR ccb count < 0 OR ccb count > 1000 + THEN errorstop ("keine vernünftige Zahl von ccb Abfragen gefunden") FI; + (* JETZT PASSIERTS : *) + dtcb abfragen (m, dtcb count); + dtcb refinements (m, subtext (dtcb ref, pos dtcb + 1)); + ccb abfragen (m, ccb count); + ccb refinements (m, subtext (ccb ref, pos ccb + 1)); + info (m, infotext); + line; + putline (""""+module+""" gelinkt. " + text (storage (old (module))) + + " K Datenraumgröße."). + +typ aendern : + IF type (old (module)) = 1003 (* file type *) + THEN putline ("(""" + module + """ hat den Typ FILE)") FI; + putline ("Achtung: """ + module + """ ist nicht vom Typ eines SHard-Moduls"); + yes ("Soll es dazu gemacht werden (Typ aufprägen)", FALSE). +END PROC link shard module; + +(******************** file as one text ************************************) + +TEXT PROC file as one text (TEXT CONST filename, BOOL CONST verbatim) : + FILE VAR f :: sequential file (input, filename); + TEXT VAR result :: "", t; + put ("Lese """ + filename + """ :"); + WHILE NOT eof (f) REP + cout (line no (f)); + getline (f, t); + work on t; + result CAT t + PER; + line; + result. + +work on t : + IF verbatim + THEN t CAT ""13""10"" + ELSE t := compress (t); t CAT " " FI. +END PROC file as one text; + +(****** ich schreibe jetzt ein neues shard modul ***************************) + +PROC ich schreibe jetzt ein neues shard modul : + line (2); + putline ("So so, Sie wollen also ein neues SHard-Modul schreiben."); line; + pause (20); + putline ("Mir kommt es so vor, als sei heute der " + date + + " und im Moment gerade " + time of day + " Uhr"); line; + IF NOT yes ("Stimmt das ungefähr (auf 5 Minuten kommt's nicht an)", TRUE) + THEN do ("set date"); line (2) FI; + putline ("Also gut. Schreiben Sie Ihr verdammtes Modul."); + putline ("Aber merken Sie sich die folgenden 4 Bytes als ihren Modultyp"); + put (""15" "); + REAL VAR x :: floor (clock (1) - date ("05.05.79") - time ("10:00:00")); + INT VAR i; + FOR i FROM 1 UPTO 4 REP + put (int (x MOD 256.0)); + x := floor (x / 256.0) + PER; + put (" "14""); line (2); + putline ("Also : die Dinger merken (schreiben Sie sie auf, sonst vergessen Sie"); + putline (" sie ja doch) und NICHT MEHR ÄNDERN !"); + line (3) +END PROC ich schreibe jetzt ein neues shard modul; + +END PACKET setup eumel dienstprogramme; + diff --git a/system/setup/3.1/src/setup eumel 5: partitionierung b/system/setup/3.1/src/setup eumel 5: partitionierung new file mode 100644 index 0000000..705f26d --- /dev/null +++ b/system/setup/3.1/src/setup eumel 5: partitionierung @@ -0,0 +1,435 @@ +PACKET setup eumel partitionierung (* Copyright (C) 1985 *) + (* Martin Schönbeck, Spenge *) +DEFINES tracks, (* Lutz Prechelt, Karlsruhe *) + sectors, (* Änderungen: Ley ms *) + heads, (* Stand: 07.04.89 *) + first track, + last track, + partition start, + partition type, + partition active, + partition size, + partition word 0, + + get boot block, + put boot block, + clear partition, + + (*get bad track table,*) + get bad sector table, + clear partition table, + setup channel, + start of partition: + + LET bst size = 1024; (* nr of bad sector table entrys *) + +ROW 256 INT VAR boot block; +INT VAR boot block session := session - 1; +INT VAR fd channel := 28; (* Festplatten-Setupkanal *) + +INT PROC setup channel: + fd channel +END PROC setup channel; + +PROC setup channel (INT CONST new channel): + enable stop; + teste kanal typ; + boot block session DECR 1; + wirf altes pac raus; + fd channel := new channel; + sorge dafuer dass kanal uptodate ist. + +teste kanal typ: + IF (get value (1, new channel) AND 12) <> 12 + THEN errorstop ("Hier gibt es leider keine Platte") + FI. + +wirf altes pac raus: + IF new channel <> fd channel + THEN INT VAR raus := get value (-13, fd channel); + FI. + +sorge dafuer dass kanal uptodate ist: + INT VAR old channel := channel; + ROW 256 INT VAR dummy; INT VAR i; + continue (new channel); + disable stop; + blockin (dummy, -1, -1, i); + break (quiet); + continue (old channel). + +END PROC setup channel; + +PROC get bad sector table (ROW bst size REAL VAR bb tab, + INT VAR bad sect, INT CONST eumel type): + initialisiere tabelle; + suche schlechte sectoren. + +initialisiere tabelle: + INT VAR i; + FOR i FROM 1 UPTO bst size REP + bb tab [i] := -1.0; + PER. + +suche schlechte sectoren: + INT VAR my channel := channel; + REAL VAR sector := start of partition (eumel type), + end := sector + partition size (partition number (eumel type)), + track mode restart :: 0.0; + INT VAR akt track := 0, + fehler code; + bad sect := 1; (* Eintragsnr. des NÄCHSTEN schlechten Sektors *) + continue (fd channel); + disable stop; + DATASPACE VAR ds := nilspace; + REAL CONST cylinder size :: real (sectors * heads), + track size :: real (sectors); + track mode restart := sector + track size - + (sector MOD track size); + (* wenn sector nicht erster der spur, dann die erste einzeln *) + WHILE sector < end REP + IF sector MOD cylinder size = 0.0 + THEN melde naechste spur FI; + IF sector >= track mode restart + THEN check track + ELSE check sector FI + UNTIL bad sect > bst size OR is error PER; + continue (my channel); + forget (ds); + enable stop; + IF bad sect > bst size + THEN errorstop ("Zu viele schlechte Sektoren"); + FI; + lass nicht zu dass ein ersatzsektor ein schlechter ist; + bad sect DECR 1. (* ANZAHL schlechter Sektoren *) + +melde naechste spur: + break (quiet); + continue (my channel); + akt track INCR 1; + cout (akt track); + continue (fd channel). + +check track : + verify track (ds, 2, sector, fehler code); + IF schlechten sektor gefunden + THEN track mode restart := sector + tracksize + ELSE sector INCR track size FI. + +check sector : + read block (ds, 2, sector, fehler code); + IF schlechten sektor gefunden + THEN eintragen FI; + sector INCR 1.0. + +schlechten sektor gefunden: + SELECT fehler code OF + CASE 0: FALSE + CASE 1: error stop ("Platte kann nicht gelesen werden"); FALSE + CASE 2: TRUE + CASE 3: error stop ("Versorgungsfehler beim Plattentest"); FALSE + OTHERWISE error stop ("unbekannter Fehler auf Platte"); FALSE + END SELECT. + +eintragen: + bb tab [bad sect] := sector; + bad sect INCR 1. + +lass nicht zu dass ein ersatzsektor ein schlechter ist: + REAL VAR aktueller ersatz := end - real (bad sect - 1); + INT VAR akt b sect; + FOR akt b sect FROM 1 UPTO bad sect - 1 REP + IF aktueller ersatz ist in tabelle + THEN vertausche aktuell zu ersetzenden mit ihm + FI; + PER. + +aktueller ersatz ist in tabelle: + INT VAR such index; + FOR such index FROM 1 UPTO bad sect REP + IF aktueller ersatz = bb tab (such index) + THEN LEAVE aktueller ersatz ist in tabelle WITH TRUE + FI; + PER; + FALSE. + +vertausche aktuell zu ersetzenden mit ihm: + bb tab ( such index ) := bb tab ( akt b sect ); + bb tab (akt b sect) := aktueller ersatz. +END PROC get bad sector table; + +INT PROC cyl and head (REAL CONST sector): + cylinder code (int (sector / real (sectors)) DIV heads) OR head. + +head : + (int (sector / real (sectors)) MOD heads). +END PROC cyl and head; + +PROC get boot block: + IF boot block session <> session + THEN hole aktuellen boot block + FI. + +hole aktuellen bootblock : + disable stop; + DATASPACE VAR dummy ds := nilspace; + BOUND STRUCT (ALIGN dummy, + ROW 256 INT block) VAR partition table := dummy ds; + get external block (dummy ds, 2, 0, fd channel); + IF NOT is error + THEN transfer data to boot block + FI; + forget (dummy ds). + +transfer data to boot block: + IF not valid boot block + THEN try to get valid boot block from file + FI; + boot block := partition table. block; + boot block session := session. + +not valid boot block: + partition table. block [256] <> boot indicator OR + it is an old boot block of eumel. + +boot indicator: -21931. + +it is an old boot block of eumel: + partition table. block [1] = 1514. + +try to get valid boot block from file: + forget (dummy ds); + partition table := old ("bootblock"); + IF is error THEN LEAVE transfer data to boot block FI. +END PROC get boot block; + +PROC clear partition table (INT CONST sicherung): + IF sicherung = -3475 + THEN neuen boot block; + put boot block + FI. + +neuen boot block: + enable stop; + BOUND STRUCT (ALIGN dummy, + ROW 256 INT block) VAR partition table; + partition table := old ("bootblock"); + boot block := partition table. block; + boot block session := session. +END PROC clear partition table; + +PROC put boot block: + IF boot block ist uptodate + THEN schreibe block auf platte + ELSE errorstop ("boot block nicht uptodate") + FI. + +boot block ist uptodate: + boot block session = session. + +schreibe block auf platte: + disable stop; + DATASPACE VAR dummy ds := nilspace; + BOUND STRUCT (ALIGN dummy, + ROW 256 INT block) VAR partition table := dummy ds; + transfer data to dataspace; + put external block (dummy ds, 2, 0, fd channel); + forget (dummy ds). + +transfer data to dataspace: + partition table. block := boot block. +END PROC put boot block; + +INT PROC partition number (INT CONST part type): + INT VAR partition; + FOR partition FROM 1 UPTO 4 REP + IF partition type (partition) = part type + THEN LEAVE partition number WITH partition + FI + PER; + errorstop ("Partitiontyp gibt es nicht"); + 7. +END PROC partition number; + +INT PROC partition word 0 (INT CONST partition): + boot block (entry (partition)) +END PROC partition word 0; + +PROC partition word 0 (INT CONST partition, word): + boot block (entry (partition)) := word +END PROC partition word 0; + +REAL PROC start of partition (INT CONST partition type): + partition start (partition number (partition type)) +END PROC start of partition; + + +INT PROC first track (INT CONST partition): + high byte (boot block [entry (partition) + 1]) + + 4 * (low byte (boot block [entry (partition) + 1]) AND (128 + 64)) +END PROC first track; + +INT PROC last track (INT CONST partition): + high byte (boot block [entry (partition) + 3]) + + 4 * (low byte (boot block [entry (partition) + 3]) AND (128 + 64)) +END PROC last track; + +INT PROC partition type (INT CONST partition): + low byte (boot block [entry (partition) + 2]) +END PROC partition type; + +BOOL PROC partition active (INT CONST partition): + low byte (boot block [entry (partition)]) = 128 +END PROC partition active; + +(****************** neu eingefügt ******************************) +PROC partition active (INT CONST partition, BOOL CONST active): + IF active THEN activate this partition + ELSE deactivate this partition + FI. + +deactivate this partition: + set bit (boot block [entry (partition)], 7); + (* first setting needed, because reset bit does xor *) + reset bit (boot block [entry (partition)], 7). + +activate this partition: + set bit (boot block [entry (partition)], 7). +END PROC partition active; + +(****************** neu eingefügt ******************************) + +PROC first track (INT CONST partition, cylinder): + boot block [entry (partition) + 1] + := cylinder code (cylinder) OR start sector. + +start sector: + IF cylinder = 0 + THEN 2 + ELSE 1 + FI. +END PROC first track; + +PROC last track (INT CONST partition, cylinder): + boot block [entry (partition) + 3] := cylinder code (cylinder). +END PROC last track; + +PROC partition type (INT CONST partition, type): + boot block [entry (partition) + 2] := type. +END PROC partition type; + +REAL PROC partition start (INT CONST partition): + unsigned low word + high word. + +unsigned low word: + real (low byte (boot block [entry (partition) + 4])) + + real (high byte (boot block [entry (partition) + 4])) * 256.0. + +high word: + real (boot block [entry (partition) + 5]) * 65536.0. +END PROC partition start; + +PROC partition start (INT CONST partition, REAL CONST sector offset): + boot block [entry (partition) + 4] := low word (sector offset); + boot block [entry (partition) + 5] := high word (sector offset) +END PROC partition start; + +REAL PROC partition size (INT CONST partition): + unsigned low word + high word. + +unsigned low word: + real (low byte (boot block [entry (partition) + 6])) + + real (high byte (boot block [entry (partition) + 6])) * 256.0. + +high word: + real (boot block [entry (partition) + 7]) * 65536.0. +END PROC partition size; + +PROC partition size (INT CONST partition, REAL CONST number of blocks): + boot block [entry (partition) + 6] := low word (number of blocks); + boot block [entry (partition) + 7] := high word (number of blocks) +END PROC partition size; + +PROC clear partition (INT CONST partition): + INT VAR i; + FOR i FROM 0 UPTO 7 REP + boot block [entry (partition) + i] := 0 + PER +END PROC clear partition; + +INT PROC entry (INT CONST partition): + get boot block; + 256 - 5 * 8 + (partition * 8) +END PROC entry; + +INT PROC cylinder code (INT CONST cylinder): + cylinder text ISUB 1. + +cylinder text: + high cylinder bits + low cylinder bits. + +high cylinder bits: + code ((cylinder AND (256 + 512)) DIV 4). + +low cylinder bits: + code (cylinder AND (128 + 64 + 32 + 16 + 8 + 4 + 2 + 1)). +END PROC cylinder code; + +INT PROC tracks: + get value (-10, fd channel) +END PROC tracks; + +INT PROC sectors: + get value (-11, fd channel) +END PROC sectors; + +INT PROC heads: + get value (-12, fd channel) +END PROC heads; + +INT PROC get value (INT CONST control code, channel for value): + enable stop; + INT VAR old channel := channel; + IF channel for value <> old channel THEN continue (channel for value) FI; + INT VAR value; + control (control code, 0, 0, value); + IF channel for value <> old channel THEN continue (old channel) FI; + value +END PROC get value; + +PROC get external block (DATASPACE VAR ds, INT CONST ds page, + archive block, get channel): + INT VAR old channel := channel; + continue (get channel); + disable stop; + read block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht gelesen werden"); + CASE 2: error stop ("Lesefehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + continue (old channel). +END PROC get external block; + +PROC put external block (DATASPACE CONST ds, INT CONST ds page, + archive block, get channel): + INT VAR old channel := channel; + continue (get channel); + disable stop; + write block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht geschrieben werden"); + CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + continue (old channel). +END PROC put external block; + +END PACKET setup eumel partitionierung; + diff --git a/system/setup/3.1/src/setup eumel 6: shardmontage b/system/setup/3.1/src/setup eumel 6: shardmontage new file mode 100644 index 0000000..cc0d475 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 6: shardmontage @@ -0,0 +1,389 @@ + +(**************************************************************************) +(***** Zusammenbau eines SHards aus Modulen mit Dialog *****************) +(***** Copyright (c) 1987, 1988 by *****************) +(***** Lutz Prechelt, Karlsruhe *****************) +(**************************************************************************) + +PACKET setup eumel shardmontage (* Copyright (c) 1987 by *) +DEFINES build shard, (* Lutz Prechelt, Karlsruhe *) + add bad sector table to shard, (* Stand : 08.04.88 3.2 *) + installation nr, (* Eumel 1.8.1 *) + print configuration : + +(* Beschreibung des SHard-Hauptmodulformats siehe "modulkonfiguration" *) + +(* In diesem Paket sind viele Namenskonventionen verankert. + Das leere SHard-Hauptmodul hat den Namen "SHard leer", teilaufgebaute + SHards heissen normalerweise in der Form "SHard 07.07.87 14:34" (andere + Namen sind möglich, wenn sie mit "SHard " beginnen.) + Die Prozedur build shard bastelt in Dialogsteuerung durch den Benutzer + aus Modulen und einem leeren oder teilaufgebauten SHard-Hauptmodul einen + neuen SHard zusammen und schreibt ihn in die Datei SHARD + Die Prozedur add bad block table to shard fügt einem so zusammengebauten + SHard eine bad block tabelle gemäß dem Zustand der Partition hinzu oder + ändert die vorhandene. + Dann ist der SHard komplett fertig zum auf-die-Partition-schleudern. + (einschliesslich Installationsnummer) +*) + +LET hauptmodul namentyp = "SHard *", + (*modul namentyp = "SHardmodul *",*) + shard name = "SHARD"; + +LET bad sector table size = 1024, (* Entries *) + max sh length = 60, (* Blocks, vorläufig !!! *) + nr of channels total = 40, + offset shard length = 6, + offset bad sector table pointer = 8, + offset verbal identification = 176, (* Start Shardleiste *) + offset id 4 = 196; (* 176 + 14h *) + +INT VAR actual installation nr :: id (5); +DATASPACE VAR ds :: nilspace; + +PROC build shard (DATASPACE CONST old shard ds) : + (* Der Aufrufer muß hinterher nachsehen, ob es die Datei SHARD auch + wirklich gibt. Falls nicht, ist "Aufbau des SHards war nicht möglich" + zu melden. + *) + BOUND MODUL VAR old shard :: old shard ds, new shard; + TEXT VAR t; + INT VAR i; + THESAURUS VAR th, modules, automatic mode modules, + modules in old shard, modules in new shard; + BOOL CONST old shard valid :: int (old shard, offset id 4) = id (4) AND + verbal identification ok; + perhaps take old shard; (* ggf. LEAVE *) + get main module name in t; + copy (t, shard name); + new shard := old (shard name); + enable stop; + eliminate bad sector table from shard (new shard); + get module names; + configurate modules and build shard; + add ids. + +verbal identification ok : + text (old shard, offset verbal identification, 16) = + "SHard Schoenbeck". + +perhaps take old shard : + kopf; + forget (shard name, quiet); + IF old shard valid CAND + yes ("Wollen Sie den SHard genauso wie beim letzten Setup", FALSE) + THEN copy (old shard ds, shard name); LEAVE build shard + ELSE out (""10"") FI. + +get main module name in t : + putline (" A u s w a h l d e s S H a r d - H a u p t m o d u l s "10""); + th := all LIKE hauptmodul namentyp; + IF highestentry (th) > 1 + THEN let the user select one + ELSE take the only one FI. + +let the user select one : + putline ("Wählen Sie jetzt bitte, welches SHard-Hauptmodul Sie als"); + putline ("Ausgangspunkt der Konfiguration benutzen möchten."); + putline ("(Namen durch Zeiger auswählen dann RETURN-Taste drücken)"); + t := ONE th; + out (""4""13""10""10""10""). + +take the only one : + t := name (th, 1); + putline ("Das einzige verfügbare SHard Hauptmodul ist"); + putline (t); + pause (30). + +get module names : + (* Besorgt die Listen 1. vorhandene Module 2. Module im alten SHard + und 3. Module im SHard Hauptmodul + Liefert in modules eine Auswahl von 1. ohne 3. mit 2. als Vorschläge + und in automatic mode modules eine Auswahl von 2. (alles vorgeschlagen) + Die Liste 2. ist dabei so sortiert, daß stets eingekettete Module in der + richtigen Reihenfolge auftauchen. + *) + kopf; + put ("Ich untersuche den SHard: "); + get modules in shard (new shard, modules in new shard); + IF old shard valid + THEN get modules in shard (old shard, modules in old shard) + ELSE modules in old shard := empty thesaurus FI; + kopf; + putline ("Wählen Sie jetzt bitte mit RETURN/rauf/runter, welche Module Sie"); + putline ("mit in den SHard aufnehmen möchten."); + putline ("(Zum Verlassen ESC q)"); + modules := certain (all modules - modules in new shard, + modules in old shard); + IF old shard valid + THEN kopf; + putline ("Wählen Sie jetzt, welche der Module vollautomatisch wie im"); + putline ("Vorlage-SHard konfiguriert werden sollen (Reihenfolge egal)"); + automatic mode modules := certain (modules / modules in old shard, + modules in old shard) + ELSE automatic mode modules := empty thesaurus FI. + +configurate modules and build shard : + FOR i FROM 1 UPTO highest entry (modules) REP + page; cout (i); collect heap garbage; + t := name (modules, i); + configurate module (new shard, old shard, + modules in old shard CONTAINS t, + automatic mode modules CONTAINS t, t) + PER; + IF highest entry (automatic mode modules) < highest entry (modules) + THEN perhaps keep copy of partly build shard FI; + collect heap garbage. + +perhaps keep copy of partly build shard : + kopf; + storage info; + out (""10"Möchten Sie eine zusätzliche Kopie des SHard in dieser Version"13""10""); + IF yes ("aufheben", FALSE) + THEN TEXT CONST start :: subtext (hauptmodul namentyp, 1, + LENGTH hauptmodul namentyp - 1); + t := date; + put ("Gewünschter Name :"); out (start); editget (t); out (""13""10""); + t := start + t; + IF NOT exists (t) COR overwrite THEN copy (shard name, t) FI + FI. + +add ids : + int (new shard, offset id 4 + 2 (* ID5 *), actual installation nr); + int (new shard, offset id 4 + 4 (* ID6 *), id (6)); + int (new shard, offset id 4 + 6 (* ID7 *), id (7)). + +overwrite : + IF yes ("Existierende Datei """ + t + """ überschreiben", FALSE) + THEN forget (t, quiet); + TRUE + ELSE FALSE FI. +END PROC build shard; + +(******************** print configuration **********************************) + +PROC print configuration (DATASPACE CONST old shard ds, BOOL CONST on screen): + (* Ruft für alle Module, die in old shard ds und als Datei vorhanden sind + print configuration aus dem Paket modulkonfiguration auf. + Macht bei on screen nach jedem Modul eine Pause, andernfalls wird die + Ausgabe in einem Rutsch gemacht und mit indirect list auf den Drucker + umgeleitet. + *) + BOUND MODUL VAR old shard :: old shard ds; + THESAURUS VAR modules in old shard; + BOOL CONST old shard valid :: int (old shard, offset id 4) = id (4) AND + verbal identification ok; + enable stop; + IF NOT old shard valid + THEN errorstop ("Der SHard ist ungültig"); + LEAVE print configuration + FI; + write head ("Anzeigen der Konfiguration des SHard"); + put ("Bitte fassen Sie sich in Geduld"); + get modules in shard (old shard, modules in old shard); + out (""4""13""10""); (* clear cout, line *) + IF on screen + THEN putline ("Nach jedem Modul eine Taste drücken.") + ELSE putline ("Die Ausgabe geht zum Drucker"); + indirect list (TRUE); + putline ("***** SHardkonfiguration *****"); line; + FI; + disable stop; + do print configuration (old shard, modules in old shard, on screen); + IF is error THEN put error; pause; clear error FI; + enable stop; + IF NOT on screen THEN indirect list (FALSE) FI. + +verbal identification ok : + text (old shard, offset verbal identification, 16) = + "SHard Schoenbeck". +END PROC print configuration; + +PROC do print configuration (MODUL CONST old shard, + THESAURUS CONST modules in old shard, + BOOL CONST on screen) : + INT VAR i; + TEXT VAR t; + enable stop; + FOR i FROM 1 UPTO highest entry (modules in old shard) REP + t := name (modules in old shard, i); + print configuration (old shard, t); + collect heap garbage; + IF on screen THEN pause FI + PER. +END PROC do print configuration; + +(********************** modules in shard **********************************) + +PROC get modules in shard (MODUL CONST old shard, + THESAURUS VAR modules in old shard) : + (* Stellt einem THESAURUS zusammen, der aus den Namen aller in old shard + enthaltenen Module besteht (ohne Duplikate). + Dabei sind diejenigen Modulnamen, deren Treiber in old SHard nicht als + eingekettete Treiber vorkommen, im Resultat VOR den eingeketteten + (d.h. mit kleineren link-Nummern) zu finden, um die richtige + Konfigurationsreihenfolge vorschlagen zu können. + Es muß zuvor bereits einmal init modules list aufgerufen worden sein ! + *) + INT VAR kanal; + REAL VAR p dtcb, p ccb; + TEXT VAR type, m name; + THESAURUS VAR simple :: empty thesaurus, chained :: empty thesaurus; + FOR kanal FROM 0 UPTO nr of channels total - 1 REP + cout (kanal); + p dtcb := sh dtcb offset (old shard, kanal); + p ccb := sh ccb offset (old shard, kanal); + look at this chain + PER; + invert chained thesaurus; + modules in old shard := what comes out when i let nameset do all the hard + work for me with a little trick and knowledge of implementation. + +look at this chain : + (* Das Verfahren ist auf den ersten Blick etwas kompliziert, spart aber + einiges an Kodeduplikation + *) + m name := ""; + WHILE p dtcb <> 0.0 AND p ccb <> 0.0 REP + IF m name <> "" AND NOT (chained CONTAINS m name) + THEN insert (chained, m name) FI; + type := text (old shard, p dtcb, 4); + m name := module name (type); + p dtcb := unsigned (int (old shard, p ccb + 2.0)); (* verkettet *) + p ccb := unsigned (int (old shard, p ccb + 4.0)); + PER; + IF m name <> "" THEN insert (simple, m name) FI. + +invert chained thesaurus : + (* bis jetzt sind bei mehrfachen Verkettungen die zuletzt eingeketteten + Treiber als erstes eingetragen, das darf jedoch nicht so bleiben + *) + INT VAR i; + THESAURUS VAR help :: empty thesaurus; + FOR i FROM highest entry (chained) DOWNTO 1 REP + insert (help, name (chained, i)) + PER; + chained := help. + +what comes out when i let nameset do all the hard +work for me with a little trick and knowledge of implementation : + (* Beware of false algebraic identities ! These are neither numbers nor + sets but lists (ordered and not duplicate-free) + *) + empty thesaurus + (simple - chained) + chained. +END PROC get modules in shard; + +(*************** add bad sector table to shard ****************************) + +PROC add bad sector table to shard (INT CONST eumel type, + DATASPACE CONST shard ds, + BOOL CONST take from partition, + INT VAR bad sector count) : + (* Fügt einem SHard eine bad sector table hinzu oder ändert sie. + Ist noch keine vorhanden, so sollte der Zeiger 0 sein. + *) + ROW bad sector table size REAL VAR bst; + BOUND MODUL VAR new shard :: shard ds; + REAL VAR new shard length, offset bst; + INT VAR i; + enable stop; + IF take from partition + THEN put ("kopiere Tabelle :"); + find bst in shard on partition + ELSE put ("Spur :"); + get bad sector table (bst, bad sector count, eumel type); + FI; + eliminate bad sector table from shard (new shard); + new shard length := unsigned (int (new shard, offset shard length)); + int (new shard, new shard length, bad sector count); + int (new shard, offset bad sector table pointer, unsigned (new shard length)); + new shard length INCR 2.0; + IF take from partition + THEN copy bst from old to new shard + ELSE write bst to new shard FI; + int (new shard, offset shard length, unsigned (new shard length)). + +copy bst from old to new shard : + copy (old shard, offset bst + 2.0, new shard, new shard length, + bad sector count * 4); + cout (bad sector count * 4); + new shard length INCR real (bad sector count * 4). + +write bst to new shard : + FOR i FROM 1 UPTO bad sector count REP + cout (i); + enter bad sector low word + PER; + FOR i FROM 1 UPTO bad sector count REP + cout (i); + enter bad sector high word; + PER. + +find bst in shard on partition : + cout (0); + read file (ds, start of partition (eumel type) + 1.0, max sh length, + setup channel); + BOUND MODUL CONST old shard :: ds; + IF int (old shard, offset id 4) <> id (4) + THEN errorstop ("SHard auf Partition unbrauchbar") FI; + offset bst := unsigned (int (old shard, offset bad sector table pointer)); + bad sector count := int (old shard, unsigned (offset bst)). + +enter bad sector low word : + int (new shard, new shard length, low word (bst [i])); + new shard length INCR 2.0. + +enter bad sector high word : + int (new shard, new shard length, high word (bst [i])); + new shard length INCR 2.0. +END PROC add bad sector table to shard; + +(************ eliminate bad sector table from shard ****************) + +PROC eliminate bad sector table from shard (MODUL VAR shard) : + (* Entfernt die bad sector table (bst) aus dem shard falls sie sich am Ende + desselben befindet. Trägt korrekte neue Werte für den bst pointer und + shard laenge ein. + *) + REAL VAR shard length :: unsigned (int (shard, offset shard length)), + bst offset :: unsigned (int (shard, offset bad sector table pointer)); + LET bst entry length = 4.0; (* bst entries sind Wort-Paare *) + IF bst offset = 0.0 + THEN (* ist gar keine bst vorhanden, also schon prima eliminiert *) + ELIF bst ist am ende + THEN bst entfernen FI; + bst austragen. + +bst ist am ende : + bst offset + bst entry length * nr of bst entries + 2.0 = + shard length. + +nr of bst entries : + unsigned (int (shard, bst offset)). + +bst entfernen : + int (shard, offset shard length, unsigned (bst offset)). + +bst austragen : + int (shard, offset bad sector table pointer, 0). +END PROC eliminate bad sector table from shard; + +(******************* installation nr *************************************) + +INT PROC installation nr : + actual installation nr +END PROC installation nr; + +PROC installation nr (INT CONST new) : + actual installation nr := new +END PROC installation nr; + +(*********************** Hilfsprozeduren **********************************) + +PROC kopf : + write head ("M o d u l - S H a r d Zusammenbau eines SHard"). +END PROC kopf; + +END PACKET setup eumel shardmontage; + diff --git a/system/setup/3.1/src/setup eumel 7: setupeumel b/system/setup/3.1/src/setup eumel 7: setupeumel new file mode 100644 index 0000000..0504e97 --- /dev/null +++ b/system/setup/3.1/src/setup eumel 7: setupeumel @@ -0,0 +1,1238 @@ +(*************************************************************************) +(*** Hauptprogramm des setup-Eumel:Einstellen der EUMEL - Partitionen ***) +(*** und SHard-Installation auf einer Festplatte. ***) +(*** ***) +(*** Autor : W. Sauerwein Stand : 07.04.89 ***) +(*** I. Ley Version : 2.3 ***) +(*** Anpassung an Modul-SHard : Lutz Prechelt, Karlsruhe ***) +(*** -"- : Werner Metterhausen ***) +(*** -"- : Martin Schönbeck ***) +(*************************************************************************) +(*** V 3.1 14.04.89 shard wird immer mit 'max sh size' geschriegen ***) +(*** da mit 'ds pages' ggf teile fehlten, wenn innen ***) +(*** unbenutzte pages (buffer) waren ***) +(*** V 3.0 10.04.89 support fuer mehrere Laufwerke eingebaut ***) +(*** ausgabe der module vor loeschen etc. entfernt ***) + +PACKET setup eumel DEFINES setup eumel, setup eumel endlos, version, +show partition table: + +LET setup version = "Version 3.1"; + +TEXT VAR stand :: "Stand : 18.04.89 (mit Modul-SHard Version 4.9)"; + +PROC version (TEXT CONST vers): stand := vers END PROC version; + +PROC version: editget (stand) END PROC version; + +LET max partitions = 4, + max sh size = 128, (* Anzahl Bloecke *) + return = ""13"", + escape = ""27""; + +LET hauptmodul namentyp = "SHard *", + modul namentyp = "SHardmodul *", + sh name = "SHARD", + sh backup = "SHARD Sicherungskopie"; + +ROW max partitions INT VAR part list; +ROW max partitions INT VAR part type, part active, + part first track, part last track; +ROW max partitions REAL VAR part start, + part size; + + INT VAR zylinder, + startzeile tabelle :: 1, + startzeile menu :: 12, + active partition, + partitions, + partition, i, j, cx, cy, help; + TEXT VAR retchar, + meldung := ""; + BOOL VAR testausgabe, + mit schreibzugriff := TRUE, + meldung eingetroffen := FALSE, + endlos :: FALSE, + at version; +THESAURUS VAR minimum modulkollektion := empty thesaurus; +DATASPACE VAR ds := nilspace; + +(************************* setup eumel endlos *****************************) + +PROC setup eumel endlos (BOOL CONST b) : + endlos := b; + IF endlos + THEN line; + putline ("Bitte geben Sie nun alle die Dateien an, die der Benutzer auf"); + putline ("keinen Fall löschen darf. (Taste drücken)"); + minimum modulkollektion := certain (all, emptythesaurus); + line (3); + putline ("Der setup eumel kann nun nach dem nächsten Aufruf nicht mehr "); + putline ("verlassen werden. ") + FI. +END PROC setup eumel endlos; + +(******************** get/put actual partition data ************************) + +PROC get actual partition data : + get boot block; + zylinder := tracks; + FOR i FROM 1 UPTO max partitions REP + part type (i) := partition type (i); + part first track (i) := first track (i); + part last track (i) := last track (i); + part start (i) := partition start (i); + part size (i) := partition size (i); + part active (i) := partition word 0 (i); + IF partition active (i) THEN active partition := i FI + PER; + get number of installed partitions; + generate part list. + +get number of installed partitions : + partitions := 0; + FOR i FROM 1 UPTO max partitions REP + IF part type (i) <> 0 THEN partitions INCR 1 FI + PER. + +generate part list : + FOR i FROM 1 UPTO max partitions REP + IF part type (i) <> 0 THEN part list (i) := i + ELSE part list (i) := 0 + FI; + PER; + schiebe nullen nach hinten; + sort part list. + +schiebe nullen nach hinten : + i := 1; INT VAR k := 0; + REP k INCR 1; + IF part list (i) = 0 THEN circle + ELSE i INCR 1 + FI + UNTIL k = max partitions - 1 PER. + +circle : + FOR j FROM i UPTO max partitions - 1 REP + part list (j) := part list (j + 1) + PER; + part list (max partitions) := 0. + +sort part list : + FOR i FROM 2 UPTO partitions REP + FOR j FROM 1 UPTO i - 1 REP + IF part first track (part list (i)) < part first track (part list (j)) + THEN tausche FI + PER + PER. + +tausche : + help := part list (i); + part list (i) := part list (j); + part list (j) := help. + +END PROC get actual partition data; + +PROC put actual partition data : + FOR i FROM 1 UPTO max partitions REP + IF partition exists (i) THEN put partition + ELSE clear partition (i) + FI; + PER; + IF mit schreibzugriff THEN put boot block FI. + +put partition : + IF is eumel (i) THEN partition type (i, part type (i)); + first track (i, part first track (i)); + last track (i, part last track (i)); + partition start (i, part start (i)); + partition size (i, part size (i)) + FI; + partition word 0 (i, part active (i)); + IF active partition = i + THEN partition active (i, TRUE) + ELSE partition active (i, FALSE) + FI. + +END PROC put actual partition data; + +(*************************** setup eumel ********************************) + +PROC setup eumel : + line; command dialogue (TRUE); + at version := yes ("System für AT", TRUE); + testausgabe := FALSE; (*yes ("Testversion", FALSE); *) + pruefe ob notwendige dateien vorhanden; + init modules list; + IF yes ("Leere Floppy für Systemsicherung eingelegt", FALSE) + THEN command dialogue (FALSE); save system; command dialogue (TRUE) FI; + IF NOT endlos THEN putline ("Verlassen mit ESC."); pause (40) FI; + terminal setup; + logo; + generate eumel. + +pruefe ob notwendige dateien vorhanden: + BOUND INT VAR y; + IF mit schreibzugriff THEN y := old (sh name); + y := old ("shget.exe"); + y := old ("bootblock"); + y := old ("configuration"); + y := old ("AT-4.x") + FI. + +END PROC setup eumel; + +PROC generate eumel : + disable stop; + show partition table; + REP update table; + main menu; + action; + IF is error THEN fehler; + put line (error message); + put line ("Bitte betätigen Sie eine Taste !"); + clear error; + pause; + IF mit schreibzugriff THEN terminal setup FI + FI + PER. + +action : + INT VAR choice; + clear error; + REP + cursor (cx, cy); + IF partitions < max partitions + THEN choice := get choice (0, max, retchar) + ELSE choice := get choice (2, max, 0, retchar) + FI; + IF escaped CAND NOT endlos THEN LEAVE generate eumel FI; + UNTIL retchar = return PER; + cl eop (1, startzeile menu - 1); + INT VAR unser kanal := channel; + SELECT choice OF + CASE 0 : programm ende + CASE 1 : create partition (TRUE) + CASE 2 : create partition (FALSE) + CASE 3 : activate partition + CASE 4 : delete partition + CASE 5 : delete partition table + CASE 6 : konfiguration anzeigen + CASE 7 : shard zusammenbauen + CASE 8 : modulkollektion aendern + CASE 9 : change drive + + END SELECT; + continue (unser kanal). + +max : + 9. + +change drive: + cursor (1, startzeile menu); + put ("Bitte Laufwerksnummer angeben:"); + get cursor (cx, cy); + put (" 0 - 3"); + REP cursor (cx, cy); + INT VAR drive := get choice (0, 3, retchar); + IF sure escaped THEN LEAVE change drive FI; + UNTIL NOT escaped PER; + setup channel (28-drive); + show partition table. + + +programm ende : + cursor (1, startzeile menu); + IF keine partition aktiv + THEN IF trotz warnung beenden THEN eumel beenden FI + ELSE IF yes ("Wollen Sie die Partitionierung Ihrer Festplatte beenden", FALSE) + THEN eumel beenden + FI FI. + +keine partition aktiv : active partition = 0. + +trotz warnung beenden : + put line ("ACHTUNG : Es ist keine Partition aktiv gesetzt !"); + put line (" Sie können daher nicht von der Festplatte booten !"); + line; + yes ("Wollen Sie trotzdem die Partitionierung der Festplatte beenden", FALSE). + +eumel beenden : + cl eop (1, startzeile menu - 1); + cursor (1, startzeile menu + 3); + shutup; terminal setup; + logo; + show partition table. + +shard zusammenbauen : + cl eop (1, startzeile menu); + IF yes ("Wollen Sie Ihren SHard neu konfigurieren", FALSE) + THEN shard sichern und vorlage beschaffen; + + IF NOT is error THEN build shard (ds) FI; + IF is error OR NOT exists (sh name) + + THEN forget (sh name, quiet); rename (sh backup, sh name); + putline ("Zusammenbau fehlgeschlagen. Alter SHard erhalten."); + pause (300); + FI; + forget (sh backup, quiet); forget (ds); + show partition table + FI. + +shard sichern und vorlage beschaffen : + forget (sh backup, quiet); + IF exists (shname) + THEN copy (sh name, sh backup); + FI; + forget (ds); + line; + IF yes (""3"Ist in einer existierenden Eumel-Partition ein SHard installiert, +"13""10"der als Vorlage dienen soll", FALSE) + THEN INT VAR vorlage :: 69; + editget (1, startzeile menu + 4, "Partitiontyp: ", vorlage); + (* Das sollte man mal noch schöner machen !!! *) + read file (ds, start of partition (vorlage) + 1.0, max sh size, + setup channel) + ELSE ds := old (sh name) FI. + + +konfiguration anzeigen : + hole anzuzeigenden ds; + line; + print configuration (ds, NOT yes ("Auf dem Drucker ausgeben", FALSE)); + show partition table. + +hole anzuzeigenden ds: + forget (ds); + line; + IF yes ("Soll ein SHard aus einer Partition angezeigt werden", TRUE) + THEN INT VAR anzeige :: 69; + editget (1, startzeile menu + 4, "Partitiontyp: ", anzeige); + (* Das sollte man mal noch schöner machen !!! *) + read file (ds, start of partition (anzeige) + 1.0, max sh size, + setup channel) + ELSE ds := old (ONE ((all LIKE hauptmodul namentyp) + "SHARD")) FI. + + +modulkollektion aendern : + THESAURUS VAR th; + TEXT VAR x :: "SHard"; + INT VAR i ; + page; + th := (all LIKE hauptmodul namentyp) + (all LIKE modul namentyp) + + (all LIKE sh name) ; + (* Diese Ausgabe macht leider den Bildschirmaufbau kaputt *) + (* mit dem Erfolg, daß man dann nicht mehr sieht, was man *) + (* ankreuzt, deshalb auskommentiert *) + (******* + putline(" Alle SHards :"); + line; + FOR i FROM 1 UPTO highest entry(th) + REP + putline(name(th,i)) + PER; + *******) + putline(" Modulkollektion ändern"); + line; + IF yes ("Wollen Sie irgendwelche Module löschen", FALSE) + THEN th := (all LIKE hauptmodul namentyp) + (all LIKE modul namentyp) + + (all LIKE sh name) - minimum modulkollektion; + forget (certain (th, emptythesaurus)); + ELIF yes ("Wollen Sie Module vom Archiv holen", FALSE) + THEN put ("Archivname:"); editget (x); line; + archive (x); + th := ALL archive LIKE modul namentyp; + fetch (certain (th, emptythesaurus), archive); + release (archive) + FI; + init modules list; + show partition table. + + +END PROC generate eumel; + + +PROC show partition table : + IF NOT mit schreibzugriff THEN get actual partition data FI; + headline; + devide table; + columns; + underlines; + rows; + downline. + +head line : + cl eop (1, startzeile tabelle); + put center (startzeile tabelle, "Aktuelle Partitions - Tabelle", TRUE). + +devide table : + FOR i FROM 1 UPTO 8 + REP + cursor (45, startzeile tabelle + i); out (inverse ("")) + PER. + +columns : + cursor ( 1, startzeile tabelle + 2); + out ("Nr. System Typ Zustand Grösse Anfang Ende"); + cursor (48, startzeile tabelle + 2); + out ("Platte : Zyl. / KB"). + +underlines : + cursor ( 1, startzeile tabelle + 3); + out ("--------------------------------------------"); + cursor (47, startzeile tabelle + 3); + out ("------------------------------"). + +rows : + FOR i FROM 1 UPTO max partitions + REP cursor (2, startzeile tabelle + 3 + i); + put (text (i) + " :") + PER. + +downline : + put center (startzeile menu - 3, " EUMEL Installationssystem " + setup version + + " (IBM PC/" + rechner typ + + " und kompatible Rechner) ", TRUE); + put center (startzeile menu - 2, stand, TRUE). + +rechner typ : + IF at version THEN "AT" + ELSE "XT" + FI. + +END PROC show partition table; + +PROC main menu : + biete auswahl an; + IF meldung eingetroffen THEN melde FI; + IF testausgabe THEN ausgabe fuer test FI. + +ausgabe fuer test : + testrahmen; + test out. + +testrahmen : + FOR i FROM startzeile menu - 1 UPTO startzeile menu + 9 + REP + cl eol (45, i); + put (inverse ("")) + PER; + cursor (52, startzeile menu); + put ("Ecke für Test-Output"); + cursor (52, startzeile menu). + +test out : + FOR i FROM 1 UPTO max partitions + REP + cursor (52, startzeile menu + 1 + i); + put (text (i) + ":"); + put (part type (i)); + put (part first track (i)); + put (part last track (i)); + IF active partition = i THEN put ("aktiv") + ELSE put ("inaktiv") + FI; + PER. + +melde : + cursor (1, 24); + put (inverse ("Meldung :")); + put (meldung); + meldung eingetroffen := FALSE. + +biete auswahl an : + cl eop (1, startzeile menu - 1); line; + IF partitions < max partitions + THEN putline (" EUMEL - Partition einrichten .............. 1") + ELSE line; + putline (" EUMEL - Partition") + FI; + cursor (20, startzeile menu + 1); + putline ("erneuern (Neuer SHard) .. 2"); + putline (" aktivieren .............. 3"); + putline (" löschen ................. 4"); + putline (" Partitionstabelle löschen ................. 5"); + putline (" SHard-Konfiguration anzeigen .............. 6"); + putline (" SHard konfigurieren ....................... 7"); + putline (" SHardmodule laden oder löschen ............ 8"); + putline (" Bearbeitetes Laufwerk wechseln ............ 9"); + putline (" SETUP-EUMEL beenden ....................... 0"); + putline ("-----------------------------------------------"); + put (" Ihre Wahl >>"); + get cursor (cx, cy). + +END PROC main menu; + +PROC update table : + IF mit schreibzugriff THEN get actual partition data FI; + FOR i FROM 1 UPTO partitions REP update partition PER; + FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER; + zeige plattengroesse; + IF active partition = 0 THEN meldung := "ACHTUNG : Es ist keine Partition aktiv gesetzt !"; + meldung eingetroffen := TRUE + FI. + +update partition : + partition := part list (i); + show partition. + +rubout partition : + cursor (5, startzeile tabelle + 3 + i); + out (" "). + +show partition : + cursor (5, startzeile tabelle + 3 + i); + put (name + type + zustand + groesse + startspur + endspur). + +name : subtext (subtext (part name, 1, 7) + + " ", 1, 8). + +type : text (part type (partition), 5) + " ". + +zustand : IF active partition = partition THEN (" aktiv ") + ELSE (" ") + FI. + +startspur : " " + text (part first track (partition), 5). +endspur : text (part last track (partition), 6). +groesse : text (part groesse, 5). + +zeige plattengroesse : + put gesamt; + put noch freie; + put maximaler zwischenraum. + +put maximaler zwischenraum : + cursor (48, startzeile tabelle + 6); + put ("gr. Lücke : " + text (maximaler zwischenraum, 5) + " / " + + kilobyte(maximaler zwischenraum)). + +put gesamt : + cursor (48, startzeile tabelle + 4); + put ("Gesamt : " + text (zylinder, 5) + " / " + + kilobyte(zylinder)). + +put noch freie : + cursor (48, startzeile tabelle + 5); + put ("Frei : " + text (freie zylinder, 5) + " / " + + kilobyte( freie zylinder)). + +END PROC update table; + + +TEXT PROC kilobyte (INT CONST zylinderzahl): + TEXT VAR kb; + kb := text(round(real(zylinderzahl) * real(heads) * real(sectors) * 0.512,0)); + subtext(kb,1,length(kb)-2) + +END PROC kilobyte; + + +PROC create partition (BOOL CONST partition is new) : + IF NOT partition is new + THEN renew partition + ELIF freie part number gefunden CAND noch platz uebrig + THEN new partition + ELSE kein platz mehr FI. + +kein platz mehr : + fehler; + put ("Es kann keine neue Partition mehr eingerichtet werden."); + pause (300). + +noch platz uebrig : freie zylinder > 0. + +freie part number gefunden : + IF partitions < max partitions THEN suche nummer; + TRUE + ELSE FALSE + FI. + +suche nummer : + partition := 0; + REP partition INCR 1 UNTIL part type (partition) = 0 PER. + +new partition : + cl eop (1, startzeile menu); + IF yes ("Neue EUMEL - Partition einrichten", FALSE) + THEN INT VAR alte aktive partition := active partition; + IF NOT partition exists (partition) + THEN IF enter partition spezifikations + THEN IF mit schreibzugriff THEN check part and install FI + FI; + ELSE keine freie partition + FI FI. + +renew partition : + cl eop (1, startzeile menu); + IF yes ("Neuen SHard auf bestehende EUMEL - Partition schreiben", FALSE) + THEN enter part number; + IF mit schreibzugriff THEN check part and install FI + FI. + +enter part number : + put ("Welche Partition wollen Sie erneuern :"); + get cursor (cx, cy); + put (" Abbruch mit <ESC>"); + REP + REP cursor (cx, cy); + partition := get choice (1, 4, retchar); + IF sure escaped THEN LEAVE create partition FI; + partition := part list (partition) + UNTIL NOT escaped PER; + IF NOT (partition exists (partition) AND is eumel (partition)) + THEN fehler; put ("Keine EUMEL - Partition"); + pause (300); cl eop (1, 20); + FI + UNTIL partition exists (partition) AND is eumel (partition) PER. + +check part and install: + IF partition is new THEN put actual partition data FI; + IF testausgabe THEN put ("Keine Überprüfung schlechter Sektoren, da Testversion !") + ELSE trage schlechte sektoren ein; + FI; + IF is error AND partition is new + THEN active partition := alte aktive partition; + rubout partition; + LEAVE check part and install + ELIF NOT is error + THEN line; + put ("Shard wird auf die Partition geschrieben..."); line (2); + bringe shard auf platte (part type (partition)); + ELSE line; + putline ("Fehler aufgetreten. Partition unverändert") + FI; + put ("Bitte betätigen Sie eine Taste !"); + loesche eingabepuffer; + pause. + +trage schlechte sektoren ein: + INT VAR anzahl schlechter sektoren; + line (2); + putline ("Überprüfen der Partition nach schlechten Sektoren."); + add bad sector table to shard (part type (partition), old (sh name), + NOT partition is new, anzahl schlechter sektoren); + line; + IF NOT is error THEN put ("Ich habe " + bs zahl + " gefunden.") FI. + +bs zahl: + IF anzahl schlechter sektoren = 0 + THEN "keine schlechten Sektoren" + ELIF anzahl schlechter sektoren > 1 + THEN text (anzahl schlechter sektoren) + " schlechte Sektoren" + ELSE "einen schlechten Sektor" + FI. + +keine freie partition : + fehler; + put line ("Sie können nur auf freien Partitionen 'EUMEL' einrichten."); + put ("Die Partition " + text (partition) + " ist bereits mit einem System belegt !"); + pause (300). + +END PROC create partition; + +BOOL PROC enter partition spezifikations : + cl eol (60, startzeile menu); put ("Abbruch mit <ESC>"); + cl eol (1, startzeile menu + 2); + put ("Typ : EUMEL,"); + INT VAR old end := part last track (partition); + enter part size; + enter part first track; + put end track; + cl eol (60, startzeile menu); + IF NOT eingaben ok THEN LEAVE enter partition spezifikations WITH FALSE FI; + cl eol (1, startzeile menu + 4); + part first track (partition) := int (start); + part last track (partition) := int (start) + int (size) - 1; + part start (partition) := first usable sector; + part size (partition) := first sector behind partition - + part start (partition); + active partition := partition; + part type (partition) := kleinste freie eumel nummer; + add to part list; + TRUE. + +eingaben ok : + cl eop (1, startzeile menu + 4); + yes ("Sind die Partitionsangaben korrekt", FALSE). + +enter part size : + get cursor (cx, cy); + REP + REP cursor (cx, cy); + put ("Welche Grösse :"); + TEXT VAR size := groessenvorschlag; + loesche eingabepuffer; + editget (size, escape, "", retchar); + IF sure escaped + THEN LEAVE enter partition spezifikations WITH FALSE + FI + UNTIL NOT escaped PER; + IF NOT size ok THEN falsche groesse FI + UNTIL size ok AND not too big PER; + cl eol (1, y + 1); + cl eol (1, y + 2); + cl eol (cx, cy); + put ("Grösse : " + size + ";"). + +size ok : + NOT size greater maxint + CAND size positiv + AND desired size <= maximaler zwischenraum. + +not too big: + INT VAR x,y; + get cursor(x,y); + IF real(kilobyte(int(size))) >= 16196.0 + THEN line; + putline("Eine Partition grösser 16 MB ist nur bei einer + Version sinnvoll !"); + yes("Eingabe korrekt",FALSE) + ELSE TRUE + FI. + +size greater maxint : + length (size) >= 5. + +size positiv : + desired size > 0. + +falsche groesse : + fehler; + put line ("Es kann keine Partition mit " + size + " Zylindern eingerichtet werden !"); + IF NOT size greater maxint CAND size positiv + THEN put ("Die grösste zusammenhängende Anzahl Zylinder ist " + + text (maximaler zwischenraum) + ".") + ELSE put ("Bitte eine positive Grösse angeben !") + FI. + +groessenvorschlag : + text (maximaler zwischenraum). + +enter part first track : + get cursor (cx, cy); + REP + REP cursor (cx, cy); + put ("Start - Zylinder der Partition :"); + TEXT VAR start := startvorschlag; + loesche eingabepuffer; + editget (start, escape, "", retchar); + IF sure escaped THEN part last track (partition) := old end; + LEAVE enter partition spezifikations WITH FALSE + FI + UNTIL NOT escaped PER; + IF NOT start ok THEN falscher start FI + UNTIL start ok PER; + cl eol (cx, cy); + put ("Start : " + start + ";"). + +put end track : + put ("Ende : " + text (int (start) + int (size) - 1)). + +start ok : + length (start) < 5 + CAND enough room + AND NOT in existing partition + AND NOT out of volume. + +out of volume : desired start > zylinder OR desired start < 0. + +in existing partition : + IF partitions = 0 THEN FALSE + ELSE i := 0; + REP + i INCR 1 + UNTIL start of part i > desired start + OR last partition + OR error found PER; + IF error found THEN TRUE ELSE FALSE FI + FI. + +error found : + part index <> i AND + (start of part i <= desired start AND end spur i >= desired start). + +part index : + 0. + +desired start : int (start). + +start of part i : part first track (part list (i)). + +last partition : i = partitions. + +enough room : + desired start + desired size <= begin of next partition. + +desired size : int (size). + +begin of next partition : + IF partitions = 0 THEN zylinder + ELSE i := 0; + REP + i INCR 1; + UNTIL start of part i > desired start + OR last partition PER; + IF start of part i > desired start THEN start of part i + ELSE zylinder + FI + FI. + +falscher start : + fehler; + put ("Auf Zylinder " + start); + put ("kann keine Partition der Grösse " + size); + put ("beginnen !"). + +startvorschlag : + text (best start position). + +best start position : + IF partitions = 0 THEN 0 + ELSE best start spur vor und zwischen den partitionen + FI. + +best start spur vor und zwischen den partitionen : + INT VAR best start := 0, min size := zylinder; + FOR i FROM 0 UPTO partitions + REP + IF platz genug zwischen i und i plus 1 AND kleiner min size + THEN min size := platz zwischen i und i plus 1; + best start := start des zwischenraums + FI + PER; + best start. + +start des zwischenraums : + end spur i + 1. + +end spur i : + IF i = 0 THEN -1 + ELSE part last track (part list (i)) + FI. + +platz zwischen i und i plus 1 : + part first track i plus 1 - (end spur i + 1). + +part first track i plus 1 : + IF i = partitions THEN zylinder + ELSE part first track (part list (i + 1)) + FI. + +platz genug zwischen i und i plus 1 : + platz zwischen i und i plus 1 >= int (size). + +kleiner min size : platz zwischen i und i plus 1 < min size. + +first usable sector: + IF int (start) = 0 + THEN 1.0 + ELSE real (heads * sectors) * real (start) + FI. + +first sector behind partition: + real (heads * sectors) * (real(start) + real (size)). + +kleinste freie eumel nummer : + IF partitions = 0 THEN 69 + ELSE search for part type (69) + FI. + +END PROC enter partition spezifikations; + +INT PROC search for part type (INT CONST minimum) : + IF minimum exists THEN search for part type (minimum + 1) + ELSE minimum + FI. + +minimum exists : + BOOL VAR exists := FALSE; + INT VAR i; + FOR i FROM 1 UPTO partitions REP + IF part type (part list (i)) = minimum THEN exists := TRUE FI + PER; + exists. + +END PROC search for part type; + +PROC bringe shard auf platte (INT CONST eumel type): + IF mit schreibzugriff THEN + enable stop; + INT CONST old session :: session; + fixpoint; + IF session <> old session + THEN errorstop ("SHard auf Platte schreiben im RERUN !") FI; + write file ("shget.exe", start der eumel partition, 1, setup channel); + write file (sh name, start der eumel partition + 1.0, + max sh size, setup channel) + FI. + +start der eumel partition: + start of partition (eumel type). +END PROC bringe shard auf platte; + + +PROC add to part list : + IF part list leer THEN part list (1) := partition + ELIF neuer start vor letzter partition THEN fuege ein + ELSE haenge an + FI; + partitions INCR 1. + +part list leer : partitions = 0. + +neuer start vor letzter partition : + part first track (partition) < part first track (part list (partitions)). + +haenge an : part list (partitions + 1) := partition. + +fuege ein : + suche erste partition die spaeter startet; + schiebe restliste auf; + setze partition ein. + +suche erste partition die spaeter startet : + i := 0; + REP i INCR 1 + UNTIL part first track (part list (i)) > part first track (partition) PER. + +schiebe restliste auf : + FOR j FROM partitions DOWNTO i + REP + part list (j + 1) := part list (j) + PER. + +setze partition ein : + part list (i) := partition. + +END PROC add to part list ; + +INT PROC maximaler zwischenraum : + IF partitions = 0 THEN zylinder + ELSE max (maximaler platz vor und zwischen den partitionen, + platz hinter letzter partition) + FI. + +maximaler platz vor und zwischen den partitionen : + help := platz vor erster partition; + FOR i FROM 1 UPTO partitions - 1 + REP + help := max (help, begin of part i plus 1 - end of part i - 1) + PER; + help. + +platz vor erster partition : + part first track (part list (1)). + +platz hinter letzter partition : + zylinder - part last track (part list (partitions)) - 1. + +begin of part i plus 1 : + part first track (part list (i + 1)). + +end of part i : + part last track (part list (i)). + +END PROC maximaler zwischenraum; + +PROC activate partition : + enter part number; + IF NOT escaped THEN set partition active FI. + +set partition active : + IF yes ("Partition mit Typnummer " + text (part type (partition)) + " aktivieren", FALSE) + THEN active partition := partition; + put actual partition data + FI. + +enter part number : + cursor (60, startzeile menu); put ("Abbruch mit <ESC>"); + cursor ( 1, startzeile menu); + put ("Welche Partition wollen Sie aktivieren :"); + get cursor (cx, cy); + REP + REP cursor (cx, cy); + partition := get choice (1, 4, retchar); + IF sure escaped THEN LEAVE activate partition FI; + partition := part list (partition) + UNTIL NOT escaped PER; + IF NOT partition exists (partition) THEN fehler melden FI + UNTIL partition exists (partition) PER; + cl eol (60, startzeile menu); + cl eop (1, cy + 2). + +fehler melden : + partition gibt es nicht. + +partition gibt es nicht : + fehler; + put ("Diese Partition gibt es nicht."). + +END PROC activate partition; + +PROC delete partition : + enter part number; + IF NOT escaped THEN + IF yes ("Partition mit Typnummer " + text (part type (partition)) + " löschen", FALSE) + AND ganz sicher + THEN rubout partition + FI FI. + +enter part number : + cursor (60, startzeile menu); put ("Abbruch mit <ESC>"); + cursor ( 1, startzeile menu); + put ("Welche Partition wollen Sie löschen :"); + get cursor (cx, cy); + REP + REP cursor (cx, cy); + partition := get choice (1, 4, retchar); + IF sure escaped THEN LEAVE delete partition FI; + partition := part list (partition) + UNTIL NOT escaped PER; + IF NOT (partition exists (partition) AND is eumel (partition)) THEN fehler melden FI + UNTIL partition gueltig AND is eumel (partition) PER; + cl eol (60, startzeile menu); + cl eop (1, cy + 2). + +fehler melden : + IF NOT partition exists (partition) THEN partition gibt es nicht + ELSE keine eumel partition + FI. + +partition gibt es nicht : + fehler; + put ("Diese Partition gibt es nicht."). + +ganz sicher : + line; + yes ("Sind Sie sich ganz sicher", FALSE). + +END PROC delete partition; + +PROC delete partition table : + cursor ( 1, startzeile menu + 1); + put ("Es gehen ALLE Daten verloren, die sich auf Ihrer Platte befinden !"); + line (2); + IF yes ("Wollen Sie wirklich die ganze Partitionstabelle löschen", FALSE) + THEN line; + IF yes ("Sind Sie sich ganz sicher", FALSE) + THEN loesche ganze tabelle + FI FI. + +loesche ganze tabelle : + FOR i FROM 1 UPTO max partitions + REP part type (i) := 0; + part first track (i) := 0; + part last track (i) := 0; + part start (i) := 0.0; + part size (i) := 0.0; + part list (i) := 0 + PER; + partitions := 0; + active partition := 0; + IF mit schreibzugriff THEN clear partition table (-3475) FI. + +END PROC delete partition table; + +PROC rubout partition : + part type (partition) := 0; + part first track (partition) := 0; + part last track (partition) := 0; + IF active partition = partition THEN active partition := 0 FI; + del from part list; + put actual partition data. + +del from part list : + search for partition in part list; + delete it and set highest to 0; + partitions DECR 1. + +search for partition in part list : + i := 0; + REP i INCR 1 UNTIL part list (i) = partition PER. + +delete it and set highest to 0 : + FOR j FROM i UPTO partitions - 1 + REP + part list (j) := part list (j + 1) + PER; + part list (partitions) := 0. + +END PROC rubout partition; + +INT PROC get choice (INT CONST von, bis, TEXT VAR retchar): + get choice (von, bis, von, retchar) +END PROC get choice; + +INT PROC get choice (INT CONST von, bis, zusatz, TEXT VAR retchar): + LET return = ""13"", + escape = ""27"", + left = ""8""; + TEXT VAR buffer; + INT VAR cx, cy; + get cursor (cx, cy); out (" " + left); + REP + REP + cursor (cx, cy); buffer := incharety; + UNTIL input ok OR buffer = escape PER; + IF buffer = escape THEN retchar := escape; + LEAVE get choice WITH 0 + FI; + out (buffer); + leseschleife bis left or ret; + IF retchar = left THEN out (left + " ") FI; + IF retchar = escape THEN LEAVE get choice WITH 0 FI + UNTIL retchar = return OR retchar = escape PER; + int (buffer). + +input ok : (buffer >= text (von) AND buffer <= text (bis)) OR buffer = text (zusatz). + +leseschleife bis left or ret: + REP + inchar (retchar) + UNTIL retchar = return OR retchar = left OR retchar = escape PER. + +END PROC get choice; + +TEXT PROC inverse (TEXT CONST t): + ""15"" + t + " " + ""14"" +END PROC inverse; + +PROC put center (TEXT CONST t): + put center (t, 80) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, BOOL CONST inverse): + put center (zeile, t, 80, inverse); +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t): + put center (zeile, t, 80) +END PROC put center; + +PROC put center (TEXT CONST t, INT CONST gesamtbreite): + INT VAR cy; + get cursor (cy, cy); + put center (cy, t, gesamtbreite) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite): + put center (zeile, t, gesamtbreite, FALSE); +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite, + BOOL CONST inverse): + IF inverse + THEN cursor (1, zeile); + out (""15""); + gesamtbreite - 2 TIMESOUT " "; + FI; + cursor ((gesamtbreite - length (t)) DIV 2, zeile); + put (t); + IF inverse + THEN cursor (gesamtbreite - 1, zeile); + out (""14""); + FI +END PROC put center; + +PROC cl eol: + out (""5"") +END PROC cl eol; + +PROC cl eop: + out (""4"") +END PROC cl eop; + +PROC cl eol (INT CONST cx, cy): + cursor (cx, cy); + cl eol +END PROC cl eol; + +PROC cl eop (INT CONST cx, cy): + cursor (cx, cy); + cl eop +END PROC cl eop; + +INT PROC partition groesse (INT CONST part) : + part last track (part) - part first track (part) + 1 +END PROC partition groesse; + +BOOL PROC is eumel (INT CONST partition) : + part type (partition) >= 69 AND part type (partition) <= 72 +END PROC is eumel; + +BOOL PROC partition exists (INT CONST partition) : + IF partition > 0 AND partition <= max partitions + THEN part type (partition) <> 0 + ELSE FALSE + FI +END PROC partition exists;. + +part groesse : partition groesse (partition). + +part name : + SELECT part type (partition) OF + CASE 1, 4 : "DOS" + CASE 69, 70, 71, 72 : "EUMEL" + OTHERWISE text (part type (partition)) + END SELECT. + +escaped : retchar = escape. + +sure escaped : + IF escaped THEN cl eop (1, 20); cursor (1, 22); + yes ("Vorgang abbrechen", TRUE) + ELSE FALSE + FI. + +partition gueltig : + partition > 0 + AND partition <= max partitions. + +freie zylinder : + zylinder - belegte zylinder. + +belegte zylinder : + help := 0; + FOR i FROM 1 UPTO partitions REP + help INCR partition groesse (part list (i)) + PER; + help. + +keine eumel partition : + fehler; + put line ("Sie dürfen mit diesem System nur 'EUMEL' - Partitionen manipulieren."); + put ("Die Partition " + text (partition) + " ist nicht vom Typ 'EUMEL' !"). + +fehler : + cl eop (1, 20); + put (""7"" + inverse ("FEHLER :")); line (2). + +loesche eingabepuffer : + REP UNTIL incharety = "" PER. ; + +PROC logo : + page; + put center (3, "S E T U P - E U M E L "+ setup version); + put center (5, "für"); + put center (7, "M O D U L - S H A R D"); + put center (13, "======================================================"); + put center (15, "(für IBM " + typ + " und Kompatible)"); + put center (20, stand); + pause (50); + collect heap garbage. + +typ : + IF at version THEN "AT" ELSE "XT" FI. +END PROC logo; + +END PACKET setup eumel; + +setup eumel + + + + + + + diff --git a/system/setup/3.1/src/setup eumel erzeugen b/system/setup/3.1/src/setup eumel erzeugen new file mode 100644 index 0000000..7a50898 --- /dev/null +++ b/system/setup/3.1/src/setup eumel erzeugen @@ -0,0 +1,15 @@ +check off; +insert("setup eumel -1: mini eumel dummies"); +insert("setup eumel 0: /S"); +insert("setup eumel 1: basisoperationen"); +insert("setup eumel 2: modulzugriffe"); +insert("setup eumel 3: modulkonfiguration"); +insert("setup eumel 5: partitionierung"); +insert("setup eumel 6: shardmontage"); +insert("setup eumel 7: setupeumel"); +putline("Jetzt 'setup eumel endlos' nicht vergessen"); + + + + + diff --git a/system/setup/3.1/src/setup eumel erzeugen-M b/system/setup/3.1/src/setup eumel erzeugen-M new file mode 100644 index 0000000..ad85301 --- /dev/null +++ b/system/setup/3.1/src/setup eumel erzeugen-M @@ -0,0 +1,14 @@ +check off; +insert("setup eumel 0: /M"); +insert("setup eumel 1: basisoperationen"); +insert("setup eumel 2: modulzugriffe"); +insert("setup eumel 3: modulkonfiguration"); +insert("setup eumel 5: partitionierung"); +insert("setup eumel 6: shardmontage"); +insert("setup eumel 7: setupeumel"); +putline("Jetzt 'setup eumel endlos' nicht vergessen"); + + + + + diff --git a/system/setup/3.1/src/shget.exe b/system/setup/3.1/src/shget.exe Binary files differnew file mode 100644 index 0000000..902d697 --- /dev/null +++ b/system/setup/3.1/src/shget.exe diff --git a/system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik b/system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik new file mode 100644 index 0000000..36fa31e --- /dev/null +++ b/system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik @@ -0,0 +1,831 @@ +#type ("trium10")##limit (13.5)# +#block##start(2.5,2.5)##pagelength(21.0)##pagenr("%",418)##setcount(22)# +#headeven# +% EUMEL-Benutzerhandbuch + + + +#end# +#headodd# + TEIL 10: Graphik % + + + +#end# +#type("triumb14")# +#ib(9)##center#TEIL 10: Graphik#ie(9)# +#type("trium10")# +#free(2.0)# +#on("bold")##ib(9)##type("triumb14")#1. Übersicht#ie(9)# +#type("trium10")# + + #limit(12.0)##on("italics")#Dieser Teil des Benutzer-Handbuchs beschreibt die Graphik- + Möglichkeiten des EUMEL-Systems. Die Graphik-Pakete ge + hören nicht zum EUMEL-Standard, sondern sind Anwender + pakete, die im Quellcode ausgeliefert und von jeder Installation + in das System aufgenommen werden können. Unter Umständen + müssen Programme erstellt werden, die die Anpassungen für + spezielle graphische Geräte einer Installation vornehmen. +#limit(13.5)##off("italics")# + +Das Graphik-System ermöglicht es, durch ELAN-Programme geräteunab +hängige Informationen für Zeichnungen ("#ib#Graphiken#ie#") zu erstellen. Die Graphik +erzeugenden Programme brauchen dabei keine gerätespezifischen Größen sowie +gerätespezifischen Unterprogramme zu enthalten. Sie befassen sich somit +ausschließlich mit der Erzeugung der problemorientierten Information für die +Konstruktion einer Zeichnung. Nach der geräteunabhängigen Erzeugung einer +Graphik kann diese auf unterschiedlichen Geräten ausgegeben werden (z.B. erst +auf einem Terminal zur Kontrolle und dann auf einem Plotter). + +Die EUMEL-Graphik umfaßt zwei- und dreidimensionale Graphik. Dabei +entspricht die Y-Achse bei der zweidimensionalen Graphik der Z-Achse (Höhe) +bei der dreidimensionalen Graphik. Im dreidimensionalen Fall sind perspektivi +sche, orthografische und schiefwinklige Projektionen mit beliebigen Betrach +tungswinkeln möglich. + +Bei der EUMEL-Graphik wird streng zwischen Erzeugung und Manipulation von +Graphiken (Bildern) auf der einen und Darstellung der erzeugten Bilder auf der +anderen Seite unterschieden. Für die Erzeugung und Manipulation der Graphi +ken existiert der Typ PICTURE, für die Darstellung der Bilder gibt es den Typ +PICFILE. Dabei müssen Ausschnitt, Maßstab, Betrachtungswinkel und Pro +jektionsart erst bei der Darstellung festgelegt werden. Diese Konstruktion des +Graphik-Systems hat folgende Vorteile: + +a) Programme, die Graphik-Informationen erzeugen, sind geräteunabhängig. + Das bedeutet, daß Programmierer sich ausschließlich mit einem logischen + Problem zu befassen brauchen und nicht mit gerätespezifischen Besonder + heiten. + +b) Graphiken können auf mehreren unterschiedlich gearteten Geräten mehrmals + dargestellt werden, ohne daß das erzeugende Programm geändert oder neu + gestartet werden muß. Z.B. kann ein Programmierer eine Graphik erst auf + dem Terminal auf Richtigkeit und Größenverhältnisse überprüfen, bevor er die + Zeichnung auf einem Plotter zeichnen läßt. + +c) Graphiken können leicht geändert (z.B. vergrößert oder in eine Richtung + gestreckt) werden, ohne daß das erzeugende Programm erneut durchlaufen + werden muß. Zudem können Graphiken aneinander oder übereinander gelegt + werden. + +d) Graphiken mit unterschiedlichen Farben, Strichen usw. können leicht erzeugt + werden. + +e) Der Anschluß von neuen Graphik-Geräten durch Benutzer ist leicht möglich, + ohne daß die Graphik erzeugenden Programme modifiziert werden müssen. + +f) Plotter können wie Drucker an einen SPOOLER gehängt werden. + +g) Bilder können als PICFILEs gespeichert und versandt werden. +#free(2.0)# +#ib(9)##type("triumb14")#Erzeugung von Bildern#ie(9)# +#type("trium10")# + +Bilder entstehen in Objekten vom Datentyp + +#type("modern12")# + PICTURE +#type("trium10")# + +Diese müssen mit der Prozedur + +#type("modern12")# + nilpicture +#type("trium10")# + +initialisiert werden. Sie enthalten dann ein leeres Bild, dessen Dimension noch +nicht festgelegt ist. Die Dimension eines PICTUREs wird mit dem ersten +Schreibzugriff ('move' oder 'draw') festgelegt. Ein PICTURE kann immer nur +entweder zwei- oder dreidimensional sein. Außerdem kann einem PICTURE mit +der Prozedur + +#type("modern12")# + pen +#type("trium10")# + +genau ein virtueller Stift zugeordnet oder der aktuelle Stift erfragt werden. + +Die Erzeugung eines Bildes basiert auf dem Modell eines Plotters. Der (virtuelle) +Zeichenstift kann mit + +#type("modern12")# + move +#type("trium10")# + +ohne zu zeichnen an beliebige Stellen gefahren werden (reine Positionierung). +Mit + +#type("modern12")# + draw +#type("trium10")# + +wird der Stift veranlaßt, eine Linie von der aktuellen zur angegebenen Zielposi +tion zu zeichnen. 'move' löst also Bewegungen mit gehobenem, 'draw' solche mit +gesenktem Stift aus. Um auch 'relatives' Zeichnen zu ermöglichen, existiert die +Prozedur + +#type("modern12")# + where +#type("trium10")# + +die die aktuelle Stiftposition liefert. +#free(2.0)# +#ib(9)##type("triumb14")#Manipulation von Bildern#ie(9)# +#type("trium10")# + +Erstellte Bilder können als Ganzes manipuliert werden. Die Prozeduren + +#type("modern12")# + translate (* verschieben *) + stretch (* strecken bzw. stauchen *) + rotate (* drehen *) + reflect (* spiegeln *) +#type("trium10")# + +verändern jeweils das ganze Bild. Es ist aber auch möglich, mehrere Bilder +zusammenzufügen. Mit + +#type("modern12")# + CAT +#type("trium10")# + +kann ein weiteres Bild angefügt werden. Dabei müssen allerdings beide +PICTURE die gleiche Dimension haben. In solchen als ganzes manipulierten +Bildern kann man ohne Einschränkung mit 'draw' und 'move' weiterzeichnen. +#free(2.0)# +#ib(9)##type("triumb14")#Darstellung#ie(9)# +#type("trium10")# + +Für die Darstellung der erzeugten Bilder existiert der Typ + +#type("modern12")# + PICFILE +#type("trium10")# + +Dieser besteht aus max. 128 PICTUREs, die mit den Prozeduren + +#type("modern12")# + put + get +#type("trium10")# + +eingegeben bzw. ausgegeben werden können. PICFILE wird durch Datenräume +realisiert, deshalb erfolgt die Assoziation an einen benannten Datenraum ähnlich +wie beim FILE. Dafür wird die Prozedur + +#type("modern12")# + picture file +#type("trium10")# + +verwandt. Ein neuer PICFILE enthält genau ein leeres PICTURE. Die Darstellung +der PICFILEs auf Zeichengeräten erfolgt mit der Prozedur + +#type("modern12")# + plot +#type("trium10")# + +Da die Graphiken aber in "Weltkoordinaten" erzeugt werden und die spätere +Darstellung vollkommen unbeachtet bleibt, müssen gewisse Darstellungspara +meter für die Zeichnung gesetzt werden. Diese Parameter werden im PICFILE +abgelegt und gelten jeweils für den gesamten PICFILE. Dadurch ist es möglich, +einen PICFILE mit spezifizierter Darstellungsart über einen SPOOLER an einen +Plotter zu senden oder die bei der letzten Betrachtung gewählte Darstellung mit +in dem PICFILE gespeichert zu halten. Für die Darstellung können den virtuellen +Stiften mit der Prozedur + +#type("modern12")# + select pen +#type("trium10")# + +reale Stifte zugeordnet werden. Voreingestellt ist für alle virtuellen Stifte: +Standardfarbe, Standardstärke, durchgängige Linie. + +Indem man einigen virtuellen Stiften den leeren Stift als realen Stift zuordnet, +kann man einzelne PICTUREs ausblenden. Sowohl bei der Darstellung von +zwei- als auch dreidimensionaler Graphik kann die gewählte Zeichenfläche auf +dem Endgerät mit der Prozedur + +#type("modern12")# + viewport +#type("trium10")# + +festgelegt werden. Voreingestellt ist das Quadrat mit der größtmöglichen Seiten +länge, d.h. der kürzeren Seite der hardwaremäßigen Zeichenfläche. +#free(2.0)# +#ib(9)##type("triumb14")#Darstellung zweidimensionaler Graphik#ie(9)# +#type("trium10")# + +Bei der Darstellung zweidimensionaler Bilder muß der zu zeichnende Ausschnitt +(das 'Fenster') angegeben werden. Mit der Prozedur + +#type("modern12")# + window +#type("trium10")# + +wird durch Angabe der minimalen und maximalen X- bzw. Y-Koordinaten ein +Fenster definiert. Da das so definierte Fenster auf die ganze (mit 'viewport' +definierbare) Zeichenfläche abgebildet wird, ist der Abbildungsmaßstab durch das +Zusammenspiel von 'viewport' und 'window' bestimmt. Da bei 'viewport' stan +dardmäßig das maximale Zeichenquadrat voreingestellt ist, wird in diesem Fall +durch gleiche X- und Y-Fenstergröße eine winkeltreue Darstellung erreicht. +#free(2.0)# +#ib(9)##type("triumb14")#Darstellung dreidimensionaler Graphik#ie(9)# +#type("trium10")# + +Im dreidimensionalen Fall wird das Fenster ebenfalls mit + +#type("modern12")# + window +#type("trium10")# + +definiert, wobei dann allerdings auch der Bereich der dritten Dimension +(Z-Koordinaten) zu berücksichtigen ist. Da die dreidimensionale Graphik auf +eine zweidimensionale Fläche projiziert wird, können aber noch weitere Darstel +lungsparameter angegeben werden. Der Betrachtungswinkel wird mit Hilfe der +Prozedur + +#type("modern12")# + view +#type("trium10")# + +angegeben. Zur Spezifikation der gewünschten Projektionsart gibt es + +#type("modern12")# + orthographic (* orthographische Projektion *) + perspective (* perspektivische Projektion, + der Fluchtpunkt ist frei wählbar *) + oblique (* schiefwinklige Projektion *) +#type("trium10")# +#free(2.0)# +#ib(9)##type("triumb14")#Beispiel (Sinuskurve)#ie(9)# +#type("modern12")# + + funktion zeichnen; + bild darstellen . + +funktion zeichen : + PICTURE VAR pic :: nilpicture; + REAL VAR x := -pi; + move (pic, x, sin (x)); + REP x INCR 0.1; + draw (pic, x, sin (x)) + UNTIL x >= pi PER . + +bild darstellen : + PICFILE VAR p :: picture file ("sinus"); + window (p, -pi, pi, -1.0, 1.0); + put (p, pic); + plot (p) . +#type("trium10")# +#free(2.0)# +#ib(9)##type("triumb14")#Beispiel (Würfel)#ie(9)# +#type("modern12")# + + wuerfel zeichen; + wuerfel darstellen. + +wuerfel zeichnen : + zeichne vorderseite; + zeichne rueckseite; + zeichne verbindungskanten. + +zeichne vorderseite : + PICTURE VAR vorderseite :: nilpicture; + move (vorderseite, 0.0, 0.0, 0.0); + draw (vorderseite, 1.0, 0.0, 0.0); + draw (vorderseite, 1.0, 0.0, 1.0); + draw (vorderseite, 0.0, 0.0, 1.0); + draw (vorderseite, 0.0, 0.0, 0.0). + +zeichne rueckseite : + PICTURE VAR rueckseite :: translate + (vorderseite, 0.0, 1.0, 0.0). + +zeichne verbindungskanten : + PICTURE VAR verbindungskanten :: nilpicture; + move (verbindungskanten, 0.0, 0.0, 0.0); + draw (verbindungskanten, 0.0, 1.0, 0.0); + + move (verbindungskanten, 1.0, 0.0, 0.0); + draw (verbindungskanten, 1.0, 1.0, 0.0); + + move (verbindungskanten, 1.0, 0.0, 1.0); + draw (verbindungskanten, 1.0, 1.0, 1.0); + + move (verbindungskanten, 0.0, 0.0, 1.0); + draw (verbindungskanten, 0.0, 1.0, 1.0). + +wuerfel darstellen : + PICFILE VAR p := picture file ("wuerfel"); + put (p, vorderseite); + put (p, rueckseite); + put (p, verbindungskanten); + window (p, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0); + view (p, 0.0, 40.0, 20.0); + orthographic (p); + plot (p). +#type("trium10")# +#free(2.0)# +#ib(9)##type("triumb14")#Beschreibung der Graphik-Prozeduren#ie(9)# +#type("trium10")# + + #limit(12.0)##on("italics")#Zweidimensionale PICTUREs brauchen weniger Speicherplatz + als dreidimensionale. Daher werden in einigen Fehlermeldun + gen unterschiedliche Größen angegeben. +#limit(13.5)##off("italics")# + +:= + OP := (PICTURE VAR dest, PICTURE CONST source) + Zweck: Zuweisung + + OP := (PICFILE VAR dest, DATASPACE CONST source) + Zweck: Assoziiert die PICFILE Variable 'dest' mit der DATASPACE CONST + 'source' und initialisiert die PICFILE Variable sofern nötig. + Fehlerfall: + * dataspace is no PICFILE + Der anzukoppelnde Datenraum hat einen falschen Typ. + +#ib#CAT#ie# + OP CAT (PICTURE VAR dest, PICTURE CONST source) + Zweck: Aneinanderfügen von zwei PICTURE's. + Fehlerfälle: + * OP CAT: left dimension <> right dimension + Es können nur PICTUREs mit gleicher Dimension angefügt werden. + * OP CAT: Picture overflow + Die beiden PICTURE überschreiten die maximale Größe eines + Pictures. + +#ib#act picture#ie# + PICTURE PROC act picture (PICFILE VAR p) + Zweck: Liefert das PICTURE des PICFILEs 'p', auf das mit 'backward' o.ä. + positioniert wurde. + +#ib#backward#ie# + PROC backward (PICFILE VAR p) + Zweck: Positioniert den PICFILE 'p' um ein PICTURE zurück. + Fehlerfall: + * backward at begin of file + Es wurde versucht vor den Anfang des PICFILEs zu positionieren. + +#ib#draw#ie# + PROC draw (PICTURE VAR pic, REAL CONST x, y) + Zweck: Die Prozedur zeichnet in dem (zweidimensionalen) Bild 'pic' eine + Linie von der aktuellen Position zur Position (x, y). + Fehlerfälle: + * picture overflow + Zu viele Befehle in einem PICTURE (z. Zeit max. 1927) + * picture is three dimensional + Ein PICTURE kann nur entweder zwei- oder dreidimensional sein. + + PROC draw (PICTURE VAR pic, REAL CONST x, y, z) + Zweck: Die Prozedur zeichnet in dem (dreidimensionalen) Bild 'pic' eine + gerade Linie von der aktuellen Position zur Position (x, y, z). + Fehlerfälle: + * picture overflow + Zu viele Befehle in einem PICTURE (z. Zeit max. 1310) + * picture is only two dimensional + Ein PICTURE kann nur entweder zwei- oder dreidimensional sein. + + PROC draw (PICTURE VAR pic, TEXT CONST text) + Zweck: Der angegebene Text wird in das Bild 'pic' eingetragen. Der Anfang + ist dabei die aktuelle Stiftposition. Diese wird nicht verändert. + Fehlerfall: + * picture overflow + Der Text paßt nicht mehr in das PICTURE. + + PROC draw (PICTURE VAR pic, TEXT CONST text, + REAL CONST angle, height) + Zweck: Der angegebene Text wird unter dem Winkel 'angle' gegenüber der + Waagerechten und in der Größe 'height' in das PICTURE 'pic' + eingetragen. Der Anfang ist dabei die aktuelle Stiftposition. Diese + wird nicht verändert. + Fehlerfall: + * picture overflow + Der Text paßt nicht mehr in das PICTURE. + + PROC draw (PICFILE VAR pic, REAL CONST x, y) + Zweck: Die Prozedur zeichnet in dem aktuellen (zweidimensionalen) + PICTURE des PICFILEs 'p' eine gerade Linie. Der (virtuelle) Stift wird + von der aktuellen Position zur Position (x, y) gefahren. Falls das + aktuelle PICTURE zu voll ist, wird automatisch auf das nächste + umgeschaltet. + Fehlerfälle: + * picfile overflow + Das letzte PICTURE ist voll (z. Zeit max. 128 PICTURE) + * picture is threedimensional + Das aktuelle PICTURE ist dreidimensional. + + PROC draw (PICTFILE VAR pic, REAL CONST x, y, z) + Zweck: s. o. + Fehlerfälle: + * picfile overflow + Das letzte PICTURE ist voll (z. Zeit max. 128) + * picfile is only twodimensional + Das aktuelle PICTURE ist zweidimensional. + + PROC draw (PICTFILE VAR pic, TEXT CONST text) + Zweck: Der angegebene Text wird in das aktuelle PICTURE des PICFILEs 'p' + eingetragen. Falls das aktuelle PICTURE zu voll ist, wird automatisch + auf das nächste umgeschaltet. Der Anfang ist dabei die aktuelle + Stiftposition. Diese wird nicht verändert. + Fehlerfall: + * picfile overflow + Das letzte PICTURE ist voll (z. Zeit max. 128) + + PROC draw (PICFILE VAR pic, TEXT CONST text, + REAL CONST angle, height) + Zweck: Der angegebene Text wird unter dem Winkel 'angle' gegenüber der + Waagerechten und in der Größe 'height' in das aktuelle PICTURE + des PICFILES 'p' eingetragen. Falls das aktuelle PICTURE zu voll ist, + wird automatisch auf das nächste umgeschaltet. Der Anfang ist + dabei die aktuelle Stiftposition. Diese wird nicht verändert. + Fehlerfall: + * picfile overflow + Das letzte PICTURE ist voll (z. Zeit max. 128) + +#ib#eof#ie# + BOOL PROC eof (PICFILE CONST p) + Zweck: Liefert 'TRUE' wenn hinter das Ende des PICFILEs positioniert + wurde. + +#ib#extrema#ie# + PROC extrema (PICTURE CONST p, + REAL VAR x min, x max, y min, y max) + Zweck: Die Prozedur liefert die größten und kleinsten X- und Y-Koordi + naten des PICTUREs 'p'. Diese werden in die Parameter 'x min', 'x + max', 'y min' und 'y max' eingetragen. + + PROC extrema (PICTURE CONST p, + REAL VAR x min, x max, y min, y max, z min, z max) + Zweck: s.o. + + PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) + Zweck: s.o. + + PROC extrema (PICFILE VAR p, + REAL VAR x min, x max, y min, y max, z min, z max) + Zweck: s.o. + +#ib#forward#ie# + PROC forward (PICFILE VAR p) + Zweck: Positioniert den PICFILE um ein PICTURE weiter. + Fehlerfall: + * picfile overflow + Es sollte hinter das Ende des PICFILEs positioniert werden. + +#ib#get#ie# + PROC get (PICFILE VAR p, PICTURE VAR pic) + Zweck: Liest ein PICTURE aus einem PICFILE und positioniert auf das + Nächste. + Fehlerfall: + * input after end of picfile + Es sollte nach dem Ende des Picfiles gelesen werden. + +#ib#move#ie# + PROC move (PICTURE VAR pic, REAL CONST x, y) + Zweck: Der (virtuelle) Stift wird zur Position (x, y) gefahren. + Fehlerfälle: + * picture overflow + Zu viele Befehle in einem PICTURE (z. Zeit max. 1927 'moves') + * picture is three dimensional + Ein PICTURE kann nur entweder zwei- oder dreidimensional sein. + + PROC move (PICTURE VAR pic, REAL CONST x, y, z) + Zweck: Der (virtuelle) Stift wird zur Position (x, y, z) gefahren. + Fehlerfälle: + * picture overflow + Zu viele Befehle in einem PICTURE (z. Zeit max. 1310) + * picture is only twodimensional + Ein PICTURE kann nur entweder zwei- oder dreidimensional sein. + + PROC move (PICFILE VAR p, REAL CONST x, y) + Zweck: Der (virtuelle) Stift wird zur Position (x, y) gefahren. Falls das aktuelle + PICTURE des PICFILEs 'p' zu voll ist, wird automatisch auf das + nächste umgeschaltet. + Fehlerfall: + * picfile overflow + Das letzte PICTURE ist voll (z. Zeit max. 128 PICTUREs) + + PROC move (PICFILE VAR p, REAL CONST x, y, z) + Zweck: Der (virtuelle) Stift wird zur Position (x, y, z) gefahren. Falls das + aktuelle PICTURE des PICFILEs 'p' zu voll ist, wird automatisch auf + das nächste umgeschaltet. + Fehlerfall: + * picfile overflow + Das letzte PICTURE ist voll (z. Zeit max. 128 PICTUREs) + +#ib#nilpicture#ie# + PICTURE PROC nilpicture + Zweck: Die Prozedure liefert ein leeres PICTURE zur Initialisierung. + +#ib#oblique#ie# + PROC oblique (PICFILE VAR p, REAL CONST a, b) + Zweck: Bei dem (dreidimensionalen!) Bild 'p' wird 'schiefwinklig' als + gewünschte Projektionsart eingestellt. Dabei ist (a, b) der Punkt in + der X-Y-Ebene, auf den der Einheitsvector in Z-Richtung + abgebildet werden soll. + +#ib#orthographic#ie# + PROC orthographic (PICFILE VAR p) + Zweck: Bei dem (dreidimensionalen!) Bild 'p' wird "orthografisch" als Pro + jektionsart eingestellt. Bei der orthografischen Projektion wird ein + dreidimensionaler Körper mit parallelen Strahlen senkrecht auf die + Projektionsebene abgebildet. + +#ib#pen#ie# + INT PROC pen (PICTURE CONST pic) + Zweck: Liefert die Nummer des 'virtuellen Stifts'. + + PICTURE PROC pen (PICTURE CONST pic, INT CONST pen) + Zweck: Liefert ein PICTURE mit dem Inhalt 'pic' und dem 'virtuellen Stift' mit + der Nummer 'pen'. Möglich sind die Nummern 1 - 16. + Fehlerfälle: + * PROC pen: pen [No] < 1 + Der gewünschte Stift ist kleiner als 1. + * PROC pen: pen [No] > 16 + Der gewünschte Stift ist größer als 16. + +#ib#perspective#ie# + PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) + Zweck: Bei den dreidimensionalen PICTUREs des PICFILE's 'p' wird + "perspektivisch" als gewünschte Projektionsart eingestellt. Der Punkt + (cx, cy, cz) ist der Fluchtpunkt der Projektion, d.h. alle Parallelen zur + Blickrichtung schneiden sich in diesem Punkt. + +#ib#pic no#ie# + INT PROC pic no (PICFILE CONST p) + Zweck: Liefert die Nummer des aktuellen PICTUREs. + +#ib#picture file#ie# + DATASPACE PROC picture file (TEXT CONST name) + Zweck: Die Prozedur dient zur Assoziation eines benannten Datenraumes mit + einem PICFILE (s. Operator ':='). + +#ib#plot#ie# + PROC plot (TEXT CONST name) + Zweck: Der PICFILE mit dem Namen 'name' wird entspechend der angege + benen Darstellungsart gezeichnet. Diese Parameter ('perspective', + 'orthographic', 'oblique', 'view', 'window' etc.) müssen vorher + eingestellt werden. + Fehlerfall: + * FILE does not exist + Es existiert kein PICFILE mit dem Namen 'name' + + PROC plot (PICFILE VAR p) + Zweck: Der PICFILE 'p' wird entspechend der angegebenen Darstellungsart + gezeichnet. Diese Parameter müssen vorher eingestellt werden. + + #on("bold")#Zweidimensional: +#off("bold")# + obligat: 'window' (zweidimensional) + optional: 'view' (zweidimensional) + 'select pen' + 'viewport' + + #on("bold")#Dreidimensional: +#off("bold")# + obligat: 'window' (dreidimensional) + optional: 'view' (dreidimensional) + 'orthographic', 'perspective', 'oblique' + 'viewport' + 'select pen' + +#ib#put#ie# + PROC put (PICFILE VAR p, PICTURE CONST pic) + Zweck: Schreibt ein PICTURE in einen PICFILE und positioniert um eins + vor. + Fehlerfall: + * picfile overflow + Der PICFILE ist voll. (z. Z. max. 128 PICTURE) + +#ib#reset#ie# + PROC reset (PICFILE VAR p) + Zweck: Positioniert auf den Anfang eines Picfiles. + +#ib#rotate#ie# + PICTURE PROC rotate (PICTURE CONST pic, REAL CONST alpha) + Zweck: Das PICTURE 'pic' wird um den Punkt (0, 0) um den Winkel 'alpha' + (im Gradmaß) im mathematisch positiven Sinn gedreht. + + PICTURE PROC rotate (PICTURE CONST pic, + REAL CONST alpha, beta, gamma) + Zweck: Das dreidimensionale PICTURE 'pic' wird um den Winkel 'alpha', + 'beta' oder 'gamma' im mathematisch positiven Sinn gedreht. Der + Winkel 'alpha' dreht um die X-Achse, der Winkel 'beta' um die + Y-Achse und 'gamma' um die Z-Achse. Es darf dabei nur jeweils + ein Winkel von 0.0 verschieden sein. Alle Winkel werden im + Gradmaß angegeben. + +#ib#select pen#ie# + PROC select pen (PICFILE VAR p, + INT CONST pen, colour, thickness, linetype) + Zweck: Für die Darstellung des Bildes 'p' soll dem "virtuellen Stift" 'pen' ein + realer Stift zugeordnet werden, der möglichst die Farbe 'colour' und + die Dicke 'thickness' hat und dabei Linien mit dem Typ 'line type' + zeichnet. Es wird die beste Annäherung für das Ausgabegerät für + diese Parameter genommen. Dabei gelten folgende Vereinbarun + gen: + + Farbe: negative Farben setzten den Hintergrund, positive Farben + zeichnen im Vordergrund. + + 0 Löschstift (falls vorhanden) + 1 Standardfarbe des Endgeräts (schwarz oder weiß) + 2 rot + 3 blau + 4 grün + 5 schwarz + 6 weiß > 20 nicht normierte Sonderfarben + + Dicke: 0 + Standardstrichstärke des Endgerätes > 0 + Strichstärke in 1/10 mm + + Typ: + 0 keine sichtbare Linie + 1 durchgängige Linie + 2 gepunktete Linie + 3 kurz gestrichelte Linie + 4 lang gestrichelte Linie + 5 Strichpunktlinie + + Die hier aufgeführten Möglichkeiten müssen nicht an allen grafischen + Endgeräten vorhanden sein. Der geräteabhängige Graphik-Treiber + wählt jeweils die für ihn bestmögliche Annäherung. + + Fehlerfälle: + * pen < 1 + * pen > 16 + +#ib#size#ie# + INT PROC size (PICFILE CONST p) + Zweck: Liefert die aktuelle Größe eines PICFILEs in Bytes. + +#ib#stretch#ie# + PICTURE PROC stretch (PICTURE CONST pic, REAL CONST xc, yc) + Zweck: Das PICTURE 'pic' wird in X-Richtung um den Faktor 'xc', in + Y-Richtung um den Faktor 'yc' gestreckt (bzw. gestaucht). Dabei + bewirkt der Faktor + c > 1 eine Streckung + 0 < c < 1 eine Stauchung + c < 0 zusätzlich eine Achsenspiegelung + + PICTURE PROC stretch (PICTURE CONST pic, REAL CONST xc, yc, zc) + Zweck: Das dreidimensionale PICTURE 'pic' wird entsprechend den + angegeben Faktoren 'xc', 'yc' und 'zc' gestreckt. Wirkung s.o. + +#ib#translate#ie# + PICTURE PROC translate (PICTURE CONST pic, REAL CONST dx, dy) + Zweck: Das PICTURE 'pic' wird um 'dx' und 'dy' verschoben. + Fehlerfall: + * picture is threedimensional + 'pic' ist dreidimensional. + + PICTURE PROC translate (PICTURE CONST pic, REAL CONST dx, dy, dz) + Zweck: Das PICTURE 'pic' wird um 'dx', 'dy' und 'dz' verschoben. + Fehlerfall: + * picture is twodimensional + Das PICTURE 'pic' ist zweidimensional + +#ib#two dimensional#ie# + PROC two dimensional (PICFILE VAR p) + Zweck: Setzt als Projektionsart zweidimensional. + +#ib#view#ie# + PROC view (PICFILE VAR p, REAL CONST alpha, phi, theta) + Zweck: Dreidimensionale Bilder werden häufig nicht direkt von vorne + dargestellt, sondern für die Betrachtung gedreht. Mit der Prozedur + 'view' kann diese Betrachtungsrichtung durch die Polarwinkel 'phi' + und 'theta' angegeben werden. Mit dem Winkel 'alpha' kann dann + das Bild um den Mittelpunkt der Zeichenfläche gedreht werden. + Dadurch kann ein Bild auch auf einem Terminal hochkant gestellt + werden. Voreingestellt ist 'phi = 0, theta = 0 und alpha = 0', d.h. + direkt von oben. + + Im Gegensatz zu 'rotate' hat 'view' keine Wirkung auf das eigentli + che Bild (PICFILE), sondern nur auf die gewählte Darstellung. So + addieren sich zwar aufeinanderfolgende "Rotationen", 'view' aber + geht immer von der Nullstellung aus. Auch kann das Bild durch eine + "Rotation" ganz oder teilweise aus oder in das Darstellungsfenster + ('window') gedreht werden. Bei 'view' verändern sich die Koordina + ten der Punkte nicht, d.h. das Fenster wird mitgedreht. + +#ib#viewport#ie# + PROC viewport (PICFILE VAR p, + REAL CONST hormin, hormax, vertmin, vertmax) + Zweck: Die Zeichenfläche auf dem Endgerät, auf dem das Bild dargestellt + werden soll, wird spezifiziert. Dabei wird sowohl die Größe als auch + die relative Lage der Zeichenfläche definiert. Der linke untere + Eckpunkt der physikalischen Zeichenfläche des Gerätes hat die + Koordinaten (0.0, 0.0). Die definierte Zeichenfläche erstreckt sich + +#type("modern12")# + 'hormin' - 'hormax' in der Horizontalen, + 'vertmin' - 'vertmax' in der Vertikalen. +#type("trium10")# + + So liegt der linke untere Eckpunkt dann bei (hormin, vertmin), der + rechte obere bei (hormax, vertmax). + + Damit sowohl geräteunabhängige als auch maßstabsgerechte + Zeichnungen möglich sind, können die Koordinaten in zwei Arten + spezifiziert werden : + + a) Gerätekoordinaten + Die Koordinaten können Werte von 0.0 bis 2.0 annehmen. Dabei + hat die kürzere Seite der physikalischen Zeichenfläche defini + tionsgemäß die Länge 1.0. + + b) absolute Koordinaten + Die Werte werden in cm angegeben. Für die Maximalwerte sind + nur Werte größer als 2.0 möglich. + + Voreingestellt ist + +#type("modern12")# + viewport (0.0, 1.0, 0.0, 1.0), +#type("trium10")# + + d.h. das größtmöglichste Quadrat, beginnend in der linken unteren + Ecke der physikalischen Zeichenfläche. In vielen Fällen wird diese + Einstellung ausreichen, so daß der Anwender kein eigenes 'viewport' + definieren muß. + + Der Abbildungsmaßstab wird durch das Zusammenspiel von 'view + port' und 'window' festgelegt (siehe dort). Dabei ist insbesondere + darauf zu achten, daß winkeltreue Darstellungen nur bei gleichem + X- und Y-Maßstab möglich sind. Da man oft quadratische Fenster + ('window') verwendet, wurde als Standardfall auch ein quadratisches + 'viewport' gewählt. + +#ib#where#ie# + PROC where (PICTURE CONST pic, REAL VAR x, y) + Zweck: Die aktuelle Stiftposition wird in 'x' und 'y' eingetragen. + Fehlerfall: + * picture is threedimensional + Das PICTURE 'pic' ist dreidimensional + + PROC where (PICTURE CONST pic, REAL VAR x, y, z) + Zweck: Die aktuelle Stiftposition wird in 'x', 'y' und 'z' eingetragen. + Fehlerfall: + * picture is twodimensional + Das PICTURE 'pic' ist zweidimensional + +#ib#window#ie# + PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) + Zweck: Für die Darstellung eines zweidimensionalen Bildes wird das + darzustellende Fenster definiert. Alle Bildpunkte, deren X-Koordi + naten im Intervall [x min, x max] und deren Y-Koordinaten im + Intervall [y min, y max] liegen, gehören zum definierten Fenster. + Vektoren, die über dieses Fenster hinausgehen, werden abge + schnitten. Dieses Fenster wird auf die spezifizierte Zeichenfläche + abgebildet. (Das ist standardmäßig das größtmögliche Quadrat auf + dem ausgewählten Gerät). + + Der Darstellungsmaßstab ergibt sich als + +#type("modern12")# + x max - x min + ----------------------------------------- + horizontale Seitenlänge der Zeichenfläche + + y max - y min + ----------------------------------------- + vertikale Seitenlänge der Zeichenfläche +#type("trium10")# + + Für eine winkeltreue Darstellung müssen X- und Y-Maßstab + gleich sein! Einfach können winkeltreue Darstellung erreicht + werden, wenn das Fenster eine quadratische Form hat. Die + Zeichenfläche ('viewport') ist dementsprechend als Quadrat vorein + gestellt. + + PROC window (PICFILE VAR p, + REAL CONST x min, x max, y min, y max, z min, z max) + Zweck: Für die Darstellung eines dreidimensionalen Bildes wird das darzu + stellende Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im + Intervall [x min, x max] und deren Y-Koordinaten im Intervall [y min, + y max] und deren Z-Koordinaten im Intervall [z min, z max] liegen, + gehören zum definierten Fenster. Dieses dreidimensionale Fenster + (Quader) wird entsprechend der eingestellten Projektionsart (ortho + grafisch, perspektivisch oder schiefwinklig) und den Betrachtungs + winkeln (s. 'view') auf die spezifizierte Zeichenfläche abgebildet. (Das + ist standardmäßig das größtmögliche Quadrat auf dem ausgewählten + Gerät.) Linien, die außerhalb dieses Quadrates liegen, werden + abgeschnitten. + + Anders als im zweidimensionalen Fall ist das Problem der Maßstäbe + nicht mehr nur durch das Zusammenspiel von 'window' und 'view + port' zu beschreiben. Hier spielen auch Projektionsart und Dar + stellungswinkel eine Rolle. Falls alle Darstellungswinkel den Wert 0.0 + haben, gilt das für den zweidimensionalen Fall gesagte für die Ebene + (y = 0.0) entsprechend. + +#ib#write is possible#ie# + BOOL PROC write is possible (PICTURE CONST pic, INT CONST space) + Zweck: Liefert 'TRUE', falls 'space' Bytes Platz in 'pic' vorhanden ist. + + + + + + diff --git a/system/std.graphik/1.8.7/doc/GRAPHIK.book b/system/std.graphik/1.8.7/doc/GRAPHIK.book new file mode 100644 index 0000000..435d9e4 --- /dev/null +++ b/system/std.graphik/1.8.7/doc/GRAPHIK.book @@ -0,0 +1,897 @@ +#type ("times8")##limit (11.0)##start (2.2, 1.5)##pagelength (17.4)##block# + +#head# +#type ("triumb14")# +#center#EUMEL-Grafik-System + +#type ("times8")# +#end# +#type ("triumb14")# Teil 10: Graphik#type ("times8")# + + +#type ("trium12")# +#on("b")#1. Übersicht#off("b")# +#type ("times8")# + +#limit (7.0)##type("times6")# + #on("i")#Dieser Teil des Benutzer-Handbuchs beschreibt die Graphik- + Fähigkeiten des EUMEL-Systems. Die Graphik-Pakete gehö + ren nicht zum Eumel-Standard, sondern sind Anwenderpake + te, die im Quellcode ausgeliefert und von jeder Installation in das + System aufgenommen werden können. #off("i")# +#limit (11.0)# +#foot# + Eventuell müssen Programme erstellt werden, die die Anpassungen für spezielle graphische Geräte einer Installation + vornehmen, soweit diese nicht von den EUMEL-Anbietern bezogen werden können. +#end# + +#type("times8")# + Das #on("b")#Graphik-System#off("b")# ermöglicht es, durch ELAN-Programme geräteunabhängige Infor + mationen für Zeichnungen (#on("i")#Graphiken#off("i")#) zu erstellen. Die Graphik erzeugenden Programme + brauchen dabei keine geräteabhängigen Größen oder Unterprogramme zu enthalten. Sie + befassen sich somit ausschließlich mit der Erzeugung der problemorientierten Information + für die Konstruktion einer Zeichnung. Nach der geräteunabhängigen Erzeugung einer + Graphik kann diese auf unterschiedlichen Geräten ausgegeben werden (z.B. erst auf einem + Terminal zur Kontrolle und dann auf einem Plotter). + + Die EUMEL-Graphik umfaßt zwei- und dreidimensionale Graphik. Im dreidimensiona + len Fall sind perspektivische, orthografische und schiefwinklige Projektionen mit beliebi + gen Betrachtungswinkeln möglich. + + Bei der EUMEL-Graphik wird streng zwischen Erzeugung und Manipulation von Gra + phiken auf der einen und der Darstellung der erzeugten Bilder auf der anderen Seite + unterschieden. Für die Erzeugung und Manipulation der Graphiken wird von den Paketen + #on("i")#picture#off("i")# und #on("i")#picfile#off("i")# der Datentype #on("b")#PICTURE#off("b")# bzw. #on("b")#PICFILE#off("b")# zur Verfügung gestellt. Dabei + müssen Ausschnitt, Maßstab, Betrachtungswinkel und Projektionsart erst bei der Darstel + lung festgelegt werden. Diese Konstruktion des Graphik-Systems hat folgende Vorteile: + + a) Programme, die Graphik-Information erzeugen, sind geräteunabhängig. Das bedeu + tet, das der Programmierer sich ausschließlich mit einem logischen Problem befassen + muß und nicht mit gerätespezifischen Besonderheiten. + + b) Graphiken können auf mehreren unterschiedlich gearteten Geräten mehrmals darge + stellt werden, ohne daß das erzeugende Programm geändert oder neu gestartet werden + muß. Z.B. kann ein Programmierer eine Graphik erst auf dem Terminal überprüfen, + bevor er die Graphik auf einem Plotter zeichnen läßt. + + c) Graphiken können leicht geändert (z. B. vergrößert oder in eine Richtung gestreckt + o.ä.) werden, ohne daß sie erneut erzeugt werden müssen. Zudem können Graphiken + aneinander oder übereinander gelegt werden. + + d) Graphiken mit unterschiedlichen Farben, Strichen usw. können leicht erzeugt werden. + + e) Der Anschluß von neuen Graphik.Geräten durch Benutzer ist leicht möglich, ohe daß + die Graphik-Programme geändert werden müssen. + + f) Plotter können wie Drucker an einen Spooler gehängt werden. + + g) Bilder können als PICFILEs gespeichert und versandt werden. + + h) Es können auch auf Systemen ohne graphische Ausgabegeräte Graphiken erzeugt + werden. + + i) Es können mit einfachen Mitteln universelle Unterprogrammpakete erstellt werden, + um die Standardzeichnungen (Darstellen einer Funktion, Balken oder Liniendiagram + me, Achsen etc.) zu erstellen. + + +#type ("trium12")# +#on("b")#2. Erzeugung von Bildern#off("b")# +#type ("times8")# + + Bilder entstehen in Objektion vom Datentyp #on("b")#PICTURE#off("b")#. Diese müssen mit der Prozedur + #on("i")#nilpicture#off("i")# initialisiert werden. Sie enthalten dann ein leeres Bild, dessen Dimension noch + nicht festgelegt ist. Die Dimension eines #on("i")#PICTURE#off("i")#s wird mit dem ersten Schreibzugriff + (#on("i")#move, draw#off("i")# o.ä.) festgelegt. Ein #on("i")#PICTURE#off("i")# kann immer nur entweder zwei- oder + dreidimensional sein. + Außerdem kann einem #on("i")#PICTURE#off("i")# mit der Prozedur #on("i")#pen#off("i")# genau ein virtueller Stift zugeord + net oder der aktuelle Stift erfragt werden (Standardeinstellung: 1). + + Für Erzeugung eines Bildes wird ein virtueller Zeichenstift benutzt, dem bei der Darstel + lung jeweils genau ein realer Stift zugeordnet wird. Dieser Stift kann mit der Prozedur + #on("b")#move#off("b")# oder #on("b")#move r #off("b")#auf eine bestimmte Stelle positioniert werden ohne zu zeichnen. Mit + #on("b")#draw#off("b")# oder #on("b")#draw r#off("b")# wird eine Linie von der letzten Position zur angegebene Position + gezeichnet. Die aktuelle Stiftposition kann dabei mit #on("b")#where#off("b")# abgefragt werden. + Außerdem existiert noch die Prozedur #on("b")#draw#off("b")# die einen Text zur Beschriftung der Zeich + nung darstellt, sowie #on("b")#bar#off("b")# zum Zeichnen eines Balkens für Balkendiagramme, #on("b")#circle#off("b")# zum + Zeichnen eines Kreisbogens für Kreisdiagramme und #on("b")#mark#off("b")# zum Markiern von Positionen. + Dabei wird die aktuelle Stiftposition aber nicht verändert. + +#type ("trium12")# +#on("b")#3. Manipulation von PICTUREs#off("b")# +#type ("times8")# + + Erstellte PICTUREs können auch als Ganzes manipuliert werde. Dazu dienen die Prozedu + ren #on("b")#translate, stretch#off("b")# und #on("b")#rotate#off("b")#. Es ist auch möglich mehrere PICTURE mit dem Opera + tor #on("b")#CAT#off("b")# aneinanderzufügen, wenn beide PICTURE die gleiche Dimension haben. In + solcherart manipulierten Bildern kann ohne Einschränkung weitergezeichnet werden, + solange die maximale Größe nicht überschritten wird. + +#type ("trium12")# +#on("b")#4. Darstellung und Speicherung #off("b")# +#type ("times8")# + + Für die Darstellung und Speicherung der erzeugten Bilder existiert der Typ #on("b")#PICFILE#off("b")#. + Dieser besteht aus eienm Datenraum mit max. 1024 PICTUREs, die mit den Prozeduren #on("b")# + delete picture, insert picture, read picture, write picture, get picture#off("b")# und #on("b")#put picture#off("b")# einge + geben bzw. ausgegeben werden können. + Für die Positionierung innerhalb eines PICFILES stehen die Prozeduren #on("b")#to pic, up, down, + eof, picture no, pictures#off("b")# zur Verfügung. + Für die Assoziation mit einem benannten Datenraum existiert ähnlich wie beim Datentyp + FILE die Prozedur #on("b")#picture file#off("b")#; unbenannte Datenräume können mit dem Operator #on("b")#:=#off("b")# + assoziert werden. + Die Darstellung des PICFILES auf einem Zeichengerät erfolgt mit der Prozdur #on("b")#plot#off("b")#. + Da die Graphiken aber in #on("i")#Weltkoordinaten#off("i")# erzeugt werden und die spätere Darstellung + vollkommen unbeachtet bleibt, müssen gewisse Darstellungsparameter für die Zeichnung + gesetzt werden. Dies Parameter werden im PICFILE abgelegt und gelten jeweils für alle + darin enthaltenen PICTURE. Dadurch ist es möglich, einen PICFILE mit spezifierter + Darstellungsart über einen SPOOLER an einen Plotter zu senden oder die bei der letzten + Betrachtung gewählte Darstellung beizubehalten oder zu ändern. + Für die Darstellung können den virtuellen Stiften mit der Prozedur #on("b")#select pen#off("b")# reale Stifte + zugeordnet werden. Voreingestellt ist für alle virtuellen Stifte die Standardfarbe, Standard + stärke und durchgängige Linie. Mit #on("b")#background#off("b")# kann eine bestimmte Hintergrundfarbe + gewählt werden. + Indem man einem PICTURE den Stift 0 zuordnet, kann man dieses auch Ausblenden + wenn es bei dieser Darstellung stört. + Die Größe der realen Zeichenfläche kann mit #on("b")#viewport#off("b")# eingestellt werden, wobei die + gesamte Zeichenfäche voreingestellt ist. Dadurch können auch mehrere PICFILE auf ein + Blatt oder einen Bildschirm gezeichnet werden, wenn man durch Angabe von #on("i")#background + (0)#off("i")# das Löschen der Zeichenfläche unterdrückt. + + +#type ("trium12")# +#on("b")#5. Darstellung zweidimensionaler Graphik#off("b")# +#type ("times8")# + + Bei der Darstellung zweidimensionaler Bilder muß der zu zeichnende Ausschnitt (das + #on("i")#Fenster#off("i")#) angegeben werden. Mit der Prozedur #on("b")#window#off("b")# wird durch Angabe der minimalen + und maximalen X- bzw. Y-Koordinaten ein Fenster definiert. Linien, die über dieses + Fenster hinausgehen, werden abgeschnitten. Dadurch kann man einen beliebigen Detailaus + schnitt eines Bildes ausgeben, ohne das Bild neu generieren zu müssen. + Da das so definierte Fenster auf die mit #on("i")#viewport#off("i")# definierte Zeichenfläche abgebildet wird, + ist der Abbildungsmaßstab durch das Zusammenspiel von #on("i")#viewport#off("i")# und #on("i")#window#off("i")# bestimmt. + Wenn eine Winkeltreue Darstellung erreicht werdenn soll, muß das Verhältnis der durch + #on("i")#viewport#off("i")# eingestellten Breite und Höhe und das Verhältnis des durch #on("i")#window#off("i")# eingestellten + Ausschnitts gleich sein. + +#type ("trium12")# +#on("b")#6. Darstellung dreidimensionaler Graphik#off("b")# +#type ("times8")# + + Bei dreidimensionalen Zeichnungen wird das Fenster ebenfalls mit #on("b")#window#off("b")# definiert, + wobei dann allerdings auch der Wertebereich der dritten Dimension (Z-Koordinaten) zu + berücksichtigen ist. Auch hierbei werden Linien, die über die spezifierte Darstellungs + fläche hinausgehen abgeschnitten. Das Abschneiden erfolgt allerdings erst nach der Projek + tion auf die Darstellungsfläche, so daß auch Vektoren zu sehen sind, die über das mit + #on("i")#window#off("i")# angegebene Quader hinausgehen, wenn ihre Projektion innerhalb der Zeichen + fläche liegt. + Da die dreidimensionale Graphik auf eine zweidimensionale Fläche projeziert wird, + können aber noch weitere Darstellungsparameter angegeben werden. Der Betrachtungswin + kel wird mit Hilfe der Prozedur #on("b")#view#off("b")# angegeben. Ebenfalls kann mit #on("b")#view#off("b")# der Winkel der + Y-Achse zur Horizontalen angegeben werden. + Zur Spezifikation der gewünschten Projektionsart existieren #on("b")#orthographic#off("b")# (orthographische + Projektion), #on("b")#perspective#off("b")# (perspektivische Projektion, der Fluchtpunkt ist frei wählbar) und + #on("b")#oblique#off("b")# (schiefwinklige Projektion). + +#page# +#type ("trium12")# +#on("b")#7. Beispiele#off("b")# +#type ("times8")# + + #on("u")#Sinuskurve#off("u")# + +#type("micro")# +initialisiere picfile; +zeichne überschrift; +zeichne achsen; +zeichne sinuskurve; +wähle darstellung; +plot (p) . + +initialisiere picfile: + PICFILE VAR p :: picture file ("SINUS") . + +zeichne überschrift: + PICTURE VAR überschrift :: nilpicture; + move (überschrift, -pi/2.0, 1.0); + draw (überschrift, "sinus (x) [-pi, +pi]", 0.0, 1.0, 0.6); + put picture (p, überschrift) . + + zeichne achsen: + PICTURE VAR achsen :: nilpicture; + zeichne x achse; + zeichne y achse; + put picture (p, achsen) . + + zeichne x achse: + move (achsen, -pi, 0.0); + draw (achsen, pi, 0.0) . + + zeichne y achse: + move (achsen, 0.0, -1.0); + draw (achsen, 0.0, +1.0) . + + zeichne sinuskurve: + PICTURE VAR sinus :: nilpicture; + REAL VAR x :: -pi; + + move (sinus, x, sin (x)); + REP x INCR 0.1; + draw (sinus, x, sin (x)) + UNTIL x >= pi PER; + + put picture (p, sinus) . + + wähle darstellung: + window (p, -pi, pi, -1.0, 1.3); + viewport (p, 0.0, 0.0, 0.0, 0.0) . + +#page# +#type ("times8")# + #on("u")#Achsenkreuz#off("u")# + +#type("micro")# +initialisiere picfile; +zeichne die x achse; +zeichne die y achse; +zeichne die z achse; +stelle das achsenkreuz dar . + +initialisiere picfile: + PICFILE VAR p :: picture file ("KREUZ") . + + zeichne die x achse: + PICTURE VAR x achse := nilpicture; + move (x achse, -1.0, 0.0, 0.0); + draw (x achse, "-X", 0.0, 0.0, 0.0); + draw (x achse, 1.0, 0.0, 0.0); + draw (x achse, "+X", 0.0, 0.0, 0.0); + put picture (p, x achse) . + + zeichne die y achse: + PICTURE VAR y achse := nilpicture; + move (y achse, 0. 0, -1.0, 0.0); + draw (y achse, "-Y", 0.0, 0.0, 0.0); + draw (y achse, 0.0, 1.0, 0.0); + draw (y achse, "+Y", 0.0, 0.0, 0.0); + put picture (p, y achse) . + + zeichne die z achse: + PICTURE VAR z achse := nilpicture; + move (z achse, 0. 0, 0.0, -1.0); + draw (z achse, "-Z", 0.0, 0.0, 0.0); + draw (z achse, 0.0, 0.0, 1.0); + draw (z achse, "+Z", 0.0, 0.0, 0.0); + put picture (p, z achse) . + + stelle das achsenkreuz dar: + viewport (p, 0. 0, 1.0, 0.0, 1.0); + window (p, -1.1, 1.1, -1.1, 1.1); + oblique (p, 0.25, 0.15); + plot (p) . + +#foot# + #type("times6")# + Diese beiden Beispielprogramme befinden sich ebenfalls auf dem STD-Archive unter dem Namen #on("i")#Beispiel.Sinus#off("i")# und + #on("i")#Beispiel.Kreuz#off("i")#. +#end# + +#page# +#type ("triumb14")# Beschreibung der Graphik-Prozeduren +#type ("times8")# + + +#type ("trium12")# +#on("b")#1. PICTURE-Prozeduren#off("b")# +#type ("times8")# + +#limit (7.0)##type("times6")# + #on("i")#Zweidimensionale PICTURES brauchen weniger Speicherplatz + als dreidimensionale. Daher werden in einigen Fehlermeldungen + unterschiedliche Größen angegeben. + +#limit (11.0)##type("times8")# + +#type("times10")##on("b")#:=#off("b")##type("times8")# + OP := (PICTURE VAR l, PICTURE CONST r) + Zweck: Zuweisung + +#type("times10")##on("b")#CAT#off("b")##type("times8")# + OP CAT (PICTURE VAR l, PICTURE CONST r) + Zweck: Aneinanderfügen von zwei PICTURE. + Fehlerfälle: + * left dimension <> right dimension + Es können nur PICTURE mit gleicher Dimension angefügt werden. + * Picture overflow + Die beiden PICTURE überschreiten die maximale Größe eines PICTURE. + +#type("times10")##on("b")#nilpicture#off("b")##type("times8")# + PICTURE PROC nilpicture + Zweck: Die Prozedur liefert ein leeres PICTURE zur Initialisierung. + + PICTURE PROC nilpicture (INT CONST pen) + Zweck: Die Prozedur liefert ein leeres PICTURE mit dem Stift #on("i")#pen#off("i")# zur Initialisierung. + +#type("times10")##on("b")#draw#off("b")##type("times8")# + PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, + width) + Zweck: Der angegebene Text wird unter dem Winkel #on("i")#angle#off("i")# gegenüber der Waagerech + ten mit der Zeichenhöhe #on("i")#hight#off("i")# und der Breite #on("i")#width#off("i")# gezeichnet. #on("i")#angle#off("i")# wird in + Winkelgrad angegeben. #on("i")#height#off("i")# und #on("i")#width#off("i")# werden in #on("i")#Prozenten#off("i")# der Breite bzw. + Höhe der Zeichenfläche angegeben, bei 0 wird + die Standardhöhe- und breite angenommen. + Der Anfang ist dabei die aktuelle Stiftposition, die nicht verändert wird. Es könne + auch die Steuerzeichen ""1"", ""2"", ""3"", ""10"", ""13"" benutzt werden, + wobei sie immer in der Richtung #on("i")#angle#off("i")# wirken. + Fehlerfälle: + * Picture overflow + Der Text paßt nicht mehr in das PICTURE. + +#type("times10")##on("b")#draw#off("b")##type("times8")# + PROC draw (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y, z). + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC draw (PICTURE VAR p, REAL CONST x, y) + Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y). + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +#type("times10")##on("b")#draw r#off("b")##type("times8")# + PROC draw r (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Zeichnen einer Linie der Länge (x, y, z) relativ zur aktuellen Position. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC draw r (PICTURE VAR p, REAL CONST x, y) + Zweck: Zeichnen einer Linie der Länge (x, y) relativ zur aktuellen Position. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +#type("times10")##on("b")#move#off("b")##type("times8")# + PROC move (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Die aktuelle Position wird auf (x, y, z) gesetzt. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC move (PICTURE VAR p, REAL CONST x, y) + Zweck: Die aktuelle Position wird auf (x, y) gesetzt. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +#type("times10")##on("b")#move r#off("b")##type("times8")# + PROC move r (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Die aktuelle Position wird um (x, y, z) erhöht. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC move r (PICTURE VAR p, REAL CONST x, y) + Zweck: Die aktuelle Position wird um (x, y) erhöht. + Position. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + + +#type("times10")##on("b")#bar#off("b")##type("times8")# + PROC bar (PICTURE VAR p, REAL CONST width, hight, INT CONST pattern): + Zweck: Die Prozedur zeichnet an der aktuellen Position einen Balken mit dem Muster + #on("i")#pattern#off("i")#: + 0 = Leerer Balken + 1 = Gepunkteter Balken + 2 = Gefüllter Balken + 3 = Horizontale Linien + 4 = Vertikale Linien + 5 = Gekreuzte Linien + 6 = Diagonale Linien von Links nach Rechts + 7 = Diagonale Linien von Rechts nach Links + 8 = Gekreuzte diagonale Linien + > 8 = nicht normiertes Sondermuster + Die aktuelle Stiftposition wird dabei nicht verändert. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + + PROC bar (PICTURE VAR p, REAL CONST from, to, hight, INT CONST pattern): + Zweck: Die Prozedur zeichnet einen Balken von der Position #on("i")#from#off("i")# zur Position #on("i")#to#off("i")# und der + Höhe #on("i")#height#off("i")# mit dem Muster #on("i")#pattern#off("i")#. + s.o. + +#type("times10")##on("b")#circle#off("b")##type("times8")# + PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern) + Zweck: Die Prozedur zeichnet an der aktuellen Position ein Kreissegment vom Winkel + #on("i")#from#off("i")# bis #on("i")#to#off("i")# (im Gradmaß) mit dem Muster #on("i")#pattern#off("i")# (s.o.). Der #on("i")#radius#off("i")# wird in + Prozenten der Diagonalen der Zeichenfläche angegeben. + Die aktuelle Stiftposition wird dabei nicht verändert. Dieses Kreissegment ist in + jedem Fall 2-dimensional, so das es durch Drehungen nicht verändert wird. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +#type("times10")##on("b")#mark#off("b")##type("times8")# + PROC mark (PICTURE VAR p, REAL CONST size, INT CONST no) + Zweck: Es wird ein Marker mit der Größe #on("i")#size#off("i")# in Prozenten der Diagonalen der Zeichen + fläche an der aktuellen Stiftposition ausgegeben, ohne diese zu verändern. Es + sollten dabei mindestens 10 verschiedene Marker gewählt werden können. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + +#type("times10")##on("b")#dim#off("b")##type("times8")# + INT PROC dim (PICTURE CONST pic) + Zweck: Liefert die Dimension eines PICTURE. + +#type("times10")##on("b")#pen#off("b")##type("times8")# + INT PROC pen (PICTURE CONST p) + Zweck: Liefert den virtuellen Stift des PICTURE + + PICTURE PROC pen (PICTURE CONST p, INT CONST pen) + Zweck: Setzen des (virtuellen) Stiftes eines PICTURE. + Bei #on("i")#pen#off("i")# = 0 wird das Picture nicht gezeichnet. + Fehlerfälle: + * pen out of range + Der gewünschte Stift ist kleiner als 0 oder größer als 16. + +#type("times10")##on("b")#extrema#off("b")##type("times8")# + PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE. + Fehlerfälle: + * Picture is three dimensional + + PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, + z min, z max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE. + Fehlerfälle: + * Picture is two dimensional + +#type("times10")##on("b")#where#off("b")##type("times8")# + PROC where (PICTURE CONST p, REAL VAR x, y, z) + Zweck: Die Prozedur liefert die aktuelle Stiftposition. + Fehlerfälle: + * Picture is two dimensional + + PROC where (PICTURE CONST p, REAL VAR x, y, z) + Zweck: Die Prozedur liefert die aktuelle Stiftposition. Fehlerfälle: + * Picture is three dimensional + +#type("times10")##on("b")#rotate#off("b")##type("times8")# + PROC rotate (PICTURE VAR p, REAL CONST angle) + Zweck: Das PICTURE wird um den Punkt (0, 0) um den Winkel #on("i")#angle#off("i")# (im Gradmaß) im + mathematisch positiven Sinn gedreht. + + PROC rotate (PICTURE CONST p, REAL CONST phi, theta, lambda) + Zweck: Das PICTURE wird um den Winkel #on("i")#lambda#off("i")# um die Drehachse #on("i")#(phi, theta)#off("i")# ge + dreht. + +#type("times10")##on("b")#stretch#off("b")##type("times8")# + PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) + Zweck: Das PICTURE wird in X-Richtung um den Faktor #on("i")#sx#off("i")#, in Y-Richtung um den + Faktor #on("i")#sy#off("i")# gestreckt (bzw. gestaucht). Dabei bewirkt der Faktor + s > 1 eine Streckung + 0 < s < 1 eine Stauchung + s < 0 zusätzlich eine Achsenspiegelung. + Fehlerfälle: + * Picture is three dimensional + + PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) + Zweck: s. o. + Fehlerfälle: + * Picture is two dimensional + +#type("times10")##on("b")#translate#off("b")##type("times8")# + PROC translate (PICTURE VAR p, REAL CONST dx, dy) + Zweck: Das PICTURE wird um #on("i")#dx#off("i")# und #on("i")#dy#off("i")# verschoben. Fehlerfälle: + * Picture is three dimensional + + PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) + Zweck: Das PICTURE wird um #on("i")#dx, dy#off("i")# und #on("i")#dz#off("i")# verschoben. Fehlerfälle: + * Picture is two dimensional + + +#type ("trium12")# +#on("b")#2. PICFILE-Prozeduren#off("b")# +#type ("times8")# + +#type("times10")##on("b")#plot#off("b")##type("times8")# + PROC plot (TEXT CONST name) + Zweck: Der PICFILE mit dem Namen #on("i")#name#off("i")# wird entsprechend der angegebenen Dar + stellungsart gezeichnet. Diese Parameter (#on("i")#perspective, orthographic, oblique, view, + window etc.#off("i")#) müssen vorher eingestellt werden. + Fehlerfälle: + * PICFILE does not exist + Es existiert kein PICFILE mit dem Namen #on("i")#name#off("i")# + + PROC plot (PICFILE VAR p) + Zweck: Der PICFILE #on("i")#p#off("i")# wird entsprechend der angegebenen Darstellungsart gezeichnet. + Diese Parameter müssen vorher eingestellt werden: + + #on("b")#zweidimensional:#off("b")# + obligat: #on("i")#window#off("i")# (zweidimensional) + optional: #on("i")#view#off("i")# (zweidimensional) + #on("i")#viewport#off("i")# + #on("i")#select pen#off("i")# + + #on("b")#dreidimensional:#off("b")# + obligat: #on("i")#window#off("i")# (dreidimensional) + optional: #on("i")#view#off("i")# (dreidimensional) + #on("i")#orthographic | perspective | oblique#off("i")# + #on("i")#viewport#off("i")# + #on("i")#select pen#off("i")# + + +#type("times10")##on("b")#select pen#off("b")##type("times8")# + PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type) + Zweck: Für die Darstellung des Bildes #on("i")#p#off("i")# soll dem #on("i")#virtuellen#off("i")# Stift #on("i")#pen#off("i")# ein realer Stift + zugeordnet werden, der möglichst die Farbe #on("i")#colour#off("i")# und die Dicke #on("i")#thickness#off("i")# hat + und dabei Linien mit dem Typ #on("i")#line type#off("i")# zeichnet. Es wird die beste Annäherung + für das Ausgabegerät genommen. + Dabei gelten folgende Vereinbarungen: + + #on("b")#Farbe:#off("b")# Negative Farben werden XOR gezeichnet (dunkel wird hell und hell wird + dunkel), Farbe 0 ist der Löschstift und positive Farben überschreiben + (ersetzen) den alten Punkt mit folgenden Werten: + + 1 Standardfarbe des Endgerätes + 2 rot + 3 blau + 4 grün + 5 schwarz + 6 weiß + > 6 nicht normierte Sonderfarben + + + #on("b")#Dicke:#off("b")# 0 Standardstrichstärke des Endgerätes + > 0 Strichstärke in 1/10 mm. + + + #on("b")#Linientyp:#off("b")# + 0 keine sichtbare Linie + 1 durchgängige Linie + 2 gepunktete Linie + 3 kurz gestrichelte Linie + 4 lang gestrichelte Linie + 5 Strichpunktlinie + > 5 nicht normierte Linie + + + Die hier aufgeführten Möglichkeiten müssen nicht an allen graphischen Endge + räten vorhanden sein. Der geräteabhängige Graphik-Treiber wählt jeweils die + bestmögliche Annäherung. + + Fehlerfälle: + * pen out of range + #on("i")#pen#off("i")# muss im Bereich 1-16 sein. + +#type("times10")##on("b")#background#off("b")##type("times8")# + PROC background (PICFILE VAR p, INT CONST colour) + Zweck: Der Hintergrund wird auf die Farbe #on("i")#colour#off("i")# (s.o.) gesetzt wenn möglich. + Bei der Angabe #on("i")#background (p, 0)#off("i")# wird das Löschen des Bildschirms unterdrückt, + so daß das Zeichen mehrerer PICFILE auf einem Blatt möglich wird. + + INT PROC background (PICFILE CONST p): + Zweck: Liefert die eingestellte Hintergrundfarbe. + +#type("times10")##on("b")#view#off("b")##type("times8")# + PROC view (PICFILE VAR p, REAL CONST alpha) + Zweck: Setzt den Winkel der Y-Achse zur Senkrechten auf #on("i")#alpha#off("i")# Grad, falls diese nicht + senkrecht auf der Betrachtungsebene steht. + + PROC view (PICFILE VAR p, REAL CONST phi, theta) + Zweck: Dreidimensionale Bilder werden häufig nicht direkt von vorne dargestellt, son + dern für die Betrachtung gedreht. Mit der Prozedur #on("i")#view#off("i")# kann die Betrachtungs + richtung durch die Polarwinkel #on("i")#phi#off("i")# und #on("i")#theta#off("i")# (im Gradmass) angegeben werden. + Voreingestellt ist #on("i")#phi#off("i")# = 0 und #on("i")#theta#off("i")# = 0, d.h. senkrecht von oben (Die #on("i")#X- + Achse#off("i")# bildet die Horizontale und die #on("i")#Y-Achse#off("i")# bildet die Vertikale). + Im Gegensatz zu #on("i")#rotate#off("i")# hat #on("i")#view#off("i")# keine Wirkung auf das eigentliche Bild (die + PICTURE werden nicht verändert), sondern nur auf die gewählte Darstellung. So + addieren sich zwar aufeinanderfolgende #on("i")#Rotationen#off("i")#, #on("i")#view#off("i")# aber geht immer von der + Nullstellung aus. Auch kann das Bild durch eine #on("i")#Rotation#off("i")# ganz oder teilweise aus + oder in das Darstellungsfenster (#on("i")#window#off("i")# gedreht werden. Bei #on("i")#view#off("i")# verändern sich + die Koordinaten der Punkte nicht, d. h. das Fenster wird mitgedreht. + + PROC view (PICFILE VAR p, REAL CONST x, y, z) + Zweck: Wie oben, nur werden die Winkel nicht in Polarkoordinaten angegeben, sondern + es wird die Blickrichtung als Vektor in Karthesischen Koordinaten angegeben. + (Der Betrachtungsvektor muß nicht normiert sein). + +#type("times10")##on("b")#viewport#off("b")##type("times8")# + PROC viewport (PICFILE VAR p, REAL CONST hormin, hormax, vertmin, vertmax) + Zweck: Die Zeichenfläche auf dem Endgerät, auf dem das Bild dargestellt werden soll, + wird spezifiziert. Dabei wird sowohl die Größe als auch die relative Lage der + Zeichenfläche definiert. Der linke untere Eckpunkt der physikalischen Zeichen + fläche des Gerätes hat die Koordinaten (0, 0). Die definierte Zeichenfläche er + streckt sich + + #on("i")#hormin - hormax#off("i")# in der Horizontalen, + #on("i")#vertmin - vertmax#off("i")# in der Vertikalen. + + So liegt der linke untere Eckpunkt dann bei (#on("i")#hormin, hormax#off("i")#), der rechte obere + Eckpunkt bei (#on("i")#hormax, vertmax#off("i")#). + + Damit sowohl geräteunabhängige als auch maßstabgetreue Zeichnungen möglich + sind, können die Koordinaten in drei Arten spezifiziert werden: + a) #on("b")#Gerätekoordinaten#off("b")# + Die Koordinaten können Werte von 0.0 bis 2.0 annehmen. Dabei hat die + kürzere Seite der physikalischen Zeichenfläche definitionsgemäß die Länge + 1.0. + b) #on("b")#Absolute Koordinaten#off("b")# + Die Werte werden in #on("i")#cm#off("i")# angegeben. Dabei müssen die Maximalwerte aber + größer als 2.0 sein, da sonst Fall a) angenommen wird. + c) #on("b")#Maximale Zeichenfläche#off("b")# Bei der Angabe (0.0, 0.0, 0.0, 0.0) wird die maxi + male physikalische Zeichenfläche eingestellt. + + Voreingestellt ist + viewport (0.0, 0.0, 0.0, 0.0) + d.h. die größtmögliche physikalische Zeichenfläche, beginnend mit der linken + unteren Ecke. + Der Abbildungsmaßstab wird durch das Zusammenspiel von #on("i")#viewport#off("i")# und + #on("i")#window#off("i")# festgelegt (s. dort). Dabei ist insbesondere darauf zu achten, daß winkel + treue Darstellung nur bei gleichen Verhältnissen von X-Bereich und Breite bzw. + von Y-Bereich und Höhe möglich ist. + + +#type("times10")##on("b")#window#off("b")##type("times8")# + PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) + Zweck: Für die Darstellung eines zweidimensionalen Bildes wird das darzustellende + Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("i")#x min, x + max#off("i")#] und deren Y-Koordinaten im Bereich [#on("i")#y min, y max#off("i")#] liegen, gehören zum + definierten Fenster.Vektoren, die außerhalb dieses Fensters liegen, gehen über die + durch #on("i")#viewport#off("i")# Fläche hinaus und werden abgeschnitten. + + Der Darstellungsmaßstab ergibt sich als + + #ub# x max - x min #ue# + horizontale Seitenlänge der Zeichenfläche + + + #ub# y max - y min #ue# + vertikale Seitenlänge der Zeichenfläche + + PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, + z min, z max) + + Zweck: Für die darstellung eines dreidimensionalen Bildes wird das darzustellende Fenster + definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("i")#x min, x max#off("i")#], + deren Y-Koordinaten im Bereich [#on("i")#y min, y max#off("i")#] und deren Z-Koordinaten im + Bereich [#on("i")#z min, z max#off("i")#] liegen, gehören zum definierten Fenster. Dieses dreidi + mensionale Fenster (#on("i")#Quader#off("i")#) wird entsprechend der eingestellten Projektionsart + (orthographisch, perspektivisch oder schiefwinklig) und den Betrachtungswinkeln + (s. #on("i")#view#off("i")#) auf die spezifizierte Zeichenfläche abgebildet. + Anders als im zweidimensionalen Fall ist das Problem der Maßstaäbe nicht mehr + nur durch das Zusammenspiel von #on("i")#window#off("i")# und #on("i")#viewport#off("i")# zu beschreiben. Hier + spielen auch die Projektionsart und Darstellungswinkel herein. + +#type("times10")##on("b")#oblique#off("b")##type("times8")# + PROC oblique (PICFILE VAR p, REAL CONST a, b) + Zweck: Bei dem (dreidimensionalen) Bild #on("i")#p#off("i")# wird #on("u")#schiefwinklig#off("u")# als gewünschte Projek + tionsart eingestellt. Dabei ist (#on("i")#a, b#off("i")#) der Punkt auf der X-Y-Ebene, auf den der + EinheitsVektor der Z-Richtung abgebildet werden soll. + +#type("times10")##on("b")#orthographic#off("b")##type("times8")# + PROC orthographic (PICFILE VAR p) + Zweck: Bei dem (dreidimensionalen) Bild #on("i")#p#off("i")# wird #on("u")#orthographisch#off("u")# als gewünschte Projek + tionsart eingestellt. Bei der orthographischen Projektion wird ein dreidimensio + naler Körper mit parallelen Strahlen senkrecht auf der Projektionsebene abge + bildet. + +#type("times10")##on("b")#perpective#off("b")##type("times8")# + PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) + Zweck: Bei dem (dreidimensionalen) Bild #on("i")#p#off("i")# wird #on("u")#perspektivisch#off("u")# als gewünschte Projek + tionsart eingestellt. Der Punkt (#on("i")#cx, 1/cy, cz#off("i")#) ist der Fluchtpunkt der Projektion, + d. h. alle Parallen zur Z-Achse schneiden sich in diesem Punkt. + +#type("times10")##on("b")#extrema#off("b")##type("times8")# + PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE. + + PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE. + +#type ("trium12")# +#on("b")#3. Prozeduren zur Manipulation von PICFILE#off("b")# +#type("times 8")# + +#type("times10")##on("b")#:=#off("b")##type("times8")# + OP := (PICFILE VAR l, PICFILE CONST r) + Zweck: Zuweisung des PIFILEs #on("i")#r#off("i")# an das PICFILE #on("i")#l#off("i")# + + OP := (PICFILE VAR p, DATASPACE CONST d) + Zweck: Assoziert die PICFILE Variable #on("i")#p#off("i")# mit dem Datenraum #on("i")#d#off("i")# und initialisiert die + Variable, wenn nötig. + Fehlerfälle: + * dataspace is no PICFILE + Der anzukoppelnde Datenraum hat einen unzulässigen Typ + +#type("times10")##on("b")#picture file#off("b")##type("times8")# + DATASPACE PROC picture file (TEXT CONST name) + Zweck: Assoziaten eines benannten Datenraumes mit einem PICFILE (s.o.). + +#type("times10")##on("b")#to pic#off("b")##type("times8")# + PROC to pic (PICFILE VAR p, INT CONST pos) + Zweck: Positioniert auf das PICTURE Nummer #on("i")#pos#off("i")#. + Fehlerfälle: + * Position underflow + Es wurde eine Position kleiner Null angegeben. + * Position after eof + Es wurde versucht, hinter das Ende eines PICFILE zu positionieren. Die letzte + erlaubte Position ist #on("i")#pictures (p)+1#off("i")#. + +#type("times10")##on("b")#up#off("b")##type("times8")# + PROC up (PICFILE VAR p) + Zweck: Positioniert genau ein PICTURE zurück. + Fehlerfall: + * Position underflow + Es wurde versucht, vor das erste PICTURE zu positionieren + + PROC up (PICFILE VAR p, INT CONST n) + Zweck: Positioniert genau #on("i")#n#off("i")# Picture zurück. + Fehlerfall: + * Position underflow + Es wurde versucht, vor das erste PICTURE zu positionieren + +#type("times10")##on("b")#down#off("b")##type("times8")# + PROC down (PICFILE VAR p) + Zweck: Positioniert genau ein PICTURE vorwärts. + Fehlerfall: + * Position after eof + Es wurde versucht, hinter das Ende eines PICFILE zu positionieren. Die letzte + erlaubte Position ist #on("i")#pictures (p)+1#off("i")#. + + PROC down (PICFILE VAR p, INT CONST n) + Zweck: Positioniert genau #on("i")#n#off("i")# Picture vorwärts. + Fehlerfall: + * Position after eof + Es wurde versucht, hinter das Ende eines PICFILE zu positionieren Die letzte + erlaubte Position ist #on("i")#pictures (p)+1#off("i")#. + +#type("times10")##on("b")#delete picture#off("b")##type("times8")# + PROC delete picture (PICFILE VAR p) + Zweck: Löscht das aktuelle PICTURE + +#type("times10")##on("b")#insert picture#off("b")##type("times8")# + PROC insert picture (PICFILE VAR p) + Zweck: Fügt ein PICTURE #on("u")#vor#off("u")# der aktuellen Position ein. + +#type("times10")##on("b")#read picture#off("b")##type("times8")# + PROC read picture (PICFILE CONST p, PICTURE VAR pic) + Zweck: Liest das aktuelle PICTURE. + +#type("times10")##on("b")#write picture#off("b")##type("times8")# + PROC write picture (PICFILE VAR p, PICTURE CONST pic) + Zweck: Schreibt das PICTURE #on("i")#pic#off("i")# auf der aktuellen Position. + +#type("times10")##on("b")#put picture#off("b")##type("times8")# + PROC put picture (PICFILE VAR p, PICTURE CONST pic) + Zweck: Schreibt das PICTURE #on("i")#pic#off("i")# an die aktuelle Position und erhöht diese um 1. + +#type("times10")##on("b")#get picture#off("b")##type("times8")# + PROC get picture (PICFILE VAR p, PICTURE VAR pic) + Zweck: Liest das PICTURE #on("i")#pic#off("i")# an dir aktuellen Position und erhöht diese um 1. + +#type("times10")##on("b")#eof#off("b")##type("times8")# + BOOL PROC eof (PICFILE CONST p) + Zweck: Liefert genau dann #on("i")#TRUE#off("i")#, wenn das Ende eines PICFILE erreicht ist. + +#type("times10")##on("b")#picture no#off("b")##type("times8")# + INT PROC picture no (PICFILE CONST p) + Zweck: Liefert die Nummer des aktuellen PICTURE. + +#type("times10")##on("b")#pictures#off("b")##type("times8")# + INT PROC pictures (PICFILE CONST p) + Zweck: Liefert die Anzahl PICTURE eines PICFILE. + + +#page# +#type ("trium12")# +#on("b")#4. Auslieferungsumfang#off("b")# +#type ("times8")# + + Die EUMEL-GRAPHIK wird auf einer Diskette mit folgendem Inhalt ausgeliefert. + Archive #on("i")#Graphik#off("i")#: + + "gen Graphik" + "gen Plotter" + "GRAPHIK.book" + "GRAPHIK.Picfile" + "GRAPHIK.Transform" + "GRAPHIK.Plot" + "GRAPHIK.Plotter" + "GRAPHIK.Server" + "GRAPHIK.vektor plot" + "ZEICHENSATZ" + "PC.plot" + "HP7475.plot" + "Beispiel.Kreuz" + "Beispiel.Sinus" + + + + #on("u")#Dateiinhalte#off("u")# + + 1. "gen Graphik" Installationsprogramm für Terminals + 2. "gen Plotter" Installationsprogramm für Plotter + 3. "GRAPHIK.book" enthält diese Beschreibung. + 4. "GRAPHIK.Picfile" enthält die Pakete #on("i")#picture#off("i")# und #on("i")#picfile#off("i")#. + 5. "GRAPHIK.Transform" stellt das Paket #on("i")#transformation#off("i")# zur Verfügung, in dem + interne Prozeduren zur Projektion definiert werden. + 6. "GRAPHIK.Plot" definiert die Prozedur #on("i")#plot#off("i")# zur Darstellung eines + PICFILES auf dem Terminal + 7. "GRAPHIK.Plotter" definiert die Prozedur #on("i")#plotter#off("i")# zur Darstellung eines + PICFILES auf dem Plotter + 8. "GRAPHIK.Server" Server für einen Plotter-Spool + 9. "GRAPHIK.vektor plot" enthält Hilfsprogramme, die bei der Erstellung einer + eigenen Terminalanpassung benutzt werden können. + 10. "ZEICHENSATZ" enthält einen Zeichensatz für Terminals die im Graphik + Modus keinen Text ausgeben können. + 11. "PC.plot" Terminalanpassung für IBM-PC und ähnliche. + 12. "HP7475.plot" Terminalanpassung für HP7474-Plotter und Geräte mit + HP-GL. + 13. "Beispiel.Kreuz" Beispielprogramm + 14. "Beispiel.Sinus" Beispielprogramm + +#type ("trium12")# +#on("b")#5. Installation#off("b")# +#type ("times8")# + + + In der Datei #on("i")#gen Graphik#off("i")# ist ein Installationspragramm enthalten. Nach dem Starten des + Programms mit #on("i")#run ("gen Graphik")#off("i")# fragt es nach dem Dateinamen der Terminalanpas + sung. + Steht keine Terminalanpassung für ein Endgerät zur Verfügung (und kann auch nicht + beschafft werden) so kann man durch Insertieren der Datei #on("i")#GRAPHIK.Picfile#off("i")# lediglich die + Leistungen der Pakete #on("i")#Picture#off("i")# und #on("i")#Picfile#off("i")# nutzen, ohne die erzeugten Graphiken darstellen + zu können. + Zur Benutzung eines #on("i")#Plotters#off("i")# über einen Spooler wird die Datei #on("i")#gen Plotter#off("i")# gestartet. + + + Beispiel: + 1. archive ("Graphik") + 2. fetch all (archive) + 3. release (archive) + 4. run ("gen Graphik") + <-- PC.Plot + + +#type ("trium12")# +#on("b")#6. Besonderheiten der PC.plot-Anpassung#off("b")# +#type ("times8")# + + + Da der IBM-PC verschiedene Graphik- und Text-Modi kennt, wird durch das Pro + gramm #on("i")#PC.plot#off("i")# die Prozedur #on("i")#graphik#off("i")# zusätzlich zur Verfügung gestellt. Sie erlaubt es den + PC in verschiedenen Graphik-Modi zu betreiben. + + PROC graphik (INT CONST modus, pause) + + Modus: 0 --- Keine Graphik (normaler Textmodus) + 1 --- hochauflösende Graphik, 50 Zeilen, + 640 * 400 Punkte, einfarbig + 2 --- hochauflösende Graphik, 25 Zeilen, + 640 * 400 Punkte, einfarbig + 3 --- mittlere Auflösung, 640 * 200 Punkte, 3 Farben + 4 --- IBM-PC Auflösung, 320 * 200 Punkte, 3 Farben. + + Pause: Da der PC bei #on("i")#end plot#off("i")# wieder in den Normalmodus umschaltet und die Graphik + dann nicht mehr zu sehen ist, kann man eine #on("i")#pause#off("i")# angeben. Die hier eingestellte + Zeit ist aber nicht die Länge der Pause, sondern der Kehrwert der Blinkfrequenz + proportional. + + diff --git a/system/std.graphik/1.8.7/doc/graphik beschreibung b/system/std.graphik/1.8.7/doc/graphik beschreibung new file mode 100644 index 0000000..53ebe49 --- /dev/null +++ b/system/std.graphik/1.8.7/doc/graphik beschreibung @@ -0,0 +1,661 @@ +#type ("basker12")##limit (16.0)##block# + +#head# +#type ("triumb18")# +#center#EUMEL-Grafik-System +#type ("basker12")# +#end# + #on("italics")#gescheit, gescheiter, + gescheitert#off("italics")# + +#type ("basker14")# +#on("bold")#Beschreibung der Graphik-Prozeduren#off("bold")# +#type ("basker12")# + + #on("italics")#Zweidimensionale PICTURE brauchen weniger Speicherplatz als dreidimen + sionale. Daher werden in einigen Fehlermeldungen unterschiedliche Größen + angegeben.#off("italics")# + +#on("underline")#Picture-Prozeduren#off("underline")# +PICTURE + + +:= + OP := (PICTURE VAR l, PICTURE CONST r) + Zweck: Zuweisung + +CAT + OP CAT (PICTURE VAR l, PICTURE CONST r) + Zweck: Aneinanderfügen von zwei PICTURE. + Fehlerfälle: + * left dimension <> right dimension + Es können nur PICTURE mit gleicher Dimension angefügt werden. + * Picture overflow + Die beiden PICTURE überschreiten die maximale Größe eines + PICTURE. + +nilpicture + PICTURE PROC nilpicture + Zweck: Die Prozedur liefert ein leeres PICTURE zur Initialisierung. + +draw + PROC draw (PICTURE VAR p, TEXT CONST text) + Zweck: Der angegebene Text wird gezeichnet. Der Anfang ist dabei die aktuelle + Stiftposition, die nicht verändert wird. + Fehlerfälle: + * Picture overflow + Der Text paßt nicht mehr in das PICTURE. + + PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, + height, bright) + Zweck: Der angegebene Text wird unter dem Winkel #on("italics")#angle#off("italics")# gegenüber der + Waagerechten mit der Zeichenhöhe #on("italics")#hight#off("italics")# und der Breite #on("italics")#bright#off("italics")# gezeich + net. Der Anfang ist dabei die aktuelle Stiftposition, die nicht verändert + wird. + Fehlerfälle: + * Picture overflow + Der Text paßt nicht mehr in das PICTURE. + + PROC draw (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y, z). + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC draw (PICTURE VAR p, REAL CONST x, y) + Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y). + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +draw r PROC draw r (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Zeichnen einer Linie der Länge (x, y, z) relativ zur aktuellen Position. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC draw r (PICTURE VAR p, REAL CONST x, y) + Zweck: Zeichnen einer Linie der Länge (x, y) relativ zur aktuellen Position. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +draw cm + PROC draw cm (PICTURE VAR p, REAL CONST x, y) + Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y) cm. + Dabei werden die angegebenen Projektionsparameter nicht beachtet, + sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + +draw cm r + PROC draw cm r (PICTURE VAR p, REAL CONST x, y) + Zweck: Zeichnen einer Linie der Länge (x, y) cm relativ zur aktuellen Position. + Dabei werden die angegebenen Projektionsparameter nicht beachtet, + sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + +move + PROC move (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Die aktuelle Position wird auf (x, y, z) gesetzt. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC move (PICTURE VAR p, REAL CONST x, y) + Zweck: Die aktuelle Position wird auf (x, y) gesetzt. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +move r + PROC move r (PICTURE VAR p, REAL CONST x, y, z) + Zweck: Die aktuelle Position wird um (x, y, z) erhöht. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is two dimensional + + PROC move r (PICTURE VAR p, REAL CONST x, y) + Zweck: Die aktuelle Position wird um (x, y) erhöht. + Position. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + +move cm + PROC move cm (PICTURE VAR p, REAL CONST x, y) + Zweck: Die aktuelle Position wird auf (x, y) cm gesetzt. Dabei werden die an + gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")# + Zentimeter#off("bold")# berechnet. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + +move cm r + PROC move cm r (PICTURE VAR p, REAL CONST x, y) + Zweck: Die aktuelle Position wird um (x, y) cm erhöht. Dabei werden die an + gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")# + Zentimeter#off("bold")# berechnet. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + +bar + PROC bar (PICTURE VAR p, REAL CONST width, hight, INT CONST + pattern): + Zweck: Die Prozedur zeichnet an der aktuellen Position einen Balken mit dem + Muster #on("italics")#pattern#off("italics")#: 0 = Leerer Balken + 1 = Gepunkteter Balken + 2 = Gefüllter Balken + 3 = Horizontale Linien + 4 = Vertikale Linien + 5 = Gekreuzte Linien + 6 = Diagonale Linien von Links nach Rechts + 7 = Diagonale Linien von Rechts nach Links + 8 = Gekreuzte diagonale Linien. + Die aktuelle Stiftposition wird dabei nicht verändert. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + * Unknown pattern + Das angegebene Muster liegt nicht im Bereich 0-8 + +circle + PROC circle (PICTURE VAR p, REAL CONST from, to, INT CONST + pattern) + Zweck: Die Prozedur zeichnet an der aktuellen Position ein Kreissegment vom + Winkel #on("italics")#from#off("italics")# bis #on("italics")#to#off("italics")# (im Gradmaß) mit dem Muster #on("italics")#pattern#off("italics")# (s.o.). Die + aktuelle Stiftposition wird dabei nicht verändert. + Fehlerfälle: + * Picture overflow + Zu viele Befehle in einem PICTURE + * Picture is three dimensional + * Unknown pattern + Das angegebene Muster liegt nicht im Bereich 0-8 + +dim + INT PROC dim (PICTURE CONST pic) + Zweck: Liefert die Dimension eines PICTURE. + +pen + INT PROC pen (PICTURE CONST p) + Zweck: Liefert den virtuellen Stift des PICTURE + + PROC pen (PICTURE VAR p, INT CONST pen) + Zweck: Setzen des (virtuellen) Stiftes eines PICTURE. Bei pen=0 wird das + Picture nicht gezeichnet. + Fehlerfälle: + * pen out of range + Der gewünschte Stift ist kleiner als 0 oder größer als 16. + +extrema + PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y + max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE. + Fehlerfälle: + * Picture is three dimensional + + PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y + max, z min, z max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE. + Fehlerfälle: + * Picture is two dimensional + +where + PROC where (PICTURE CONST p, REAL VAR x, y, z) + Zweck: Die Prozedur liefert die aktuelle Stiftposition (Angaben mit #on("italics")#cm#off("italics")# werden + dabei nicht berücksichtigt). + Fehlerfälle: + * Picture is two dimensional + + PROC where (PICTURE CONST p, REAL VAR x, y, z) + Zweck: Die Prozedur liefert die aktuelle Stiftposition (Angaben mit #on("italics")#cm#off("italics")# werden + dabei nicht berücksichtigt). + Fehlerfälle: + * Picture is three dimensional + +rotate: + PROC rotate (PICTURE VAR p, REAL CONST angle) + Zweck: Das PICTURE wird um den Punkt (0, 0) um den Winkel #on("italics")#angle#off("italics")# (im + Gradmaß) im mathematisch positiven Sinn gedreht. + Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")# + verändert. + + PROC rotate (PICTURE CONST p, REAL CONST phi, theta, lambda ) : + PICTURE 1-397 + Zweck: Das PICTURE wird um den Winkel #on("italics")#lambda#off("italics")# um die Drehachse #on("italics")#(phi, + theta)#off("italics")# gedreht. + Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")# + verändert. + +stretch + PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) + Zweck: Das PICTURE wird in X-Richtung um den Faktor #on("italics")#sx#off("italics")#, in Y-Rich + tung um den Faktor #on("italics")#sy#off("italics")# gestreckt (bzw. gestaucht). Dabei bewirkt der + Faktor + s > 1 eine Streckung + 0 < s < 1 eine Stauchung + s < 0 zusätzlich eine Achsenspiegelung. + Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")# + verändert. + Fehlerfälle: + * Picture is three dimensional + + PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) + Zweck: s. o. + Fehlerfälle: + * Picture is two dimensional + +translate + PROC translate (PICTURE VAR p, REAL CONST dx, dy) + Zweck: Das PICTURE wird um #on("italics")#dx#off("italics")# und #on("italics")#dy#off("italics")# verschoben. + Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")# + verändert. + Fehlerfälle: + * Picture is three dimensional + + PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) + Zweck: s. o. + Fehlerfälle: + * Picture is two dimensional + +plot PROC plot (PICTURE CONST p) + Zweck: Das Picfile wird gezeichnet. + Achtung: Es wird kein #on("italics")#begin plot#off("italics")# oder #on("italics")#end plot#off("italics")# durchgeführt. Es wird + auch kein Stift gsetzt und die Projektionsparameter bleiben + unverändert. + + +#on("underline")#Graphische PICFILE-Prozeduren#off("underline")# +plot + PROC plot (TEXT CONST name) + Zweck: Der PICFILE mit dem Namen #on("italics")#name#off("italics")# wird entsprechend der angegebenen + Darstellungsart gezeichnet. Diese Parameter (#on("italics")#perspective, orthographic, + oblique, view, window etc.#off("italics")#) müssen vorher eingestellt werden. + Fehlerfälle: + * PICFILE does not exist + Es existiert kein PICFILE mit dem Namen #on("italics")#name#off("underline")# + + PROC plot (PICFILE VAR p) + Zweck: Der PICFILE #on("italics")#p#off("italics")# wird entsprechend der angegebenen Darstellungsart ge + zeichnet. Diese Parameter müssen vorher eingestellt werden: + + #on("bold")#zweidimensional:#off("bold")# + obligat: #on("italics")#window#off("italics")# (zweidimensional) + optional: #on("italics")#view#off("italics")# (zweidimensional) + #on("italics")#viewport#off("italics")# + #on("italics")#select pen#off("italics")# + + #on("bold")#dreidimensional:#off("bold")# + obligat: #on("italics")#window#off("italics")# (dreidimensional) + optional: #on("italics")#view#off("italics")# (dreidimensional) + #on("italics")#orthographic | perspective | oblique#off("italics")# + #on("italics")#viewport#off("italics")# + #on("italics")#select pen#off("italics")# + + +select pen + PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line + type, + BOOL VAR hidden lines) Zweck: Für die + Darstellung des Bildes #on("italics")#p#off("italics")# soll dem #on("italics")#virtuellen#off("italics")# Stift #on("italics")#pen#off("italics")# ein realer Stift + zugeordnet werden, der möglichst die Farbe #on("italics")#colour#off("italics")# und die Dicke #on("italics")#thick + ness#off("italics")# hat und dabei Linien mit dem Typ #on("italics")#line type#off("italics")# zeichnet. Es wird die + beste Annäherung für das Ausgabegerät genommen. + Wenn #on("italics")#hidden lines#off("italics")# auf TRUE gesetzt wird, werden bei dreidimensionalen + Zeichnungen die verdeckten Linien mitgezeichnet, ansonsten werden sie + unterdrückt. Um sicherzustellen, das der Algorithmus auch funktioniert, + müssen die Linien allerdings von vorn nach hinten gezeichnet werden. Es + ist also nicht möglich, das Bild so zu drehen, das die hinteren Linien + zuerst gezeichnet werden. + Dabei gelten folgende Vereinbarungen: + + #on("bold")#Farbe:#off("bold")# Negative Farben werden XOR gezeichnet (dunkel wird hell und + hell wird dunkel), Farbe 0 ist der Löschstift und positive Farben + überschreiben (ersetzen) den alten Punkt mit folgenden Werten: + + 1 Standardfarbe des Endgerätes + 2 rot + 3 blau + 4 grün + 5 schwarz + 6 weiß + > 6 nicht normierte Sonderfarben + + + #on("bold")#Dicke:#off("bold")# 0 Standardstrichstärke des Endgerätes, ansonsten Strichstärke in + 1/10 mm. + + + #on("bold")#Linientyp:#off("bold")# + 0 keine sichtbare Linie + 1 durchgängige Linie + 2 gepunktete Linie + 3 kurz gestrichelte Linie + 4 lang gestrichelte Linie + 5 Strichpunktlinie + > 5 nicht normierte Linie + + #on("bold")#Verdeckte Linien:#off("bold")# + TRUE Verdeckte Linien werden mitgezeichnet + FALSE Verdeckte Linien werden unterdrückt (nur bei drei + dimensionalen PICTURE) + + Die hier aufgeführten Möglichkeiten müssen nicht an allen graphischen + Endgeräten vorhanden sein. Der geräteabhängige Graphik-Treiber wählt + jeweils die bestmögliche Annäherung. + + Fehlerfälle: + * pen out of range + #on("italics")#pen#off("italics")# muss im Bereich 1-16 sein. + +background + PROC background (PICFILE VAR p, INT CONST colour) + Zweck: Der Hintergrund wird auf die Farbe #on("italics")#colour#off("italics")# (s.o.) gesetzt wenn möglich. + + INT PROC background (PICFILE CONST p): + Zweck: Liefert die eingestellte Hintergrundfarbe. + +view + PROC view (PICFILE VAR p, REAL CONST alpha) + Zweck: Setzt den Winkel der Y-Achse zur Senkrechten auf #on("italics")#alpha#off("italics")# Grad, falls + diese nicht senkrecht zur Betrachtungsebene steht. + + PROC view (PICFILE VAR p, REAL CONST phi, theta) + Zweck: Dreidimensionale Bilder werden häufig nicht direkt von vorne dargestellt, + sondern für die Betrachtung gedreht. Mit der Prozedur #on("italics")#view#off("italics")# kann die + Betrachtungsrichtung durch die Polarwinkel #on("italics")#phi#off("italics")# und #on("italics")#theta#off("italics")# (im Gradmass) + angegeben werden. Voreingestellt ist #on("italics")#phi#off("italics")# = 0 und #on("italics")#theta#off("bold")# = 0, d.h. senk + recht von oben. + + Im Gegensatz zu #on("italics")#rotate#off("italics")# hat #on("italics")#view#off("italics")# keine Wirkung auf das eigentliche Bild + (PICFILE), sondern nur auf die gewählte Darstellung. So addieren sich + zwar aufeinanderfolgende #on("italics")#Rotationen#off("italics")#, #on("italics")#view#off("italics")# aber geht immer von der + Nullstellung aus. Auch kann das Bild durch eine #on("italics")#Rotation#off("italics")# ganz oder + teilweise aus oder in das Darstellungsfenster (#on("italics")#window#off("italics")# gedreht werden. Bei + #on("italics")#view#off("italics")# verändern sich die Koordinaten der Punkte nicht, d. h. das Fenster + wird mitgedreht. + + PROC view (PICFILE VAR p, REAL CONST x, y, z) + Zweck: Wie oben, nur werden die Winkel nicht in Polarkoordinaten angegeben, + sondern es wird die Blickrichtung als Vektor in Karthesischen Koordina + ten angegeben. (Die Länge darf ungleich 1 sein). + +viewport + PROC viewport (PICFILE VAR p, REAL CONST hormin, hormax, vertmin, + vertmax) : 1-709 + Zweck: Die Zeichenfläche auf dem Endgerät, auf dem das Bild dargestellt werden + soll, wird spezifiziert. Dabei wird sowohl die Größe als auch die relative + Lage der Zeichenfläche definiert. Der linke untere Eckpunkt der physi + kalischen Zeichenfläche des Gerätes hat die Koordinaten (0, 0). Die + definierte Zeichenfläche erstreckt sich + + #on("italics")#hormin - hormax#off("italics")# in der Horizontalen, + #on("italics")#vertmin - vertmax#off("italics")# in der Vertikalen. + + So liegt der linke untere Eckpunkt dann bei (#on("italics")#hormin, hormax#off("italics")#), der rechte + obere Eckpunkt bei (#on("italics")#hormax, vertmax#off("italics")#). + + Damit sowohl geräteunabhängige als auch maßstabgetreue Zeichnungen + möglich sind, können die Koordinaten in zwei Arten spezifiziert werden: + a) #on("bold")#Gerätekoordinaten#off("bold")# + Die Koordinaten können Werte von 0.0 bis 2.0 annehmen. Dabei + hat die kürzere Seite der physikalischen Zeichenfläche definitionsge + mäß die Länge 1.0. + b) #on("bold")#Absolute Koordinaten#off("bold")# + Die Werte werden in #on("italics")#cm#off("italics")# angegeben. Dabei müssen die Maximal + werte aber größer als 2.0 sein, da sonst Fall a) angenommen wird. + + Voreingestellt ist + + viewport (0.0, 1.0, 0.0, 1.0) + + d.h. das größtmögliche Quadrat, beginnend mit der linken unteren Ecke + der physikalischen Zeichenfläche. In vielen Fällen wird diese Einstellung + ausreichen, so daß der Anwender kein eigenes #on("italics")#viewport#off("italics")# definieren muss. + + Der Abbildungsmaßstab wird durch das Zusammenspiel von #on("italics")#viewport#off("italics")# und + #on("italics")#window#off("italics")# festgelegt (s. dort). Dabei ist insbesondere darauf zu achten, daß + winkeltreue Darstellung nur bei gleichen X- und Y-Maßstab möglich + ist. Da man oft quadratische Fenster (#on("italics")#window#off("italics")#) verwendet, wurde als + Standardeinstellung auch ein quadratisches #on("italics")#viewport#off("italics")# gewählt. + + Hinweis: Mit der Prozedur #on("italics")#check limit#off("italics")# aus dem PACKET #on("italics")#basis plot#off("italics")# kann die + Überprüfung der Grenzen des eingestellten #on("italics")#viewport#off("italics")#-Bereiches ein- + bzw. ausgeschaltet werden. Bei eingeschateter Überprüfung, werden + Linien, die den Bereich überschreiten, am Rand abgetrennt. + + +window + PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) + Zweck: Für die Darstellung eines zweidimensionalen Bildes wird das darzustel + lende Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im In- + tervall [#on("italics")#x min, x max#off("italics")#] und deren Y-Koordinaten im Bereich [#on("italics")#y min, y + max#off("italics")#] liegen, gehören zum definierten Fenster.Vektoren, die außerhalb + dieses Fensters liegen, gehen über die durch #on("italics")#viewport#off("italics")# Fläche hinaus + (s.dort). + + Der Darstellungsmaßstab ergibt sich als + + #ub# x max - x min #ue# + horizontale Seitenlänge der Zeichenfläche + + + #ub# y max - y min #ue# + vertikale Seitenlänge der Zeichenfläche + + PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, + z min, z max) + + Zweck: Für die darstellung eines dreidimensionalen Bildes wird das darzustellende + Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("italics")#x + min, x max#off("italics")#], deren Y-Koordinaten im Bereich [#on("italics")#y min, y max#off("italics")#] und + deren Z-Koordinaten im Bereich [#on("italics")#z min, z max#off("italics")#] liegen, gehören zum + definierten Fenster. Dieses dreidimensionale Fenster (#on("italics")#Quader#off("italics")#) wird ent + sprechend der eingestellten Projektionsart (orthographisch, perspektivisch + oder schiefwinklig) und den Betrachtungswinkeln (s. #on("italics")#view#off("italics")#) auf die spezi + fizierte Zeichenfläche abgebildet. + Anders als im zweidimensionalen Fall ist das Problem der Maßstaäbe + nicht mehr nur durch das Zusammenspiel von #on("italics")#window#off("italics")# und #on("italics")#viewport#off("italics")# zu + beschreiben. Hier spielen auch die Projektionsart und Darstellungswinkel + herein. + +oblique: + PROC oblique (PICFILE VAR p, REAL CONST a, b) + Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#schiefwinklig#off("underline")# als gewünschte + Projektionsart eingestellt. Dabei ist (#on("italics")#a, b#off("italics")#) der Punkt auf der X-Y- + Ebene, auf den der Einheitsvektor der Z-Richtung abgebildet werden + soll. + +orthographic + PROC orthographic (PICFILE VAR p) + Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#orthographisch#off("underline")# als gewünschte + Projektionsart eingestellt. Bei der orthographischen Projektion wird ein + dreidimensionaler Körper mit parallelen Strahlen senkrecht auf der Pro + jektionsebene dabgebildet. + +perpective + PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) + Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#perspectivisch#off("underline")# als gewünschte + Projektionsart eingestellt. Der Punkt (#on("italics")#cx, 1/cy, cz#off("underline")#) ist der Fluchtpunkt der + Projektion, d. h. alle Parallen zur Z-Achse schneiden sich in diesem + Punkt. + +extrema + PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE. + + PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z + min,z max) : 1-651 + Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE. + + +#on("underline")#Prozeduren zur Manipulation von PICFILE#off("underline")# +:= + OP := (PICFILE VAR p, DATASPACE CONST d) + Zweck: Assoziert die PICFILE Variable #on("italics")#p#off("italics")# mit dem Datenraum #on("italics")#d#off("italics")# und initialisiert + die Variable, wenn nötig. + Fehlerfälle: + * dataspace is no PICFILE + Der anzukoppelnde Datenraum hat einen unzulässigen Typ + +picture file + DATASPACE PROC picture file (TEXT CONST name) + Zweck: Assoziaten eines benannten Datenraumes mit einem PICFILE (s.o.). + +put + PROC put (FILE VAR f, PICFILE VAR p) + Zweck: Schreibt den Inhalt eines PICFILE in ein FILE. Die Informationen + werden im internen Format abgelegt. + +get + PROC get (PICFILE VAR p, FILE VAR f) + Zweck: Liest den Inhalt eines PICFILE aus einem FILE. Die Informationen + müssen mit #on("italics")#put#off("italics")# geschrieben worden sein. + Fehlerfall: + * Picfile overflow + Es können nur maximal 1024 Picture (Sätze) in einem PICFILE abgelegt + werden. + +to first pic + PROC to first pic (PICFILE VAR p) + Zweck: Positioniert auf das erste PICTURE. + +to eof + PROC to last pic (PICFILE VAR p) + Zweck: Positioniert hinter das letzte PICTURE. + +to pic + PROC to pic (PICFILE VAR p, INT CONST pos) + Zweck: Positioniert auf das PICTURE Nummer #on("italics")#pos#off("italics")#. + Fehlerfälle: + * Position underflow + Es wurde eine Position kleiner Null angegeben. * Position after + eof Es wurde versucht, hinter das Ende eines PICFILE zu positionieren + +up + PROC up (PICFILE VAR p) + Zweck: Positioniert genau ein PICTURE zurück. + Fehlerfall: + * Position underflow + Es wurde versucht, vor das erste PICTURE zu positionieren + + PROC up (PICFILE VAR p, INT CONST n) + Zweck: Positioniert genau #on("italics")#n#off("italics")# Picture zurück. + Fehlerfall: + * Position underflow + Es wurde versucht, vor das erste PICTURE zu positionieren + +down + PROC down (PICFILE VAR p) + Zweck: Positioniert genau ein PICTURE vorwärts. + Fehlerfall: + * Position after eof + Es wurde versucht, hinter das Ende eines PICFILE zu positionieren + + PROC down (PICFILE VAR p, INT CONST n) + Zweck: Positioniert genau #on("italics")#n#off("italics")# Picture vorwärts. + Fehlerfall: + * Position after eof + Es wurde versucht, hinter das Ende eines PICFILE zu positionieren + +is first picture + BOOL PROC is first picture (PICFILE CONST p) + Zweck: Liefert genau dann #on("italics")#TRUE#off("italics")#, wenn das erste PICTURE erreicht ist. + +eof + BOOL PROC eof (PICFILE CONST p) + Zweck: Liefert genau dann #on("italics")#TRUE#off("italics")#, wenn das Ende eines PICFILE erreicht ist. + +picture no + INT PROC picture no (PICFILE CONST p) + Zweck: Liefert die Nummer des aktuellen PICTURE. + +pictures + INT PROC pictures (PICFILE CONST p) + Zweck: Liefert die Anzahl PICTURE eines PICFILE. + +delete picture + PROC delete picture (PICFILE VAR p) + Zweck: Löscht das aktuelle PICTURE + +insert picture + PROC insert picture (PICFILE VAR p) + Zweck: Fügt ein PICTURE #on("underline")#vor#off("underline")# der aktuellen Position ein. + +read picture + PROC read picture (PICFILE CONST p, PICTURE VAR pic) + Zweck: Liest das aktuelle PICTURE. + +write picture + PROC write picture (PICFILE VAR p, PICTURE CONST pic) + Zweck: Schreibt das PICTURE #on("italics")#pic#off("italics")# auf der aktuellen Position. + +put picture + PROC write picture (PICFILE VAR p, PICTURE CONST pic) + Zweck: Schreibt das PICTURE #on("italics")#pic#off("italics")# hinter das letzte PICTURE des PICFILE. + Die aktuelle Position wird nicht verändert. + +#page# + #on("italics")#Wo wir sind, da klappt nichts, + aber wir können nicht überall sein !#off("italics")# + +#type ("basker14")# +#on("bold")#Kurzbeschreibung des Graphik-Editors#off("bold")# +#type ("basker12")# + +In der Kommondozeile werden folgende Informationen angezeigt: + +#on("revers")#LEN nnnnn <...Name...> DIM n PEN nn Picture nnnn +#off("revers")# + + +Folgende Kommandos stehen zur Verfügung: + + PICTURE PROC pic neu + PICFILE PROC picfile neu + PROC neu zeichnen + + OP UP n (n PICTURE up) + OP DOWN n (n PICTURE down) + OP T n (to PICTURE n) + + PROC oblique (REAL CONST a, b) + PROC orthographic + PROC perspective (REAL CONST cx, cy, cz) + PROC window (BOOL CONST dev) + PROC window (REAL CONST x min, x max, y min, y max) + PROC window (REAL CONST x min, x max, y min, y max, z min, z max) + PROC viewport (REAL CONST h min, h max, v min, v max) + PROC view (REAL CONST alpha) + PROC view (REAL CONST phi, theta) + PROC view (REAL CONST x, y, z) + + PROC pen (INT CONST n) + PROC select pen (INT CONST pen, colour, thickness, line type, BOOL CONST + hidden) + PROC background (INT CONST colour) + + PROC extrema pic + PROC extrema picfile + PROC selected pen + + PROC rotate (REAL CONST angle) + PROC rotate (REAL CONST phi, theta, lambda ) + PROC stretch (REAL CONST sx, sy) + PROC stretch (REAL CONST sx, sy, sz) + PROC translate (REAL CONST dx, dy) + PROC translate (REAL CONST dx, dy, dz) + diff --git a/system/std.graphik/1.8.7/source-disk b/system/std.graphik/1.8.7/source-disk new file mode 100644 index 0000000..8e7ff34 --- /dev/null +++ b/system/std.graphik/1.8.7/source-disk @@ -0,0 +1 @@ +grundpaket/05_std.graphik.img diff --git a/system/std.graphik/1.8.7/src/Beispiel.Kreuz b/system/std.graphik/1.8.7/src/Beispiel.Kreuz new file mode 100644 index 0000000..e29f24a --- /dev/null +++ b/system/std.graphik/1.8.7/src/Beispiel.Kreuz @@ -0,0 +1,41 @@ +initialisiere picfile; +zeichne die x achse; +zeichne die y achse; +zeichne die z achse; +stelle das achsenkreuz dar . + +initialisiere picfile: + PICFILE VAR p :: picture file ("KREUZ") . + +zeichne die x achse: + PICTURE VAR x achse := nilpicture; + move (x achse, -1.0, 0.0, 0.0); + draw (x achse, "-X", 0.0, 0.0, 0.0); + draw (x achse, 1.0, 0.0, 0.0); + draw (x achse, "+X", 0.0, 0.0, 0.0); + put picture (p, x achse) . + +zeichne die y achse: + PICTURE VAR y achse := nilpicture; + move (y achse, 0.0, -1.0, 0.0); + draw (y achse, "-Y", 0.0, 0.0, 0.0); + draw (y achse, 0.0, 1.0, 0.0); + draw (y achse, "+Y", 0.0, 0.0, 0.0); + put picture (p, y achse) . + +zeichne die z achse: + PICTURE VAR z achse := nilpicture; + move (z achse, 0.0, 0.0, -1.0); + draw (z achse, "-Z", 0.0, 0.0, 0.0); + draw (z achse, 0.0, 0.0, 1.0); + draw (z achse, "+Z", 0.0, 0.0, 0.0); + put picture (p, z achse) . + +stelle das achsenkreuz dar: + viewport (p, 0.0, 1.0, 0.0, 1.0); + window (p, -1.1, 1.1, -1.1, 1.1); + oblique (p, 0.25, 0.15); + plot (p) . + + + diff --git a/system/std.graphik/1.8.7/src/Beispiel.Sinus b/system/std.graphik/1.8.7/src/Beispiel.Sinus new file mode 100644 index 0000000..beac7cd --- /dev/null +++ b/system/std.graphik/1.8.7/src/Beispiel.Sinus @@ -0,0 +1,45 @@ +initialisiere picfile; +zeichne überschrift; +zeichne achsen; +zeichne sinuskurve; +wähle darstellung; +plot (p) . + +initialisiere picfile: + PICFILE VAR p :: picture file ("SINUS") . + +zeichne überschrift: + PICTURE VAR überschrift :: nilpicture; + move (überschrift, -pi/2.0, 1.0); + draw (überschrift, "sinus (x) [-pi, +pi]", 0.0, 1.0, 0.6); + put picture (p, überschrift) . + +zeichne achsen: + PICTURE VAR achsen :: nilpicture; + zeichne x achse; + zeichne y achse; + put picture (p, achsen) . + +zeichne x achse: + move (achsen, -pi, 0.0); + draw (achsen, pi, 0.0) . + +zeichne y achse: + move (achsen, 0.0, -1.0); + draw (achsen, 0.0, +1.0) . + +zeichne sinuskurve: + PICTURE VAR sinus :: nilpicture; + REAL VAR x :: -pi; + + move (sinus, x, sin (x)); + REP x INCR 0.1; + draw (sinus, x, sin (x)) + UNTIL x >= pi PER; + + put picture (p, sinus) . + +wähle darstellung: + window (p, -pi, pi, -1.0, 1.3); + viewport (p, 0.0, 0.0, 0.0, 0.0) . + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Picfile b/system/std.graphik/1.8.7/src/GRAPHIK.Picfile new file mode 100644 index 0000000..3accf52 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Picfile @@ -0,0 +1,738 @@ +PACKET picture DEFINES (*Autor: Heiko.Indenbirken *) + PICTURE, (*Stand: 12.03.1985 *) + :=, CAT, nilpicture, (*Änderung: 20.08.85/10:38 *) + draw, draw r, (*Änderung: 05.08.86/12:21 *) + move, move r, + mark, bar, circle, + length, dim, pen, where, + extrema, rotate, stretch, translate, + picture: + +LET draw key = 1, + move key = 2, + text key = 3, + move r key = 4, + draw r key = 5, + bar 2 key = 6, + bar 3 key = 7, + circle key = 8, + mark key = 9, + max length = 31974; + +LET overflow = "Picture overflow", + pen range = "pen out of range [0-16]", + dim 3 = "Picture is 3 dimensional", + dim 2 = "Picture is 2 dimensional", + dim init = "Picture isn't initialized", + wrong key = "wrong key code", + nil = "", + zero = ""0""; + +TYPE PICTURE = STRUCT (INT dim, pen, TEXT points); + + +INT VAR read pos; +REAL VAR x, y, z; +TEXT VAR r1 :: 8*zero, r2 :: 16*zero, r3 :: 24*zero, i1 :: 2*zero; + +OP := (PICTURE VAR l, PICTURE CONST r) : + CONCR (l) := CONCR (r) +END OP :=; + +OP CAT (PICTURE VAR l, PICTURE CONST r) : + check dim (l, r.dim); + IF length (l.points) > max length - length (r.points) + THEN errorstop (overflow) FI; + + l.points CAT r.points +END OP CAT; + +PICTURE PROC nilpicture : + PICTURE : (0, 1, nil) +END PROC nilpicture; + +PICTURE PROC nilpicture (INT CONST pen): + PICTURE : (0, pen, nil) +END PROC nilpicture; + +PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright): + write (p.points, text, angle, height, bright, text key) +END PROC draw; + +PROC draw (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, x, y, z, draw key) +END PROC draw; + +PROC draw (PICTURE VAR p, REAL CONST x, y) : + check dim (p, 2); + write (p.points, x, y, draw key) +END PROC draw; + +PROC draw r (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, x, y, z, draw r key) +END PROC draw r; + +PROC draw r (PICTURE VAR p, REAL CONST x, y) : + check dim (p, 2); + write (p.points, x, y, draw r key) +END PROC draw r; + +PROC move (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, x, y, z, move key) +END PROC move; + +PROC move (PICTURE VAR p, REAL CONST x, y) : + check dim (p, 2); + write (p.points, x, y, move key) +END PROC move; + +PROC move r (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, x, y, z, move r key) +END PROC move r; + +PROC move r (PICTURE VAR p, REAL CONST x, y) : + check dim (p, 2); + write (p.points, x, y, move r key) +END PROC move r; + +PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern): + check dim (p, 2); + write (p.points, width, height, pattern, bar 2 key) +END PROC bar; + +PROC bar (PICTURE VAR p, REAL CONST from, to, height, INT CONST pattern): + check dim (p, 2); + write (p.points, from, to, height, pattern, bar 3 key) +END PROC bar; + +PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern): + check dim (p, 2); + write (p.points, radius, from, to, pattern, circle key) +END PROC circle; + +PROC mark (PICTURE VAR p, REAL CONST size, INT CONST no): + write (p.points, size, no, mark key) +END PROC mark; + +PROC write (TEXT VAR points, REAL CONST x, y, z, INT CONST key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r3, 1, x); + replace (r3, 2, y); + replace (r3, 3, z); + points CAT r3 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, REAL CONST x, y, INT CONST key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r2, 1, x); + replace (r2, 2, y); + points CAT r2 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, REAL CONST x, y, INT CONST n, key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r2, 1, x); + replace (r2, 2, y); + points CAT r2; + replace (i1, 1, n); + points CAT i1 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, REAL CONST x, y, z, INT CONST n, key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r3, 1, x); + replace (r3, 2, y); + replace (r3, 3, z); + points CAT r3; + replace (i1, 1, n); + points CAT i1 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, TEXT CONST t, REAL CONST angle, height, bright, + INT CONST key) : + IF max length - length (points) >= length (t) + THEN points CAT code (key); + replace (i1, 1, length (t)); + points CAT i1; + points CAT t; + replace (r3, 1, angle); + replace (r3, 2, height); + replace (r3, 3, bright); + points CAT r3 + FI; +END PROC write; + +PROC write (TEXT VAR points, REAL CONST size, INT CONST no, key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r1, 1, size); + points CAT r1; + replace (i1, 1, no); + points CAT i1; + ELSE errorstop (overflow) FI +END PROC write; + +PROC check dim (PICTURE VAR p, INT CONST dim): + IF p.dim = dim + THEN + ELIF p.dim = 0 + THEN p.dim := dim + ELSE errorstop (dimension) FI . + +dimension: + IF p.dim = 2 + THEN dim 2 + ELIF p.dim = 3 + THEN dim 3 + ELSE dim init FI . + +END PROC check dim; + +INT PROC length (PICTURE CONST p): + length (p.points) +END PROC length; + +INT PROC dim (PICTURE CONST pic) : + pic.dim +END PROC dim; + +PICTURE PROC pen (PICTURE CONST p, INT CONST pen) : + IF pen < 0 OR pen > 16 + THEN errorstop (pen range) FI; + + PICTURE:(p.dim, pen, p.points) +END PROC pen; + +INT PROC pen (PICTURE CONST p) : + p.pen +END PROC pen; + +PROC where (PICTURE CONST p, REAL VAR x, y) : + IF p.dim = 0 + THEN x := 0.0; y := 0.0 + ELIF p.dim = 3 + THEN errorstop (dim 3) + ELSE x := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1; + y := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1 + FI +END PROC where; + +PROC where (PICTURE CONST p, REAL VAR x, y, z) : + IF p.dim = 0 + THEN x := 0.0; y := 0.0; z := 0.0 + ELIF p.dim = 2 + THEN errorstop (dim 2) + ELSE x := subtext (p.points, length (p.points)-23, length (p.points)-16) RSUB 1; + y := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1; + z := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1; + FI +END PROC where; + + +PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, z min, z max) : + x min := max real; x max :=-max real; + y min := max real; y max :=-max real; + z min := max real; z max :=-max real; + read pos := 0; + INT CONST pic length := length (p.points); + WHILE read pos < pic length + REP check position PER . + +check position : + read pos INCR 1; + SELECT code (p.points SUB read pos) OF + CASE draw key : calc extrema + CASE move key : calc extrema + CASE move r key : calc rel extrema + CASE draw r key : calc rel extrema + CASE text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) END SELECT . + +calc extrema : + x := next real; y := next real; z := next real; + x min := min (x min, x); x max := max (x max, x); + y min := min (y min, y); y max := max (y max, y); + z min := min (z min, z); z max := max (z max, z) . + +calc rel extrema : + x INCR next real; y INCR next real; z INCR next real; + x min := min (x min, x); x max := max (x max, x); + y min := min (y min, y); y max := max (y max, y); + z min := min (z min, z); z max := max (z max, z) . + +next real : + read pos INCR 8; + subtext (p.points, read pos-7, read pos) RSUB 1 . + +next int : + read pos INCR 2; + subtext (p.points, read pos-1, read pos) ISUB 1 . + +END PROC extrema; + +PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max): + x min := max real; x max :=-max real; + y min := max real; y max :=-max real; + read pos := 0; + INT CONST pic length := length (p.points); + WHILE read pos < pic length + REP check position PER . + +check position : + read pos INCR 1; + SELECT code (p.points SUB read pos) OF + CASE draw key : calc extrema + CASE move key : calc extrema + CASE move r key : calc rel extrema + CASE draw r key : calc rel extrema + CASE text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) END SELECT . + +calc extrema : + x := next real; y := next real; + x min := min (x min, x); x max := max (x max, x); + y min := min (y min, y); y max := max (y max, y) . + +calc rel extrema : + x INCR next real; y INCR next real; + x min := min (x min, x); x max := max (x max, x); + y min := min (y min, y); y max := max (y max, y) . + +next real : + read pos INCR 8; + subtext (p.points, read pos-7, read pos) RSUB 1 . + +next int : + read pos INCR 2; + subtext (p.points, read pos-1, read pos) ISUB 1 . + +END PROC extrema; + +PROC rotate (PICTURE VAR p, REAL CONST angle) : + REAL CONST s :: sind( angle ), c := cosd( angle ); + transform (p, ROW 4 ROW 3 REAL : + (ROW 3 REAL : ( 1.0, 0.0, 0.0 ), + ROW 3 REAL : ( 0.0, c , s ), + ROW 3 REAL : ( 0.0, -s , c ), + ROW 3 REAL : ( 0.0, 0.0, 0.0 ))) +END PROC rotate; + +PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) : + REAL CONST s :: sind ( theta ), c :: cosd ( theta ), + s p :: sind ( phi ), s l :: sind ( lambda ), + ga :: cosd ( phi ), c l :: cosd ( lambda ), + be :: s p * s l, al :: s p * c l, c1 :: 1.0 - c; + transform (p, ROW 4 ROW 3 REAL : + (ROW 3 REAL : ( al*al*c1 + c , be*al*c1+ga*s, ga*al*c1-be*s ), + ROW 3 REAL : ( al*be*c1-ga*s, be*be*c1 + c , ga*be*c1+al*s ), + ROW 3 REAL : ( al*ga*c1+be*s, be*ga*c1-al*s, ga*ga*c1 + c ), + ROW 3 REAL : ( 0.0 , 0.0 , 0.0 ))) +END PROC rotate; + +PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) : + stretch (pic, sx, sy, 1.0) +END PROC stretch; + +PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) : + transform (p, ROW 4 ROW 3 REAL : + (ROW 3 REAL : ( sx, 0.0, 0.0), + ROW 3 REAL : (0.0, sy, 0.0), + ROW 3 REAL : (0.0, 0.0, sz), + ROW 3 REAL : (0.0, 0.0, 0.0))) +END PROC stretch; + +PROC translate (PICTURE VAR p, REAL CONST dx, dy) : + translate (p, dx, dy, 0.0) +END PROC translate; + +PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) : + transform (p, ROW 4 ROW 3 REAL : + (ROW 3 REAL : (1.0, 0.0, 0.0), + ROW 3 REAL : (0.0, 1.0, 0.0), + ROW 3 REAL : (0.0, 0.0, 1.0), + ROW 3 REAL : ( dx, dy, dz))) +END PROC translate; + +PROC transform (PICTURE VAR p, ROW 4 ROW 3 REAL CONST a) : + INT CONST pic length := length (p.points); + INT VAR begin pos; + read pos := 0; + x := 0.0; y := 0.0; z := 0.0; + IF p.dim = 2 + THEN transform 2 dim pic + ELSE transform 3 dim pic FI . + +transform 2 dim pic: + WHILE read pos < pic length + REP transform 2 dim position PER . + +transform 2 dim position: + read pos INCR 1; + SELECT code (p.points SUB read pos) OF + CASE draw key : transform 2 dim point + CASE move key : transform 2 dim point + CASE move r key : transform 2 dim point + CASE draw r key : transform 2 dim point + CASE text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) END SELECT . + +transform 2 dim point: + begin pos := read pos+1; + x := next real; y := next real; + transform (a, x, y, z); + replace (r2, 1, x); + replace (r2, 2, y); + replace (p.points, begin pos, r2) . + +transform 3 dim pic: + WHILE read pos < pic length + REP transform 3 dim position PER . + +transform 3 dim position : + read pos INCR 1; + SELECT code (p.points SUB read pos) OF + CASE draw key : transform 3 dim point + CASE move key : transform 3 dim point + CASE move r key : transform 3 dim point + CASE draw r key : transform 3 dim point + CASE text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) END SELECT . + +transform 3 dim point: + begin pos := read pos+1; + x := next real; y := next real; z := next real; + transform (a, x, y, z); + replace (r3, 1, x); + replace (r3, 2, y); + replace (r3, 3, z); + replace (p.points, begin pos, r3) . + +next real : + read pos INCR 8; + subtext (p.points, read pos-7, read pos) RSUB 1 . + +next int : + read pos INCR 2; + subtext (p.points, read pos-1, read pos) ISUB 1 . + +END PROC transform; + +PROC transform (ROW 4 ROW 3 REAL CONST a, REAL VAR x, y, z) : + REAL CONST ox :: x, oy :: y, oz :: z; + x := ox*a(1)(1) + oy*a(2)(1) + oz*a(3)(1) + a(4)(1); + y := ox*a(1)(2) + oy*a(2)(2) + oz*a(3)(2) + a(4)(2); + z := ox*a(1)(3) + oy*a(2)(3) + oz*a(3)(3) + a(4)(3) +END PROC transform; + +PROC picture (PICTURE CONST pic, TEXT VAR points, INT VAR dim, pen): + dim := pic.dim; + pen := pic.pen; + points := pic.points; +END PROC picture; + +END PACKET picture; + +PACKET picfile DEFINES (*Autor: Heiko Indenbirken *) + (*Stand: 23.02.1985 *) + PICFILE, :=, picture file, (*Änderung: 13.10.89/23:11 *) + select pen, selected pen, background, + set values, get values, + view, viewport, window, + oblique, orthographic, perspective, + extrema, + + to pic, up, down, + eof, picture no, pictures, + delete picture, insert picture, + read picture, write picture, + get picture, put picture: + + +LET no picfile = "dataspace is no PICFILE", + pen range = "pen out of range", + pos under = "Position underflow", + pos over = "Position overflow", + pic over = "PICFILE overflow"; + +LET max pics = 1024, + pic dataspace = 1103; + + +TYPE PICFILE = BOUND STRUCT (INT size, pos, background, + ROW 16 ROW 3 INT pens, + ROW 3 ROW 2 REAL sizes, + ROW 2 ROW 2 REAL limits, + ROW 4 REAL angles, + ROW 2 REAL obliques, + ROW 3 REAL perspectives + ROW max pics PICTURE pic); + +INT VAR i; + +OP := (PICFILE VAR l, PICFILE CONST r): + EXTERNAL 260 +END OP :=; + +OP := (PICFILE VAR p, DATASPACE CONST d) : + IF type (d) = pic dataspace + THEN CONCR (p) := d + ELIF type (d) < 0 + THEN type (d, pic dataspace) ; + CONCR (p) := d ; + init picfile dataspace ; + ELSE errorstop (no picfile) FI . + +init picfile dataspace : + r.size := 0; + r.pos := 1; + r.background := 0; + r.sizes := ROW 3 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0), + ROW 2 REAL : (0.0, 1.0), + ROW 2 REAL : (0.0, 1.0)); + r.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, 0.0), + ROW 2 REAL : (0.0, 0.0)); + r.angles := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0); + r.obliques := ROW 2 REAL : (0.0, 0.0); + r.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0); + FOR i FROM 1 UPTO 16 + REP r.pens [i] := ROW 3 INT : (1, 0, 1) PER . + +r : CONCR (CONCR (p)). +END OP :=; + +DATASPACE PROC picture file (TEXT CONST name) : + IF exists (name) + THEN old (name) + ELSE new (name) FI +END PROC picture file; + +PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type): + IF pen < 1 OR pen > 16 + THEN errorstop (pen range) FI; + p.pens [pen] := ROW 3 INT : (colour, thickness, line type) +END PROC select pen; + +PROC selected pen (PICFILE CONST p, INT CONST pen, + INT VAR colour, thickness, line type): + IF pen < 1 OR pen > 16 + THEN errorstop (pen range) FI; + colour := p.pens [pen][1]; + thickness := p.pens [pen][2]; + line type := p.pens [pen][3]; +END PROC selected pen; + +INT PROC background (PICFILE CONST p): + p.background +END PROC background; + +PROC background (PICFILE VAR p, INT CONST colour): + p.background := colour +END PROC background; + +PROC get values (PICFILE CONST p, + ROW 3 ROW 2 REAL VAR size, + ROW 2 ROW 2 REAL VAR limits, + ROW 4 REAL VAR angles, + ROW 2 REAL VAR oblique, + ROW 3 REAL VAR perspective) : + size := p.sizes; + limits := p.limits; + angles := p.angles; + oblique := p.obliques; + perspective := p.perspectives; + +END PROC get values; + +PROC set values (PICFILE VAR p, + ROW 3 ROW 2 REAL CONST size, + ROW 2 ROW 2 REAL CONST limits, + ROW 4 REAL CONST angles, + ROW 2 REAL CONST oblique, + ROW 3 REAL CONST perspective) : + p.sizes := size; + p.limits := limits; + p.angles := angles; + p.obliques := oblique; + p.perspectives := perspective; + +END PROC set values; + +PROC view (PICFILE VAR p, REAL CONST alpha): + p.angles [1] := alpha +END PROC view; + +PROC view (PICFILE VAR p, REAL CONST phi, theta): + p.angles [2] := sind (theta) * cosd (phi); + p.angles [3] := sind (theta) * sind (phi); + p.angles [4] := cosd (theta); +END PROC view; + +PROC view (PICFILE VAR p, REAL CONST x, y, z): + p.angles [2] := x; + p.angles [3] := y; + p.angles [4] := z +END PROC view; + +PROC viewport (PICFILE VAR p,REAL CONST hor min,hor max,vert min,vert max) : + p.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (hor min, hor max), + ROW 2 REAL : (vert min, vert max)) +END PROC viewport; + +PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) : + window (p, x min, x max, y min, y max, 0.0, 1.0) +END PROC window; + +PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, z min, z max) : + p.sizes := ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max), + ROW 2 REAL : (y min, y max), + ROW 2 REAL : (z min, z max)) +END PROC window; + +PROC oblique (PICFILE VAR p, REAL CONST a, b) : + p.obliques := ROW 2 REAL : (a, b); + p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0) +END PROC oblique; + +PROC orthographic (PICFILE VAR p) : + p.obliques := ROW 2 REAL : (0.0, 0.0); + p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0) +END PROC orthographic; + +PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) : + p.obliques := ROW 2 REAL : (0.0, 0.0); + p.perspectives := ROW 3 REAL : (cx, cy, cz) +END PROC perspective; + +PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) : + REAL VAR dummy; + extrema (p, x min, x max, y min, y max, dummy, dummy) +END PROC extrema; + +PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) : + REAL VAR new x min, new x max, new y min, new y max, new z min, new z max; + x min := max real; x max := - max real; + y min := max real; y max := - max real; + z min := max real; z max := - max real; + FOR i FROM 1 UPTO p.size + REP IF dim (p.pic [i]) = 2 + THEN extrema (p.pic [i], new x min, new x max, new y min, new y max) + ELSE extrema (p.pic [i], new x min, new x max, new y min, new y max, + new z min, new z max) + FI; + x min := min (x min, new x min); x max := max (x max, new x max); + y min := min (y min, new y min); y max := max (y max, new y max); + z min := min (z min, new z min); z max := max (z max, new z max); + PER +END PROC extrema; + +PROC to pic (PICFILE VAR p, INT CONST n): + IF n < 1 + THEN errorstop (pos under) + ELIF n <= p.size+1 AND n <= max pics + THEN p.pos := n + ELSE errorstop (pos over) FI +END PROC to pic; + +PROC up (PICFILE VAR p): + to pic (p, p.pos-1) +END PROC up; + +PROC up (PICFILE VAR p, INT CONST n): + to pic (p, p.pos-n) +END PROC up; + +PROC down (PICFILE VAR p): + to pic (p, p.pos+1) +END PROC down; + +PROC down (PICFILE VAR p, INT CONST n): + to pic (p, p.pos+n) +END PROC down; + +BOOL PROC eof (PICFILE CONST p): + p.pos >= p.size +END PROC eof; + +INT PROC picture no (PICFILE CONST p): + p.pos +END PROC picture no; + +INT PROC pictures (PICFILE CONST p): + p.size +END PROC pictures; + +PROC delete picture (PICFILE VAR p) : + INT VAR i; + FOR i FROM p.pos+1 UPTO p.size + REP p.pic [i-1] := p.pic [i] PER; + + p.pic [p.size] := nilpicture; + IF p.size > 1 + THEN p.size DECR 1 FI +END PROC delete picture; + +PROC insert picture (PICFILE VAR p) : + INT VAR i; + IF p.size >= max pics + THEN errorstop (pic over) + ELSE p.size INCR 1; + FOR i FROM p.size DOWNTO p.pos+1 + REP p.pic [i] := p.pic [i-1] PER; + + p.pic [p.pos] := nilpicture; + FI +END PROC insert picture; + +PROC read picture (PICFILE VAR p, PICTURE VAR pic) : + pic := p.pic (p.pos) . +END PROC read picture; + +PROC write picture (PICFILE VAR p, PICTURE CONST pic) : + p.pic (p.pos) := pic . +END PROC write picture; + +PROC get picture (PICFILE VAR p, PICTURE VAR pic) : + IF p.pos > p.size + THEN errorstop (pos over) + ELSE pic := p.pic [p.pos]; + p.pos INCR 1; + FI +END PROC get picture; + +PROC put picture (PICFILE VAR p, PICTURE CONST pic) : + IF p.pos > max pics + THEN errorstop (pic over) + ELSE p.pic [p.pos] := pic; + + IF p.pos > p.size + THEN p.size INCR 1 FI; + p.pos INCR 1 + FI +END PROC put picture; + +END PACKET picfile + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Plot b/system/std.graphik/1.8.7/src/GRAPHIK.Plot new file mode 100644 index 0000000..5087abb --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Plot @@ -0,0 +1,285 @@ +PACKET basis plot DEFINES (* Autor: Heiko Indenbirken*) + (* Stand: 12.04.85 *) + (*Änderung: 06.08.86/10:03 *) +(* ****************** Hardwareunabhängiger Teil ********************* *) +(* *) +(* *) +(* Im Harwareunabhängigen Paket 'basis plot' werden folgende *) +(* Prozeduren definiert: *) +(* Procedure : Bedeutung *) +(* ---------------------------------------------------------------- *) +(* move : Positioniert auf (x, y,[z]) in Weltkoordinaten*) +(* draw : Zeichnet eine Linie bis zum Punkt (x, y, [z]).*) +(* move r : Positioniert (x, y, [z]) weiter *) +(* draw r : Zeichnet (x, y, [z]) weiter *) +(* *) +(* draw : Zeichnet einen Text *) +(* *) +(* mark : Marker mit (no, size) *) +(* bar : Balken mit (width, height, pattern) *) +(* bar : Balken mit (from, to, width, pattern) *) +(* circle : Kreis(segment) mit (radius, from, to, pattern)*) +(* *) +(* where : Gibt die aktuelle Stiftposition (x, y, [z]) *) +(* *) +(*************************************************************************) + + move, draw, + move r, draw r, + mark, bar, circle, + where: + +LET POS = STRUCT (REAL x, y, z); + +POS VAR pos :: POS : (0.0, 0.0, 0.0); +INT VAR h :: 0, v :: 0; + +PROC move (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + move (h, v); + pos := POS : (x, y, 0.0) +END PROC move; + +PROC move (REAL CONST x, y, z) : + transform (x, y, z, h, v); + move (h, v); + pos := POS : (x, y, z) +END PROC move; + +PROC draw (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + draw (h, v); + pos := POS : (x, y, 0.0) +END PROC draw; + +PROC draw (REAL CONST x, y, z) : + transform (x, y, z, h, v); + draw (h, v); + pos := POS : (x, y, z) +END PROC draw; + +PROC move r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC move r; + +PROC move r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC move r; + +PROC draw r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC draw r; + +PROC draw r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC draw r; + +PROC where (REAL VAR x, y) : + x := pos.x; y := pos.y +END PROC where; + +PROC where (REAL VAR x, y, z) : + x := pos.x; y := pos.y; z := pos.z +END PROC where; + +PROC draw (TEXT CONST msg, REAL CONST angle, height percent, width percent): + draw (msg, angle, height (height percent), width (width percent)) . +END PROC draw; + +PROC mark (REAL CONST size, INT CONST no): + marker (h, v, no, diagonal (size)) +END PROC mark; + +PROC bar (REAL CONST width, height, INT CONST pattern): + INT VAR diff, up, zero x, zero y; + transform (0.0, 0.0, 0.0, zero x, zero y); + transform (width*0.5, height, 0.0, diff, up); + bar (h-(diff-zero x), v, h+(diff-zero x), v+(up-zero y), pattern); + move (h, v) + +END PROC bar; + +PROC bar (REAL CONST from, to, height, INT CONST pattern): + INT VAR from h, to h, up; + transform (from, height, 0.0, from h, up); + transform (to, height, 0.0, to h, up); + bar (from h, v, to h, up, pattern); + move (h, v) + +END PROC bar; + +PROC circle (REAL CONST rad, from, to, INT CONST pattern): + circle (h, v, diagonal (rad), from, to, pattern) . + +END PROC circle; + +ENDPACKET basis plot; + +PACKET plot DEFINES plot: (*Autor: Heiko Indenbirken *) + (*Stand: 13.10.89/22:31 *) + +LET draw key = 1, + move key = 2, + text key = 3, + move r key = 4, + draw r key = 5, + bar 2 key = 6, + bar 3 key = 7, + circle key = 8, + mark key = 9; + +LET dim error = "PICTURE not initialized", + key error = "wrong key code: "; + +TEXT VAR points; +INT VAR pic length, pic pen, pic dim, read pos; +PICTURE VAR pic; + +PROC plot (PICTURE CONST pic): + init plot; + IF pic dim = 2 + THEN plot two dim pic + ELIF pic dim = 3 + THEN plot three dim pic + ELIF NOT (pic dim = 0 AND pic length = 0) + THEN errorstop (dim error) FI; + points := "" . + +init plot: + picture (pic, points, pic dim, pic pen); + pic length := length (points); + read pos := 0 . + +plot two dim pic: + WHILE read pos < pic length + REP plot two dim position PER . + +plot two dim position : + read pos INCR 1; + SELECT key OF + CASE draw key: draw (next real, next real) + CASE move key: move (next real, next real) + CASE move r key: move r (next real, next real) + CASE draw r key: draw r (next real, next real) + CASE text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) END SELECT . + +plot three dim pic: + WHILE read pos < pic length + REP plot three dim position PER . + +plot three dim position : + read pos INCR 1; + SELECT key OF + CASE draw key: draw (next real, next real, next real) + CASE move key: move (next real, next real, next real) + CASE move r key: move r (next real, next real, next real) + CASE draw r key: draw r (next real, next real, next real) + CASE text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) END SELECT . + +key: + code (points SUB read pos) . + +END PROC plot; + +REAL PROC next real: + read pos INCR 8; + subtext (points, read pos-7, read pos) RSUB 1 . +END PROC next real; + +INT PROC next int: + read pos INCR 2; + subtext (points, read pos-1, read pos) ISUB 1 . +END PROC next int; + +TEXT PROC next text: + INT CONST text length :: next int; + read pos INCR text length; + subtext (points, read pos-text length+1, read pos) . +END PROC next text; + +PROC plot (TEXT CONST name) : + PICFILE VAR p :: old (name); + plot (p); +END PROC plot; + +PROC plot (PICFILE VAR p) : + set projektion; + disable stop; + begin plot; + clear screen; + plot pictures (p); + errorcheck; + end plot . + +set projektion: + ROW 3 ROW 2 REAL VAR size; + ROW 2 ROW 2 REAL VAR limit; + ROW 4 REAL VAR angles; + ROW 2 REAL VAR oblique; + ROW 3 REAL VAR perspective; + + get values (p, size, limit, angles, oblique, perspective); + set values (size, limit, angles, oblique, perspective) . + +clear screen: + INT VAR x0, y0, x1, y1, h max, v max; + REAL VAR x cm, y cm; + + IF background (p) > -1 + THEN clear + ELSE drawing area (x cm, y cm, h max, v max); + new values (x cm, y cm, h max, v max, x0, x1 , y0, y1); + set range (max (0, x0), max (0, y0), min (h max, x1), min (v max, y1)) + FI . + +errorcheck: + IF is error + THEN line; + put line ("Erorr at PICTURE No " + text (picture no (p))); + FI . + +END PROC plot; + +PROC plot pictures (PICFILE VAR p): + INT VAR back :: abs (background (p)), no; + enable stop; + FOR no FROM 1 UPTO pictures (p) + REP to pic (p, no); + read picture (p, pic); + + IF this picture is ok + THEN set pen of pic; + plot (pic) + FI + PER . + +this picture is ok: + pen (pic) <> 0 AND length (pic) > 0 . + +set pen of pic: + INT VAR colour, thick, type; + selected pen (p, pen (pic), colour, thick, type); + set pen (back, colour, thick, type) . + +END PROC plot pictures; + +END PACKET plot + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Plotter b/system/std.graphik/1.8.7/src/GRAPHIK.Plotter new file mode 100644 index 0000000..a55e515 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Plotter @@ -0,0 +1,247 @@ +PACKET plotter DEFINES plotter: (*Autor: Heiko Indenbirken *) + (*Stand: 13.10.89/22:31 *) + (*Änderung: 08.09.86/15:47 *) + +LET POS = STRUCT (REAL x, y, z); + +POS VAR pos :: POS : (0.0, 0.0, 0.0); +INT VAR h :: 0, v :: 0; + +PROC move (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + move (h, v); + pos := POS : (x, y, 0.0) +END PROC move; + +PROC move (REAL CONST x, y, z) : + transform (x, y, z, h, v); + move (h, v); + pos := POS : (x, y, z) +END PROC move; + +PROC draw (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + draw (h, v); + pos := POS : (x, y, 0.0) +END PROC draw; + +PROC draw (REAL CONST x, y, z) : + transform (x, y, z, h, v); + draw (h, v); + pos := POS : (x, y, z) +END PROC draw; + +PROC move r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC move r; + +PROC move r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC move r; + +PROC draw r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC draw r; + +PROC draw r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC draw r; + +PROC draw (TEXT CONST msg, REAL CONST angle, height percent, width percent): + draw (msg, angle, height (height percent), width (width percent)) . +END PROC draw; + +PROC mark (REAL CONST size, INT CONST no): + marker (h, v, no, diagonal (size)) +END PROC mark; + +PROC bar (REAL CONST width, height, INT CONST pattern): + INT VAR diff, up, zero x, zero y; + transform (0.0, 0.0, 0.0, zero x, zero y); + transform (width*0.5, height, 0.0, diff, up); + bar (h-(diff-zero x), v, h+(diff-zero x), v+(up-zero y), pattern); + move (h, v) + +END PROC bar; + +PROC bar (REAL CONST from, to, height, INT CONST pattern): + INT VAR from h, to h, up; + transform (from, height, 0.0, from h, up); + transform (to, height, 0.0, to h, up); + bar (from h, v, to h, up, pattern); + move (h, v) + +END PROC bar; + +PROC circle (REAL CONST rad, from, to, INT CONST pattern): + circle (h, v, diagonal (rad), from, to, pattern) . + +END PROC circle; + + +(* *) +LET draw key = 1, + move key = 2, + text key = 3, + move r key = 4, + draw r key = 5, + bar 2 key = 6, + bar 3 key = 7, + circle key = 8, + mark key = 9; + +LET dim error = "PICTURE not initialized", + key error = "wrong key code: "; + +TEXT VAR points; +INT VAR pic length, pic pen, pic dim, read pos; +PICTURE VAR pic; + +PROC plot (PICTURE CONST pic): + init plot; + IF pic dim = 2 + THEN plot two dim pic + ELIF pic dim = 3 + THEN plot three dim pic + ELIF NOT (pic dim = 0 AND pic length = 0) + THEN errorstop (dim error) FI; + points := "" . + +init plot: + picture (pic, points, pic dim, pic pen); + pic length := length (points); + read pos := 0 . + +plot two dim pic: + WHILE read pos < pic length + REP plot two dim position PER . + +plot two dim position : + read pos INCR 1; + SELECT key OF + CASE draw key: draw (next real, next real) + CASE move key: move (next real, next real) + CASE move r key: move r (next real, next real) + CASE draw r key: draw r (next real, next real) + CASE text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) END SELECT . + +plot three dim pic: + WHILE read pos < pic length + REP plot three dim position PER . + +plot three dim position : + read pos INCR 1; + SELECT key OF + CASE draw key: draw (next real, next real, next real) + CASE move key: move (next real, next real, next real) + CASE move r key: move r (next real, next real, next real) + CASE draw r key: draw r (next real, next real, next real) + CASE text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) END SELECT . + +key: + code (points SUB read pos) . + +END PROC plot; + +REAL PROC next real: + read pos INCR 8; + subtext (points, read pos-7, read pos) RSUB 1 . +END PROC next real; + +INT PROC next int: + read pos INCR 2; + subtext (points, read pos-1, read pos) ISUB 1 . +END PROC next int; + +TEXT PROC next text: + INT CONST text length :: next int; + read pos INCR text length; + subtext (points, read pos-text length+1, read pos) . +END PROC next text; + +PROC plotter (TEXT CONST name) : + PICFILE VAR p :: old (name); + plotter (p); +END PROC plotter; + +PROC plotter (PICFILE VAR p) : + set projektion; + disable stop; + begin plot; + clear screen; + plot pictures (p); + errorcheck; + end plot . + +set projektion: + ROW 3 ROW 2 REAL VAR size; + ROW 2 ROW 2 REAL VAR limit; + ROW 4 REAL VAR angles; + ROW 2 REAL VAR oblique; + ROW 3 REAL VAR perspective; + get values (p, size, limit, angles, oblique, perspective); + set values (size, limit, angles, oblique, perspective) . + +clear screen: + INT VAR x0, y0, x1, y1, h max, v max; + REAL VAR x cm, y cm; + + IF background (p) > -1 + THEN clear + ELSE drawing area (x cm, y cm, h max, v max); + new values (x cm, y cm, h max, v max, x0, x1 , y0, y1); + set range (max (0, x0), max (0, y0), min (h max, x1), min (v max, y1)) + FI . + +errorcheck: + IF is error + THEN line; + put line ("Erorr at PICTURE No " + text (picture no (p))); + FI . + +END PROC plotter; + +PROC plot pictures (PICFILE VAR p): + INT VAR back :: abs (background (p)), no; + enable stop; + FOR no FROM 1 UPTO pictures (p) + REP to pic (p, no); + read picture (p, pic); + + IF this picture is ok + THEN set pen of pic; + plot (pic) + FI + PER . + +this picture is ok: + pen (pic) <> 0 AND length (pic) > 0 . + +set pen of pic: + INT VAR colour, thick, type; + selected pen (p, pen (pic), colour, thick, type); + set pen (back, colour, thick, type) . + +END PROC plot pictures; + +END PACKET plotter + + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Server b/system/std.graphik/1.8.7/src/GRAPHIK.Server new file mode 100644 index 0000000..dfe5f62 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Server @@ -0,0 +1,97 @@ +PACKET multi user plotter: (* Autor : Rudolf Ruland *) + (* Stand : 24.03.86 *) + (*Änderung: 09.09.86/15:32 *) + +INT VAR c; +put ("gib Plotterkanal : "); get (c); + + server channel (c); + station only (FALSE) ; + spool duty ("Ausgabe mit dem Plotter"); + spool control task (myself); + +LET ack = 0 , + + fetch code = 11 , + param fetch code = 21 , + picfile type = 1103 ; + +INT VAR reply, old heap size, sender station; +TEXT VAR picfile name, userid, password, sendername; +PICFILE VAR picfile ; + +DATASPACE VAR ds, picfile ds; + +BOUND STRUCT (TEXT picfile name, userid, password, sendername, INT station) VAR msg; +BOUND TEXT VAR error msg ; + +spool manager (PROC plotter); + +PROC plotter : + + disable stop ; + command dialogue (FALSE); + ds := nilspace; picfile ds := nilspace; + continue (server channel) ; + check error ("Kanal belegt"); + + old heap size := heap size ; + REP + execute plot ; + + IF is error + THEN put error; + clear error; + FI ; + + IF heap size > old heap size + 4 + THEN collect heap garbage ; + old heap size := heap size + FI + PER + +ENDPROC plotter ; + + +PROC execute plot : + + enable stop ; + forget (picfile ds) ; picfile ds := nilspace ; + call (father, fetch code, picfile ds, reply) ; + IF reply = ack CAND type (picfile ds) = picfile type + THEN get picfile params; + plot picfile + FI ; + +. get picfile params : + forget (ds); ds := nilspace; + call (father, param fetch code, ds, reply); + IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE msg := ds; + picfile name := msg. picfile name; + userid := msg. userid; + password := msg. password; + sendername := msg. sender name; + sender station := msg. station; + FI; + +. plot picfile : + picfile := picfile ds; + plotter (picfile) . + +ENDPROC execute plot ; + + +PROC check error (TEXT CONST message) : + IF is error + THEN clear error; + rename myself (message); + IF is error THEN clear error; end (myself) FI; + pause (18000); + end (myself); + FI; +END PROC check error; + +ENDPACKET multi user plotter ; + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Transform b/system/std.graphik/1.8.7/src/GRAPHIK.Transform new file mode 100644 index 0000000..54690cc --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Transform @@ -0,0 +1,366 @@ +PACKET transformation DEFINES transform, (* Autor: Heiko Indenbirken*) + diagonal, (* Stand: 12.04.85 *) + height, width, (*Änderung: 05.08.86/13:14 *) + set values, (*Änderung: 17.09.86/19:57 *) + get values, + new values, + projektion, + window, + viewport, + view, + oblique, + orthographic, + perspective: +(* ******************* Hardwareunabhängiger Teil ********************* *) +(* transform: Die Prozedur projeziert einen 3-dimensionalen Vektor *) +(* ---------- (x, y, z) auf einen 2-dimensionalen (h, v) *) +(* diagonal Die Prozedur berechnet die Pixel als Prozent der *) +(* ---------- Diagonalen der Zeichenfläche *) +(* height Die Prozedur berechnet die Pixel als Prozent der *) +(* ---------- Höhe der Zeichenfläche *) +(* width Die Prozedur berechnet die Pixel als Prozent der *) +(* ---------- Breite der Zeichenfläche *) +(* *) +(* set values: Mit dieser Prozedur werden die Projektionsparameter *) +(* ----------- gesetzt. *) +(* size: Weltkoordinatenbereich *) +(* ((xmin,xmax),(ymin,ymax),(zmin,zmax)) *) +(* limits: Zeichenfläche *) +(* ((h min, h max), (v min, v max)) *) +(* Bei Werten < 2.0 werden die Werte als *) +(* Prozente interpretiert, ansonsten als *) +(* cm-Grössen. *) +(* get values: Übergibt die aktuellen Werte *) +(* ----------- *) +(* new values: Berechnet die neue Projektionsmatrix *) +(* ----------- *) +(*=======================================================================*) + +BOOL VAR perspective projektion :: FALSE; +INT VAR hor pixel, vert pixel, i; +REAL VAR hor cm, vert cm, + h min limit, h max limit, v min limit, v max limit; +ROW 5 ROW 5 REAL VAR p; +ROW 3 ROW 2 REAL VAR size; +ROW 2 ROW 2 REAL VAR limits; +ROW 4 REAL VAR angles; +ROW 2 REAL VAR obliques; +ROW 3 REAL VAR perspectives; + +(* Initialisieren der Projektionsmatrizen *) +INT VAR d; +window (0.0, 1.0, 0.0, 1.0, 0.0, 1.0); +viewport (0.0, 0.0, 0.0, 0.0); +view (0.0, 0.0, 1.0); +view (0.0); +orthographic; +new values (27.46, 19.21, 274, 192, d, d, d, d); + +PROC projektion (ROW 5 ROW 5 REAL VAR matrix): + matrix := p +END PROC projektion; + +PROC oblique (REAL CONST a, b) : + set values (size, limits, angles, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0)) +END PROC oblique; + +PROC orthographic : + set values (size, limits, angles, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (0.0, 0.0, 0.0)) +END PROC orthographic; + +PROC perspective (REAL CONST cx, cy, cz) : + set values (size, limits, angles, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy, cz)) +END PROC perspective; + +PROC window (REAL CONST x min, x max, y min, y max) : + window (x min, x max, y min, y max, 0.0, 1.0) +END PROC window; + +PROC window (REAL CONST x min, x max, y min, y max, z min, z max) : + set values (ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max), + ROW 2 REAL : (y min, y max), + ROW 2 REAL : (z min, z max)), + limits, angles, obliques, perspectives) +END PROC window; + +PROC viewport (REAL CONST h min, h max, v min, v max) : + set values (size, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max), + ROW 2 REAL : (v min, v max)), + angles, obliques, perspectives) +END PROC view port; + +PROC view (REAL CONST alpha) : + set values (size, limits, ROW 4 REAL : (alpha, angles(2), angles (3), angles (4)), + obliques, perspectives) +END PROC view; + +PROC view (REAL CONST phi, theta): + set values (size, limits, ROW 4 REAL : (angles (1), sind (theta) * cosd (phi), + sind (theta) * sind (phi), cosd (theta)), + obliques, perspectives) +END PROC view; + +PROC view (REAL CONST x, y, z) : + set values (size, limits, ROW 4 REAL : (angles (1), x, y, z), obliques, perspectives) +END PROC view; + +PROC get values (ROW 3 ROW 2 REAL VAR act size, + ROW 2 ROW 2 REAL VAR act limits, + ROW 4 REAL VAR act angles, + ROW 2 REAL VAR act obliques, + ROW 3 REAL VAR act perspectives) : + act size := size; + act limits := limits; + act angles := angles; + act obliques := obliques; + act perspectives := perspectives; + +END PROC get values; + +PROC set values (ROW 3 ROW 2 REAL CONST new size, + ROW 2 ROW 2 REAL CONST new limits, + ROW 4 REAL CONST new angles, + ROW 2 REAL CONST new obliques, + ROW 3 REAL CONST new perspectives) : + size := new size; + limits := new limits; + angles := new angles; + obliques := new obliques; + perspectives := new perspectives + +END PROC set values; + +PROC new values (INT VAR h min range, h max range, v min range, v max range): + new values (hor cm, vert cm, hor pixel, vert pixel, + h min range, h max range, v min range, v max range) +END PROC new values; + +PROC new values (REAL CONST size hor, size vert, + INT CONST pixel hor, pixel vert, + INT VAR h min range, h max range, + v min range, v max range): + remember screensize; + calc views; + calc projektion; + calc limits; + calc projection frame; + normalize projektion; + set picture range; + set perspective mark . + +remember screensize: + hor cm := size hor; + vert cm := size vert; + hor pixel := pixel hor; + vert pixel := pixel vert . + +calc views : + calc diagonale; + calc projektion; + calc angles; + calc normale; + calc matrix; + calc alpha angle . + +calc diagonale: + REAL VAR diagonale := sqrt (angles [2] * angles [2] + + angles [3] * angles [3] + + angles [4] * angles [4]) . + +calc projektion: + REAL VAR projektion := sqrt (angles [2] * angles [2] + + angles [4] * angles [4]) . + +calc angles: + REAL VAR sin p, cos p, sin t, cos t, sin a, cos a; + + IF diagonale = 0.0 + THEN sin p := 0.0; cos p := 1.0; + sin t := 0.0; cos t := 1.0 + ELIF projektion = 0.0 + THEN sin p := angles [3] / diagonale; + cos p := projektion / diagonale; + sin t := 0.0; cos t := 1.0 + ELSE sin p := angles [3] / diagonale; + cos p := projektion / diagonale; + sin t := angles [2] / projektion; + cos t := angles [4] / projektion + FI . + +calc normale: + REAL VAR sin p sin t := sin p * sin t, + sin p cos t := sin p * cos t, + cos p sin t := cos p * sin t, + cos p cos t := cos p * cos t, + + dx := size [1][2] - size [1][1], + dy := size [2][2] - size [2][1], + dz := size [3][2] - size [3][1], + norm az := obliques [1] , + norm bz := obliques [2] , + norm cx := perspectives [1] / dx, + norm cy := perspectives [2] / dy, + norm cz := perspectives [3] / dz . + +calc matrix: +p := ROW 5 ROW 5 REAL : + (ROW 5 REAL : ( cos t / dx - cos p sin t / dx * norm az , + - sin p sin t / dx - cos p sin t / dx * norm bz, + 0.0, + - cos p sin t / dx * norm cz, + 0.0 ), + ROW 5 REAL : ( - sin p / dy * norm az, + cos p / dy - sin p / dy * norm bz, + 0.0, + - sin p / dy * norm cz, + 0.0 ), + ROW 5 REAL : ( sin t / dz + cos p cos t / dz * norm az, + + sin p cos t / dz + cos p cos t / dz * norm bz, + 0.0, + cos p cos t / dz * norm cz, + 0.0 ), + ROW 5 REAL : (- norm cx, - norm cy, 0.0, 1.0, 0.0 ), + ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0)) . + +calc alpha angle: + IF angles (1) = 0.0 + THEN set alpha as y vertical + ELSE sin a := sind (angles (1)); + cos a := cosd (angles (1)) + FI . + +set alpha as y vertical : + REAL VAR r := sqrt (p(2)(1)**2 + p(2)(2)**2); + IF r = 0.0 + THEN sin a := 0.0; + cos a := 1.0 + ELSE sin a :=-p(2)(1)/r; + cos a := p(2)(2)/r + FI . + +calc limits : + IF limits as percent + THEN calc percent limits + ELSE calc centimeter limits FI . + +limits as percent: + limits [1][2] < 2.0 AND limits [2][2] < 2.0 . + +max limits: + h min limit := 0.0; + + v min limit := 0.0; + v max limit := real (pixel vert) . + +calc percent limits: + h min limit := real (pixel hor) * limits (1)(1)*size vert / size hor; + v min limit := limits (2)(1) * real (pixel vert); + + IF limits [1][2] = 0.0 + THEN h max limit := real (pixel hor) + ELSE h max limit := real (pixel hor) * limits [1][2]*size vert / size hor FI; + + IF limits [2][2] = 0.0 + THEN v max limit := real (pixel vert) + ELSE v max limit := limits (2)(2) * real (pixel vert) FI . + +calc centimeter limits: + h min limit := real (pixel hor) * (limits (1)(1)/size hor); + v min limit := real (pixel vert) * (limits (2)(1)/size vert); + + IF limits [1][2] = 0.0 + THEN h max limit := real (pixel hor) + ELSE h max limit := real (pixel hor) * (limits (1)(2)/size hor) FI; + + IF limits [2][2] = 0.0 + THEN v max limit := real (pixel vert) + ELSE v max limit := real (pixel vert) * (limits (2)(2)/size vert) FI . + +calc projection frame: + REAL VAR h min := max real, h max :=-max real, + v min := max real, v max :=-max real; + + extrema (size [1][1], size [2][1], size [3][1], h min, h max, v min, v max); + extrema (size [1][2], size [2][1], size [3][1], h min, h max, v min, v max); + extrema (size [1][2], size [2][2], size [3][1], h min, h max, v min, v max); + extrema (size [1][1], size [2][2], size [3][1], h min, h max, v min, v max); + extrema (size [1][1], size [2][1], size [3][2], h min, h max, v min, v max); + extrema (size [1][2], size [2][1], size [3][2], h min, h max, v min, v max); + extrema (size [1][2], size [2][2], size [3][2], h min, h max, v min, v max); + extrema (size [1][1], size [2][2], size [3][2], h min, h max, v min, v max) . + +normalize projektion : + REAL VAR sh := (h max limit - h min limit) / (h max - h min), + sv := (v max limit - v min limit) / (v max - v min), + dh := h min limit - h min*sh, + dv := v min limit - v min*sv; + + FOR i FROM 1 UPTO 5 + REP REAL CONST p i 1 := p (i)(1); + p (i)(1) := (p i 1 * cos a - p (i)(2) * sin a) * sh; + p (i)(2) := (p i 1 * sin a + p (i)(2) * cos a) * sv + PER; + p (5)(1) := dh; + p (5)(2) := dv . + +set picture range: + h min range := int (h min limit-0.5); + h max range := int (h max limit+0.5); + v min range := int (v min limit-0.5); + v max range := int (v max limit+0.5) . + +set perspective mark: + perspective projektion := perspectives [3] <> 0.0 . + +END PROC new values; + +PROC transform (REAL CONST x, y, z, INT VAR h, v) : + IF perspective projektion + THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0); + h := int ((x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (4)(1))*w + p (5)(1)); + v := int ((x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (4)(2))*w + p (5)(2)) + ELSE h := int (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (5)(1)); + v := int (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (5)(2)); + FI; +END PROC transform; + +PROC extrema (REAL CONST x, y, z, REAL VAR h min, h max, v min, v max): + REAL VAR h, v; + IF perspective projektion + THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0); + h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) +p (4)(1))*w; + v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) +p (4)(2))*w + ELSE h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1)); + v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2)) + FI; + + IF h < h min + THEN h min := h + ELIF h > h max + THEN h max := h FI; + + IF v < v min + THEN v min := v + ELIF v > v max + THEN v max := v FI + +END PROC extrema; + +INT PROC diagonal (REAL CONST percent): + int (percent * 0.01 * diagonale + 0.5) . + +diagonale: + sqrt ((h max limit-h min limit) ** 2 + (v max limit-v min limit) ** 2) . + +END PROC diagonal; + +INT PROC height (REAL CONST percent): + int (percent * 0.01 * (v max limit-v min limit) + 0.5) +END PROC height; + +INT PROC width (REAL CONST percent): + int (percent * 0.01 * (h max limit-h min limit) + 0.5) +END PROC width; + +END PACKET transformation + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot b/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot new file mode 100644 index 0000000..8bef1e4 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot @@ -0,0 +1,506 @@ +PACKET clipping DEFINES set range, (*Autor: Heiko Indenbirken *) + get range, (*Stand: 27.06.85/12:39 *) + clip: (*Änderung: 11.08.86/15:02 *) + +INT VAR x min :: 0, x max :: 1024, y min :: 0, y max :: 1024; + +PROC set range (INT CONST h min, v min, h max, v max): + IF h min >= h max OR v min >= v max + THEN errorstop ("Incorrect Range") FI; + x min := h min; x max := h max; + y min := v min; y max := v max +END PROC set range; + +PROC get range (INT VAR h min, v min, h max, v max): + h min := x min; h max := x max; + v min := y min; v max := y max +END PROC get range; + +PROC clip (INT CONST from x, from y, to x, to y, + PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw): + INT VAR x, y; + calculate parts of line; + IF both points inside + THEN draw (to x, to y) + ELIF both points outside + THEN + ELIF first point outside + THEN intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + draw (to x, to y) + ELIF second point outside + THEN intersection (from x, from y, to x, to y, to part, x, y); + draw (x, y) + ELSE intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + clip (x, y, to x, to y, PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw) + FI . + +calculate parts of line: + INT CONST from part :: part (from x, from y), + to part :: part (to x, to y) . + +both points inside: + from part = 0 AND to part = 0 . + +both points outside: + (from part AND to part) <> 0 . + +first point outside: + from part <> 0 AND to part = 0 . + +second point outside: + to part <> 0 AND from part = 0 . + +END PROC clip; + +INT PROC part (INT CONST x, y): + INT VAR index :: 0; + IF x > x max + THEN set bit (index, 0) + ELIF x < x min + THEN set bit (index, 1) FI; + + IF y > y max + THEN set bit (index, 2) + ELIF y < y min + THEN set bit (index, 3) FI; + + index + +END PROC part; + +PROC intersection (INT CONST from x, from y, to x, to y, to part, INT VAR x, y): + SELECT to part OF + CASE 1: right side + CASE 2: left side + CASE 4: up side + CASE 5: upright side + CASE 6: upleft side + CASE 8: down side + CASE 9: downright side + CASE 10: downleft side + OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT . + +right side: + y := from y + int (real (x max-from x)*(dy/dx)); + x := x max . + +left side: + y := from y + int (real (x min-from x)*(dy/dx)); + x := x min . + +up side: + x := from x + int (real (y max-from y)*(dx/dy)); + y := y max . + +down side: + x := from x + int (real (y min-from y)*(dx/dy)); + y := y min . + +upright side: + right side; + IF y > y max + THEN up side FI . + +downright side: + right side; + IF y < y min + THEN down side FI . + +upleft side: + left side; + IF y > y max + THEN up side FI . + +downleft side: + left side; + IF y < y min + THEN down side FI . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC intersection; + +END PACKET clipping; + +PACKET thick line DEFINES thick: (*Autor: Heiko Indenbirken *) + (*Stand: 02.07.85/15:07 *) + (*Änderung: 05.08.86/15:52 *) +PROC thick (INT CONST x0, y0, x1, y1, thick, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF is point + THEN draw point + ELIF is horizontal line + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + ELSE vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + FI . + +is point: + x0 = x1 AND y0 = y1 . + +is horizontal line: + abs (x0-x1) >= abs (y0-y1) . + +draw point: + INT VAR i; + FOR i FROM -thick UPTO thick + REP line (x0-thick, y0+i, x0+thick, y0+i) PER . + +END PROC thick; + +PROC horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from x > to x + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta x; + line (x start+delta x, y start+i, x end+delta x, y end+i) + PER . + +calculate increase: + REAL VAR increase :: -dy / dx . + +calculate limit points: + INT CONST x start :: from x - thick, + x end :: to x + thick, + y start :: from y + int (increase * real (thick)), + y end :: to y - int (increase * real (thick)) . + +calculate delta x: + INT CONST delta x :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC horizontal line; + +PROC vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from y > to y + THEN vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta y; + line (x start+i, y start+delta y, x end+i, y end+delta y) + PER . + +calculate increase: + REAL VAR increase :: -dx / dy . + +calculate limit points: + INT CONST x start :: from x + int (increase * real (thick)), + x end :: to x - int (increase * real (thick)), + y start :: from y - thick, + y end :: to y + thick . + +calculate delta y: + INT CONST delta y :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC vertical line; + +END PACKET thick line; + +PACKET graphik text DEFINES draw char, (*Autor: Heiko Indenbirken *) + zeichensatz: (*Stand: 27.06.85/16:03 *) + (*Änderung: 28.06.85/19:06 *) + (*Änderung: 05.08.86/16:00 *) +LET ZEICHENSATZ = ROW 255 TEXT; +ZEICHENSATZ VAR zeichen; +INT CONST char x :: 6, char y :: 10; + +zeichensatz ("ZEICHENSATZ"); + +PROC zeichensatz (TEXT CONST name): + IF exists (name) + THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name); + zeichen := new zeichen; + ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI +END PROC zeichensatz; + +PROC draw char (INT CONST char no, INT CONST x, y, x size, y size, direction, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + TEXT CONST character :: zeichen [char no]; + INT VAR n :: 1, x0, y0, x1, y1; + INT CONST len :: length (character); + WHILE n < len + REP value (character, n, x0, y0, x1, y1); + transform (x0, y0, x, y, x size, y size, direction); + transform (x1, y1, x, y, x size, y size, direction); + line (x0, y0, x1, y1); + n INCR 4 + PER . + +END PROC draw char; + +PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1): + x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1)); + x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3)); +END PROC value; + +INT PROC val (INT CONST n): + IF n > 127 + THEN -256 OR n + ELSE n FI +END PROC val; + +PROC transform (INT VAR x, y, INT CONST x0, y0, x size, y size, direction): + INT CONST old x :: x, old y :: y; + SELECT direction OF + CASE 0: x := x0 + x vektor; y := y0 + y vektor + CASE 1: x := x0 - y vektor; y := y0 + x vektor + CASE 2: x := x0 - x vektor; y := y0 - y vektor + CASE 3: x := x0 + y vektor; y := y0 - x vektor + ENDSELECT . + +x vektor: + IF x size = 0 + THEN old x + ELSE (old x*x size) DIV char x FI . + +y vektor: + IF y size = 0 + THEN old y + ELSE (old y*y size) DIV char y FI . + +END PROC transform; + +END PACKET graphik text; + +PACKET graphik text DEFINES draw text: (*Autor: Heiko Indenbirken *) + (*Stand: 03.07.85/11:55 *) + (*Änderung: 05.08.86/16:04 *) +PROC draw text (INT CONST x pos, y pos, + TEXT CONST msg, REAL CONST angle, INT CONST height, width, + PROC (INT CONST, INT CONST, + INT CONST, INT CONST, INT CONST, INT CONST) draw char): + INT CONST dir :: int (((angle MOD 360.0)+45.0) / 90.0); + INT VAR i; + REAL VAR x :: real (x pos), y :: real (y pos), + x step :: cosd (angle)*real (width), + y step :: sind (angle)*real (width); + FOR i FROM 1 UPTO length (msg) + REP IF control char + THEN execute control char + ELSE execute normal char FI + PER . + +control char: + akt char < ""32"" . + +execute control char: + SELECT code (akt char) OF + CASE 1: home + CASE 2: right + CASE 3: up + CASE 7: out (""7"") + CASE 8: left + CASE 10: down + CASE 13: return + ENDSELECT . + +home: + x := real (x pos); + y := real (y pos) . + +right: + x INCR x step; y INCR y step . + +up: + x INCR y step; y INCR x step . + +left: + x DECR x step; y DECR y step . + +down: + x DECR y step; y DECR x step . + +return: + x := real (x pos) . + +execute normal char: + draw char (code (akt char), dir, int (x+0.5), int (y+0.5), height, width); + x INCR x step; + y INCR y step . + +akt char: + msg SUB i . + +END PROC draw text; + +END PACKET graphik text; + +PACKET comercial plot DEFINES bar, (*Autor: Heiko Indenbirken *) + circle: (*Stand: 03.04.1985 *) + (*Änderung: 03.07.85/15:37 *) +PROC bar (INT CONST from x, from y, to x, to y, pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF from x > to x + THEN bar (to x, from y, from x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELIF from y > to y + THEN bar (from x, to y, to x, from y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELSE draw frame; + fill frame with pattern + FI . + +draw frame: + line (from x, from y, from x, to y); + line (from x, to y, to x, to y); + line (to x, to y, to x, from y); + line (to x, from y, from x, from y) . + +fill frame with pattern: + SELECT pattern OF + CASE 1: fill right (from x, to x, from y, to y, 2, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 2: fill hor (from x, to x, from y, to y, 1, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 3: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 4: fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 5: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 6: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 7: fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 8: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ENDSELECT . + +END PROC bar; + +PROC fill hor (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR y :: from y; + REP line (from x, y, to x, y); + y INCR step + UNTIL y > to y PER . + +END PROC fill hor; + +PROC fill vert (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR x :: from x; + REP line (x, from y, x, to y); + x INCR step + UNTIL x > to x PER . + +END PROC fill vert; + +PROC fill right (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: from x, right :: from x, + lower :: from y, upper :: from y; +(* Ausfüllen von links unten nach rechts oben *) + WHILE t < length + REP calc start point; + calc end point; + line (left, upper, right, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN left := from x + t - height; + upper := to y + ELSE left INCR step FI . + +calc end point: + IF t < width + THEN right INCR step + ELIF t < width step + THEN lower := from y + t - width; + right := to x + ELSE lower INCR step FI . + +END PROC fill right; + +PROC fill left (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: to x, right :: to x, + lower :: from y, upper :: from y; +(* Ausfüllen von rechts unten nach links oben *) + WHILE t < length + REP calc start point; + calc end point; + line (right, upper, left, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN right := to x - t + height; + upper := to y + ELSE right DECR step FI . + +calc end point: + IF t < width + THEN left DECR step + ELIF t < width step + THEN lower := from y + t - width; + left := from x + ELSE lower INCR step FI . + +END PROC fill left; + +PROC circle (INT CONST x, y, REAL CONST rad, from, to, INT CONST pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + REAL VAR t :: from; + INT VAR last x :: x, last y :: y; + WHILE t <= to + REP calc circle; + draw step; + t INCR 1.0 + PER; + line (x rad, y rad, x, y) . + +draw step: + IF pattern = 0 + THEN line (last x, last y, x rad, y rad); + last x := x rad; + last y := y rad + ELSE line (x, y, x rad, y rad) FI . + +calc circle: + INT CONST x rad :: int (cosd (t)*rad+0.5)+x, + y rad :: int (sind (t)*rad+0.5)+y . + +END PROC circle; + +END PACKET comercial plot; + diff --git a/system/std.graphik/1.8.7/src/HP7475.plot b/system/std.graphik/1.8.7/src/HP7475.plot new file mode 100644 index 0000000..860dd03 --- /dev/null +++ b/system/std.graphik/1.8.7/src/HP7475.plot @@ -0,0 +1,254 @@ +PACKET hp7475 plot DEFINES set range, (*Autor: Heiko Indenbirken *) + get range, (*Stand: 03.09.86/15:09 *) + drawing area, + begin plot, + end plot, + clear, + + set pen, get pen, + move, + draw, + marker, + bar, circle, + where: + +(* *) +(* Hardware Anschluß des HP7475A: *) +(* 9600 Baud, 8 Bit, no parity, RTS/CTS *) +(* Leitungen 1 ----- 1 *) +(* gekreuzt: 2 --x-- 3 *) +(* 3 --x-- 2 *) +(* *) + + +LET POS = STRUCT (INT x, y); +LET RANGE = STRUCT (POS min, max); +LET PEN = STRUCT (INT back, fore, thick, line); + +LET width scale = 0.002690217391304, + height scale = 0.002728921124206; + +LET term = ";", + comma = ",", + point = ".", + zero = "0", + nil = "", + etx = ""3""; + + +POS VAR old :: POS:(0, 0); +RANGE VAR area :: RANGE:(POS:(0,0), POS:(11040, 7721)); +PEN VAR pen :: PEN : (0, 1, 0, 1); +TEXT VAR result; + +ROW 16 TEXT VAR mark := ROW 16 TEXT: +("99,0,2,-2,0,0,-4,4,0,0,4,-2,0;", +"99,0,2,-1,0,-1,-1,0,-2,1,-1,2,0,1,1,0,2,-1,1,-1,0;", +"99,0,2,-2,-3,4,0,-2,3;", +"-99,-2,0,99,4,0,-99,-2,2,99,0,-4;", +"-99,-2,-2,99,4,4,-99,-4,0,99,4,-4;", +"99,0,2,-2,-2,2,-2,2,2,-2,2;", +"-99,0,-2,99,0,4,-2,-2,4,0,-2,2;", +"-99,-2,0,99,4,0,-99,-2,2,99,0,-4,2,2,-2,2,-2,-2,2,-2;", +"-99,-2,-2,99,4,4,-4,0,4,-4;", +"-99,-2,2,99,4,0,-4,-4,4,0;", +"99,0,-2,-99,-2,4,99,2,-2,2,2;", +"99,1,1,-2,0,0,-2,2,0,0,2,1,1,-99,-4,0,99,1,-1,-99,0,-2,99,-1,-1,-99,4,0,99,-1,1;", +"-99,-2,0,99,4,0,-99,-1,1,99,-2,-2,-99,1,-1,99,0,4,-99,-1,-1,99,2,-2;", +"-99,-2,2,99,4,0,-4,-4,4,0,-4,4;", +"-99,-2,0,99,4,0;", +"-99,0,299,0,-4;"); + +ROW 5 TEXT CONST line pattern := ROW 5 TEXT:("LT;", "LT1;", "LT2;", "LT3;", "LT4;"); +ROW 8 TEXT CONST fill pattern := ROW 8 TEXT:("FT4,25,45;", "FT1,0,0;", "FT3,50,0;", + "FT3,50,90;", "FT4,50,0;", "FT3,50,-45;", + "FT3,50,45;", "FT4,50,45;"); + +PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) : + x cm := 29.7; y cm := 21.07; + x pixel := 11040; y pixel := 7721; +END PROC drawing area; + + +PROC set range (INT CONST h min, v min, h max, v max): + IF h min >= h max OR v min >= v max + THEN errorstop ("Incorrect Range") FI; + area := RANGE:(POS:(h min, v min), POS:(h max, v max)) +END PROC set range; + +PROC get range (INT VAR h min, v min, h max, v max): + h min := area.min.x; v min := area.min.y; + h max := area.max.x; v max := area.max.y +END PROC get range; + +PROC begin plot: + out ("IN;") +ENDPROC begin plot; + +PROC end plot: + TEXT VAR rec; + out ("IN;SP;PA22040,7721;DP;"); + REP pause (10); + out ("OS;"); + input (rec, ""13"", 600) + UNTIL enter pressed PER; + out ("IN;") . + +enter pressed: + (int (rec) AND 4) > 0 . + +ENDPROC end plot; + +PROC clear: + new values (29.7, 21.07, 11040, 7721, area.min.x, area.max.x, area.min.y, area.max.y); + pen := PEN : (0, 1, 0, 1); + old := area.min; + out ("DF;IP;"); (* Default *) + out ("IW" + text (area.min.x, area.min.y) + ", " + (* Clipping *) + text (area.max.x, area.max.y) + term); + out ("SP1;"); (* Pen 1 *) + out ("LT;"); (* durchgehend *) + out ("PU;PA" + text (old.x, old.y)); (* Startpunkt *) + +END PROC clear; + +PROC set pen (INT CONST back, fore, thick, type): + set colour; + set linetype . + +set colour: + IF abs (fore) >= 1 AND abs (fore) <= 6 + THEN out ("SP" + text (abs (fore)) + term); + pen.fore := abs (fore); + FI . + +set linetype: + IF type >= 1 AND type <= 5 + THEN out (line pattern [type]); + pen.line := type + ELSE out ("SP;"); + pen.line := 0 + FI . + +END PROC set pen; + +PROC get pen (INT VAR back, fore, thick, line): + back := pen.back; + fore := pen.fore; + thick := pen.thick; + line := pen.line +END PROC get pen; + +PROC move (INT CONST x, y) : + out ("PU;PA" + text (x, y) + term); + old := POS : (x, y) +END PROC move; + +PROC draw (INT CONST x, y): + out ("PD;PA" + text (x, y) + term); + old := POS : (x, y) +END PROC draw; + +PROC draw (TEXT CONST msg, REAL CONST angle, INT CONST height, width): + set angle; + set height and width; + plot msg . + +set angle: + out ("DI " + text (cosd (angle), sind (angle)) + term) . + +set height and width: + IF width = 0 AND height = 0 + THEN out ("SR;") + ELSE out ("SI" + text (real (width) * width scale, + real (height) * height scale) + term) + FI . + +plot msg: + out ("LB" + msg + etx) . + +END PROC draw; + +PROC bar (INT CONST from x, from y, to x, to y, pattern): + out ("PU;PA" + text (from x, from y) + term); + out ("LT;EA" + text (to x, to y) + term); + IF pattern > 0 AND pattern <= 8 + THEN out (fill pattern [pattern]); + out ("RA" + text (to x, to y) + term); + FI; + out ("PU;PA" + text (old.x, old.y) + term); + out (line pattern [pen.line]) . + +END PROC bar; + +PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern): + out ("LT;PU;PA" + text (x, y) + term); + IF (from MOD 360.0) = 0.0 AND (to MOD 360.0) = 0.0 + THEN out ("CI" + text (rad) + term) + ELSE out ("EW" + text (rad) + comma + text (from, to-from) + term) FI; + + IF pattern > 0 AND pattern <= 6 + THEN out (fill pattern [pattern]); + out ("WG" + text (rad) + comma + text (from, to-from) + term) + FI; + out ("PU;PA" + text (old.x, old.y) + term); + out (line pattern [pen.line]) . + +END PROC circle; + +PROC marker (INT CONST x, y, no, size): + out ("LT;PU;PA" + text (x, y) + term); + out ("DI1,0;"); + IF size = 0 + THEN out ("SI0.25,0.5;") + ELSE out ("SI" + text (real (size)*0.001, real (size)*0.002) + term) FI; + out ("UC" + mark [mark no]); + out ("PU;PA" + text (old.x, old.y) + term); + out (line pattern [pen.line]) . + +mark no: + IF no >= 1 AND no <= 16 + THEN no + ELSE 1 FI . + +END PROC marker; + +PROC where (INT VAR x, y): + x := old.x; y := old.y +END PROC where; + +TEXT PROC text (INT CONST x, y): + text (x) + comma + text (y) +END PROC text; + +TEXT PROC text (REAL CONST x, y): + text (x) + comma + text (y) +END PROC text; + +TEXT PROC text (REAL CONST x): + result := compress (text (x, 9, 4)); + + IF (result SUB 1) = point + THEN insert char (result, zero, 1) + ELIF (result SUB LENGTH result) = point + THEN result CAT zero FI; + result +END PROC text; + +PROC input (TEXT VAR rec, TEXT CONST del, INT CONST time): + enable stop; + rec := nil; + REP TEXT CONST char := incharety (time); + + IF char = nil + THEN errorstop ("Timeout after " + text (time)) + ELIF pos (del, char) > 0 + THEN LEAVE input + ELSE rec CAT char FI + + PER . + +END PROC input; + +END PACKET hp7475 plot + diff --git a/system/std.graphik/1.8.7/src/PC.plot b/system/std.graphik/1.8.7/src/PC.plot new file mode 100644 index 0000000..712f5ea --- /dev/null +++ b/system/std.graphik/1.8.7/src/PC.plot @@ -0,0 +1,758 @@ +PACKET clipping DEFINES set range, (*Autor: Heiko Indenbirken *) + get range, (*Stand: 27.06.85/12:39 *) + clip: (*Änderung: 11.08.86/15:02 *) + +INT VAR x min :: 0, x max :: 1024, y min :: 0, y max :: 1024; + +PROC set range (INT CONST h min, v min, h max, v max): + IF h min >= h max OR v min >= v max + THEN errorstop ("Incorrect Range") FI; + x min := h min; x max := h max; + y min := v min; y max := v max +END PROC set range; + +PROC get range (INT VAR h min, v min, h max, v max): + h min := x min; h max := x max; + v min := y min; v max := y max +END PROC get range; + +PROC clip (INT CONST from x, from y, to x, to y, + PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw): + INT VAR x, y; + calculate parts of line; + IF both points inside + THEN draw (from x, from y); (* Macke im SHARD *) + draw (to x, to y) + ELIF both points outside + THEN + ELIF first point outside + THEN intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + draw (to x, to y) + ELIF second point outside + THEN intersection (from x, from y, to x, to y, to part, x, y); + draw (x, y) + ELSE intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + clip (x, y, to x, to y, PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw) + FI . + +calculate parts of line: + INT CONST from part :: part (from x, from y), + to part :: part (to x, to y) . + +both points inside: + from part = 0 AND to part = 0 . + +both points outside: + (from part AND to part) <> 0 . + +first point outside: + from part <> 0 AND to part = 0 . + +second point outside: + to part <> 0 AND from part = 0 . + +END PROC clip; + +INT PROC part (INT CONST x, y): + INT VAR index :: 0; + IF x > x max + THEN set bit (index, 0) + ELIF x < x min + THEN set bit (index, 1) FI; + + IF y > y max + THEN set bit (index, 2) + ELIF y < y min + THEN set bit (index, 3) FI; + + index + +END PROC part; + +PROC intersection (INT CONST from x, from y, to x, to y, to part, INT VAR x, y): + SELECT to part OF + CASE 1: right side + CASE 2: left side + CASE 4: up side + CASE 5: upright side + CASE 6: upleft side + CASE 8: down side + CASE 9: downright side + CASE 10: downleft side + OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT . + +right side: + y := from y + int (real (x max-from x)*(dy/dx)); + x := x max . + +left side: + y := from y + int (real (x min-from x)*(dy/dx)); + x := x min . + +up side: + x := from x + int (real (y max-from y)*(dx/dy)); + y := y max . + +down side: + x := from x + int (real (y min-from y)*(dx/dy)); + y := y min . + +upright side: + right side; + IF y > y max + THEN up side FI . + +downright side: + right side; + IF y < y min + THEN down side FI . + +upleft side: + left side; + IF y > y max + THEN up side FI . + +downleft side: + left side; + IF y < y min + THEN down side FI . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC intersection; + +END PACKET clipping; + +PACKET thick line DEFINES thick: (*Autor: Heiko Indenbirken *) + (*Stand: 02.07.85/15:07 *) + (*Änderung: 05.08.86/15:52 *) +PROC thick (INT CONST x0, y0, x1, y1, thick, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF is point + THEN draw point + ELIF is horizontal line + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + ELSE vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + FI . + +is point: + x0 = x1 AND y0 = y1 . + +is horizontal line: + abs (x0-x1) >= abs (y0-y1) . + +draw point: + INT VAR i; + FOR i FROM -thick UPTO thick + REP line (x0-thick, y0+i, x0+thick, y0+i) PER . + +END PROC thick; + +PROC horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from x > to x + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta x; + line (x start+delta x, y start+i, x end+delta x, y end+i) + PER . + +calculate increase: + REAL VAR increase :: -dy / dx . + +calculate limit points: + INT CONST x start :: from x - thick, + x end :: to x + thick, + y start :: from y + int (increase * real (thick)), + y end :: to y - int (increase * real (thick)) . + +calculate delta x: + INT CONST delta x :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC horizontal line; + +PROC vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from y > to y + THEN vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta y; + line (x start+i, y start+delta y, x end+i, y end+delta y) + PER . + +calculate increase: + REAL VAR increase :: -dx / dy . + +calculate limit points: + INT CONST x start :: from x + int (increase * real (thick)), + x end :: to x - int (increase * real (thick)), + y start :: from y - thick, + y end :: to y + thick . + +calculate delta y: + INT CONST delta y :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC vertical line; + +END PACKET thick line; + +PACKET graphik text DEFINES draw char, (*Autor: Heiko Indenbirken *) + zeichensatz: (*Stand: 27.06.85/16:03 *) + (*Änderung: 28.06.85/19:06 *) + (*Änderung: 05.08.86/16:00 *) +LET ZEICHENSATZ = ROW 255 TEXT; +ZEICHENSATZ VAR zeichen; +INT CONST char x :: 6, char y :: 10; + +zeichensatz ("ZEICHENSATZ"); + +PROC zeichensatz (TEXT CONST name): + IF exists (name) + THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name); + zeichen := new zeichen; + ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI +END PROC zeichensatz; + +PROC draw char (INT CONST char no, INT CONST x, y, x size, y size, direction, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + TEXT CONST character :: zeichen [char no]; + INT VAR n :: 1, x0, y0, x1, y1; + INT CONST len :: length (character); + WHILE n < len + REP value (character, n, x0, y0, x1, y1); + transform (x0, y0, x, y, x size, y size, direction); + transform (x1, y1, x, y, x size, y size, direction); + line (x0, y0, x1, y1); + n INCR 4 + PER . + +END PROC draw char; + +PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1): + x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1)); + x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3)); +END PROC value; + +INT PROC val (INT CONST n): + IF n > 127 + THEN -256 OR n + ELSE n FI +END PROC val; + +PROC transform (INT VAR x, y, INT CONST x0, y0, x size, y size, direction): + INT CONST old x :: x, old y :: y; + SELECT direction OF + CASE 0: x := x0 + x vektor; y := y0 + y vektor + CASE 1: x := x0 - y vektor; y := y0 + x vektor + CASE 2: x := x0 - x vektor; y := y0 - y vektor + CASE 3: x := x0 + y vektor; y := y0 - x vektor + ENDSELECT . + +x vektor: + IF x size = 0 + THEN old x + ELSE (old x*x size) DIV char x FI . + +y vektor: + IF y size = 0 + THEN old y + ELSE (old y*y size) DIV char y FI . + +END PROC transform; + +END PACKET graphik text; + +PACKET graphik text DEFINES draw text: (*Autor: Heiko Indenbirken *) + (*Stand: 03.07.85/11:55 *) + (*Änderung: 05.08.86/16:04 *) +PROC draw text (INT CONST x pos, y pos, + TEXT CONST msg, REAL CONST angle, INT CONST height, width, + PROC (INT CONST, INT CONST, + INT CONST, INT CONST, INT CONST, INT CONST) draw char): + INT CONST dir :: int (((angle MOD 360.0)+45.0) / 90.0); + INT VAR i; + REAL VAR x :: real (x pos), y :: real (y pos), + x step :: cosd (angle)*real (width), + y step :: sind (angle)*real (width); + FOR i FROM 1 UPTO length (msg) + REP IF control char + THEN execute control char + ELSE execute normal char FI + PER . + +control char: + akt char < ""32"" . + +execute control char: + SELECT code (akt char) OF + CASE 1: home + CASE 2: right + CASE 3: up + CASE 7: out (""7"") + CASE 8: left + CASE 10: down + CASE 13: return + ENDSELECT . + +home: + x := real (x pos); + y := real (y pos) . + +right: + x INCR x step; y INCR y step . + +up: + x INCR y step; y INCR x step . + +left: + x DECR x step; y DECR y step . + +down: + x DECR y step; y DECR x step . + +return: + x := real (x pos) . + +execute normal char: + draw char (code (akt char), dir, int (x+0.5), int (y+0.5), height, width); + x INCR x step; + y INCR y step . + +akt char: + msg SUB i . + +END PROC draw text; + +END PACKET graphik text; + +PACKET comercial plot DEFINES bar, (*Autor: Heiko Indenbirken *) + circle: (*Stand: 03.04.1985 *) + (*Änderung: 03.07.85/15:37 *) +PROC bar (INT CONST from x, from y, to x, to y, pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF from x > to x + THEN bar (to x, from y, from x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELIF from y > to y + THEN bar (from x, to y, to x, from y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELSE draw frame; + fill frame with pattern + FI . + +draw frame: + line (from x, from y, from x, to y); + line (from x, to y, to x, to y); + line (to x, to y, to x, from y); + line (to x, from y, from x, from y) . + +fill frame with pattern: + SELECT pattern OF + CASE 1: fill right (from x, to x, from y, to y, 2, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 2: fill hor (from x, to x, from y, to y, 1, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 3: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 4: fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 5: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 6: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 7: fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 8: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ENDSELECT . + +END PROC bar; + +PROC fill hor (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR y :: from y; + REP line (from x, y, to x, y); + y INCR step + UNTIL y > to y PER . + +END PROC fill hor; + +PROC fill vert (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR x :: from x; + REP line (x, from y, x, to y); + x INCR step + UNTIL x > to x PER . + +END PROC fill vert; + +PROC fill right (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: from x, right :: from x, + lower :: from y, upper :: from y; +(* Ausfüllen von links unten nach rechts oben *) + WHILE t < length + REP calc start point; + calc end point; + line (left, upper, right, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN left := from x + t - height; + upper := to y + ELSE left INCR step FI . + +calc end point: + IF t < width + THEN right INCR step + ELIF t < width step + THEN lower := from y + t - width; + right := to x + ELSE lower INCR step FI . + +END PROC fill right; + +PROC fill left (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: to x, right :: to x, + lower :: from y, upper :: from y; +(* Ausfüllen von rechts unten nach links oben *) + WHILE t < length + REP calc start point; + calc end point; + line (right, upper, left, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN right := to x - t + height; + upper := to y + ELSE right DECR step FI . + +calc end point: + IF t < width + THEN left DECR step + ELIF t < width step + THEN lower := from y + t - width; + left := from x + ELSE lower INCR step FI . + +END PROC fill left; + +PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + REAL VAR t :: from; + INT VAR last x :: x, last y :: y; + WHILE t <= to + REP calc circle; + draw step; + t INCR 5.0 + PER; + line (x rad, y rad, x, y) . + +draw step: + IF pattern = 0 + THEN line (last x, last y, x rad, y rad); + last x := x rad; + last y := y rad + ELSE line (x, y, x rad, y rad) FI . + +calc circle: + INT CONST x rad :: int (cosd (t)*real (rad)+0.5)+x, + y rad :: int (sind (t)*real (rad)+0.5)+y . + +END PROC circle; + +END PACKET comercial plot; + +PACKET pc plot DEFINES drawing area, (*Autor: Heiko Indenbirken *) + begin plot, (*Stand: 20.05.85 *) + end plot, (*Änderung: 27.06.85/16:17 *) + clear, (*Änderung: 03.07.85/15:59 *) + (*Änderung: 06.08.86/10:03 *) + graphik, + set pen, get pen, + + move, + draw, + draw line, + marker, + bar, circle, + where: + + +LET POS = STRUCT (INT x, y); +LET PEN = STRUCT (INT back, fore, thick, line); +INT CONST back code :: -4, + modus code :: -5, + draw code :: -6, + move code :: -7, + pen code :: -8, + full line :: -1; + +INT VAR d, y, pause time :: 10, + resolution :: 4, max x :: 319, max y :: 199; +BOOL VAR is clear := FALSE; +POS VAR old :: POS : (0, 0); +PEN VAR pen :: PEN : (0, 1, 0, full line); + +PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) : + x cm := 22.0; y cm := 13.7; + x pixel := max x; y pixel := max y; +END PROC drawing area; + +PROC graphik (INT CONST modus, pause): + pause time := pause; + SELECT modus OF + CASE 0: resolution := 3; + CASE 1: resolution := 72; + max x := 639; + max y := 399 + CASE 2: resolution := 64; + max x := 639; + max y := 399 + CASE 3: resolution := 6; + max x := 639; + max y := 199 + CASE 4: resolution := 4; + max x := 319; + max y := 199 + OTHERWISE errorstop ("Nur Modi 0-4") ENDSELECT; + + set range (0, 0, max x, max y); +END PROC graphik; + +PROC begin plot : + control (modus code, resolution, 0, d); + is clear := TRUE; +ENDPROC begin plot ; + +PROC end plot : + IF pause time > 0 + THEN indicate end plot FI; + control (modus code, 3, 0, d) . + +indicate end plot: + control (pen code, full line, full line, d); + REP set indicator; + UNTIL incharety (pause time) <> "" PER . + +set indicator: + control (move code, 0, max y, d); + control (draw code, max x, max y, d) . + +ENDPROC end plot ; + +PROC clear: + INT VAR x0, x1, y0, y1; + new values (22.0, 13.7, max x, max y, x0, x1, y0, y1); + set range (x0, y0, x1, y1); + clear screen; + clear pen; + clear pos; + is clear := FALSE . + +clear screen: + IF is clear OR full screen + THEN control (modus code, resolution, 0, d) + ELSE draw frame; + clear frame + FI . + +full screen: + x0 < 10 AND x1 > (max x-10) AND + y0 < 10 AND y1 > (max y-10) . + +draw frame: + control (move code, x0, y0, d); + control (draw code, x1, y0, d); + control (draw code, x1, y1, d); + control (draw code, x0, y1, d); + control (draw code, x0, y0, d) . + +clear frame: + control (pen code, full line, 0, d); + FOR y FROM max y-y1 UPTO max y-y0 + REP control (move code, x0, y, d); + control (draw code, x1, y, d); + PER . + +clear pen: + pen := PEN : (0, 1, 0, full line); + control (pen code, full line, 1, d) . + +clear pos: + old := POS : (x0, y0); + control (move code, x0, max y-y0, d) . + +END PROC clear; + +PROC set pen (INT CONST back, fore, thick, type): + set background; + set foreground and linetype; + set thickness . + +set background: + pen.back := back; (*Hintergrund über niederwertiges *) + control (back code, 0, back no, d) .(*Byte von colour code *) + (*Höherwetiges Byte regelt die *) +back no: (*Farbpalette *) + IF back = 0 + THEN std background + ELSE back FI . + +std background: + IF resolution = 4 + THEN 16 + ELSE 15 FI . + +set foreground and linetype: (*0, 1, 2, 3 Farben: löschend,*) + pen.fore := possible colour; (*ändernd oder überschreibend *) + pen.line := type; (* in allen Linientypen. *) + control (pen code, line (type), pen.fore, d) . + +possible colour: + IF fore <= full line + THEN full line + ELIF fore > 3 OR (fore > 1 AND resolution <> 4) + THEN 1 + ELSE fore FI . + +set thickness: + pen.thick := thick DIV 10 . + +END PROC set pen; + +PROC get pen (INT VAR back, fore, thick, line): + back := pen.back; + fore := pen.fore; + thick := pen.thick; + line := pen.line +END PROC get pen; + +INT PROC line (INT CONST type): + SELECT type OF + CASE 0: 0 + CASE 1: full line + CASE 2: 21845 + CASE 3: 3855 + CASE 4: 255 + CASE 5: 4351 + OTHERWISE type END SELECT +END PROC line; + +PROC int move (INT CONST x, y): + control (move code, x, max y-y, d); +END PROC int move; + +PROC int draw (INT CONST x, y): + control (draw code, x, max y-y, d); +END PROC int draw; + +PROC draw line (INT CONST from x, from y, to x, to y): + control (move code, from x, max y-from y, d); + clip (from x, from y, to x, to y, PROC int move, PROC int draw) +END PROC draw line; + +PROC move (INT CONST x, y) : + control (move code, x, max y-y, d); + old := POS : (x, y) +END PROC move; + +PROC draw (INT CONST x, y): + IF std thickness + THEN clip (old.x, old.y, x, y, PROC int move, PROC int draw) + ELSE thick (old.x, old.y, x, y, pen.thick, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line) FI; + old := POS : (x, y) . + +std thickness: pen.thick = 0 . +END PROC draw; + +PROC draw (TEXT CONST msg, REAL CONST angle, INT CONST height, width): + control (pen code, full line, pen.fore, d); + draw text (old.x, old.y, msg, angle, y size, x size, + PROC (INT CONST, INT CONST, INT CONST, INT CONST, INT CONST, INT CONST) draw char); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . + +x size: IF width = 0 + THEN 6 + ELSE width FI . +y size: IF height = 0 + THEN 10 + ELSE height FI . + +END PROC draw; + +PROC draw char (INT CONST char, direction, x, y, INT CONST height, width): + draw char (char, x, y, width, height, direction, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line) +END PROC draw char; + +PROC bar (INT CONST from x, from y, to x, to y, pattern): + control (pen code, full line, pen.fore, d); + bar (from x, from y, to x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . +END PROC bar; + +PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern): + control (pen code, full line, pen.fore, d); + circle (x, y, rad, from, to, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . +END PROC circle; + +PROC marker (INT CONST x, y, no, size): + control (pen code, full line, pen.fore, d); + draw char (no, 0, x, y, size, size); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . +END PROC marker; + +PROC where (INT VAR x, y): + x := old.x; y := old.y +END PROC where; + +END PACKET pc plot + diff --git a/system/std.graphik/1.8.7/src/ZEICHENSATZ b/system/std.graphik/1.8.7/src/ZEICHENSATZ Binary files differnew file mode 100644 index 0000000..9866ec2 --- /dev/null +++ b/system/std.graphik/1.8.7/src/ZEICHENSATZ diff --git a/system/std.graphik/1.8.7/src/gen Graphik b/system/std.graphik/1.8.7/src/gen Graphik new file mode 100644 index 0000000..f70cc66 --- /dev/null +++ b/system/std.graphik/1.8.7/src/gen Graphik @@ -0,0 +1,16 @@ +TEXT VAR geraet; +page; +out ("Bitte den Namen der Hardwareanpassung (z.B. 'PC.plot') eingeben: "); +get line (geraet); +IF NOT exists (geraet) +THEN errorstop ("Endgerät nicht vorhanden") FI; + +insert ("GRAPHIK.Picfile"); +insert ("GRAPHIK.Transform"); +insert (geraet); +insert ("GRAPHIK.Plot"); + + + + + diff --git a/system/std.graphik/1.8.7/src/gen Plotter b/system/std.graphik/1.8.7/src/gen Plotter new file mode 100644 index 0000000..73d7b2f --- /dev/null +++ b/system/std.graphik/1.8.7/src/gen Plotter @@ -0,0 +1,16 @@ +TEXT VAR geraet; +page; +out ("Bitte den Namen der Hardwareanpassung (z.B. 'PC.plot') eingeben: "); +get line (geraet); +IF NOT exists (geraet) +THEN errorstop ("Endgerät nicht vorhanden") FI; + +insert ("GRAPHIK.Picfile"); +insert ("GRAPHIK.Transform"); +insert (geraet); +insert ("GRAPHIK.Plotter"); +insert ("GRAPHIK.Server") + + + + diff --git a/system/std.graphik/1.8.7/src/graphik editor b/system/std.graphik/1.8.7/src/graphik editor new file mode 100644 index 0000000..7aa6e33 --- /dev/null +++ b/system/std.graphik/1.8.7/src/graphik editor @@ -0,0 +1,324 @@ +PACKET graphic editor DEFINES graphic, (*Autor: H.Indenbirken *) + picfile, picture, (*Stand: 26.02.1985 *) + + neu zeichnen, + + UP, DOWN, T, + + pen, select pen, selected pen, background, + extrema pic, extrema picfile: + + + +LET norm cmd = ""1""27""3""10""9"epb"16"", + hop cmd = ""2""10""12""1"", + bell = ""7"", + esc = ""27""; + +PICFILE VAR p; +PICTURE VAR pic; +TEXT VAR command :: "", old command :: "", char, headline :: ""; +BOOL VAR within edit :: FALSE, new plot :: FALSE; +ROW 3 ROW 2 REAL VAR size; +ROW 2 ROW 2 REAL VAR limits; +ROW 4 REAL VAR angles; +ROW 2 REAL VAR oblique; +ROW 3 REAL VAR perspective; + +PROC open graphic (TEXT CONST name, DATASPACE CONST ds): + p := ds; + get values (p, size, limits, angles, oblique, perspective); + head line := ""1""15"LEN ................................ DIM PEN .."14" Picture "15""14""; + replace (head line, 32-LENGTH name DIV 2, name); + new plot := TRUE; + within edit := TRUE +END PROC open graphic; + +PROC graphic: + graphic (last param) +END PROC graphic; + +PROC graphic (TEXT CONST name) : + IF NOT exists (name) + THEN IF yes ("Soll ein neuer Picfile eingerichtet werden") + THEN graphic (new (name), name) FI + ELSE graphic (old (name), name) FI + +END PROC graphic; + +PROC graphic (DATASPACE CONST f, TEXT CONST name) : + open graphic (name, f); + reset; + kommandos bearbeiten; + within edit := FALSE . + +kommandos bearbeiten : + REP IF new plot + THEN plot (p); + new plot := FALSE + FI; + read picture (p, pic); + out head line; + inchar (command); + do command + PER . + +out head line: + replace (headline, 7, text (length (pic), 5)); + replace (headline, 50, text (dim (pic), 1)); + replace (headline, 57, text (pen (pic), 2)); + replace (headline, 72, text (picture no (p), 4)); + out (head line) . + +do command: + SELECT pos (norm cmd, command) OF + CASE 1: hop commands + CASE 2: escape commands + CASE 3: position up + CASE 4: position down + CASE 5: position direct + CASE 6: extrema pic + CASE 7: selected pen (pen (pic)); + CASE 8: out (1, 2, ""15""5"Hintergrundfarbe: " + + colour of (background (p)) + " "14"") + CASE 9: identify (pic); + OTHERWISE out (bell) ENDSELECT . + +position up : + IF is first picture (p) + THEN out (bell); + ELSE up (p) FI . + +position down : + IF eof (p) + THEN out (bell) + ELSE down (p) FI . + +position direct: + out (1, 68, ""); + edit get (command, 4, 4); + to pic (p, int (command)) . + +hop commands : + inchar (command); + SELECT pos (hop cmd, command) OF + CASE 1: to first pic (p) + CASE 2: to eof (p) + CASE 3: delete picture (p); + IF NOT new plot + THEN erase (pic) FI + CASE 4: new plot := TRUE + OTHERWISE out (bell) ENDSELECT . + +escape commands : + inchar (command); + IF command = "q" + THEN LEAVE kommandos bearbeiten + ELIF command = "f" + THEN do (old command) + ELIF command = esc + THEN kommandomodus + ELSE do (kommando auf taste (command)) FI . + +END PROC graphic; + +PROC kommandomodus: + command := ""; + disable stop; + REP get command; + do (command) + UNTIL command executed PER; + + IF new values + THEN get values (size, limits, angles, oblique, perspective); + set values (p, size, limits, angles, oblique, perspective); + new plot := new plot OR new values + FI . + +get command: + REP out (1, 2, ""15"Gib Graphikkommando: "); + edit get (command, 0, 54, "", "k", char); + out (""14""); + out (1, 2, ""5""); + + IF char = ""13"" + THEN LEAVE get command + ELIF char = ""27"k" + THEN command := old command FI + PER . + +command executed: + IF is error + THEN out (1, 1, error message); + clear error; + FALSE + ELSE old command := command; + TRUE + FI . + +END PROC kommandomodus; + +PROC out (INT CONST x, y, TEXT CONST t): + cursor (x, y); + out (t) +END PROC out; + +TEXT PROC colour of (INT CONST colour): + SELECT colour OF + CASE 0: "löschen" + CASE 1: "std" + CASE 2: "rot" + CASE 3: "blau" + CASE 4: "grün" + CASE 5: "schwarz" + CASE 6: "weiß" + OTHERWISE text (colour) ENDSELECT . +END PROC colour of; + +TEXT PROC linetype of (INT CONST linetype): + SELECT linetype OF + CASE 0: "unsichtbar" + CASE 1: "durchgehend" + CASE 2: "gepunktet" + CASE 3: "kurz gestrichelt" + CASE 4: "lang gestrichelt" + CASE 5: "strichpunkt" + OTHERWISE text (linetype) ENDSELECT . +END PROC linetype of; + +PICFILE PROC picfile : + IF NOT within edit + THEN errorstop ("Not within editmode") FI; + p +END PROC picfile; + +PICTURE PROC picture : + IF NOT within edit + THEN errorstop ("Not within editmode") FI; + pic +END PROC picture; + +PROC neu zeichnen: + new plot := TRUE +END PROC neu zeichnen; + +OP UP (INT CONST distance): + up (p, distance); + read picture (p, pic) +END OP UP; + +OP DOWN (INT CONST distance): + down (p, distance); + read picture (p, pic) +END OP DOWN; + +OP T (INT CONST n): + to pic (p, n); + read picture (p, pic) +END OP T; + +PROC pen (INT CONST n): + IF NOT new plot + THEN erase (pic) FI; + + pen (pic, n); + write picture (p, pic); + + IF NOT new plot + THEN show (pic) FI +END PROC pen; + +PROC select pen (INT CONST n, colour, thickness, linetype, BOOL CONST hidden): + select pen (p, n, colour, thickness, linetype, hidden); + new plot := TRUE +END PROC select pen; + +PROC select pen (INT CONST n, colour, thickness, linetype): + select pen (p, n, colour, thickness, linetype, FALSE); + new plot := TRUE +END PROC select pen; + +PROC selected pen (INT CONST n, INT VAR colour, thickness, linetype, + BOOL VAR hidden): + selected pen (p, n, colour, thickness, linetype, hidden); +END PROC selected pen; + +PROC selected pen (INT CONST n): + INT VAR colour, thickness, linetype; + BOOL VAR hidden; + selected pen (p, n, colour, thickness, linetype, hidden); + out (1, 2, ""5""15"PEN #" + text (n) + ": Farbe: " + colour of (colour) + + ", Dicke " + text (thickness) + ", Linientyp " + linetype of (linetype) + + hidden text + " "14"") . + +hidden text: + IF hidden + THEN ". " + ELSE ", nicht sichtbare Linien werden unterdrückt." FI . + +END PROC selected pen; + +INT PROC background: + background (p) +END PROC background; + +PROC background (INT CONST n): + new plot := n <> background (p); + background (p, n) +END PROC background; + +PROC extrema pic: + REAL VAR x min, x max, y min, y max, z min, z max; + IF dim (pic) = 2 + THEN extrema (pic, x min, x max, y min, y max); + out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) + + "] [" + text (y min) + "," + text (y max) + "] "14"") + ELSE extrema (pic, x min, x max, y min, y max, z min, z max); + out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) + + "] [" + text (y min) + "," + text (y max) + + "] [" + text (z min) + "," + text (z max) +"] "14"") + FI +END PROC extrema pic; + +PROC extrema picfile: + REAL VAR x min, x max, y min, y max, z min, z max; + extrema (p, x min, x max, y min, y max, z min, z max); + out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) + + "] [" + text (y min) + "," + text (y max) + + "] [" + text (z min) + "," + text (z max) +"] "14"") +END PROC extrema picfile; + +PROC identify (PICTURE CONST pic): + begin plot; + hidden lines (TRUE); + pen (background (p), 1, 1, 2); + plot (pic); + end plot +END PROC identify; + +PROC erase (PICTURE CONST pic): + INT VAR colour, thickness, linetype; + BOOL VAR hidden; + + selected pen (p, pen (pic), colour, thickness, linetype, hidden); + begin plot; + hidden lines (TRUE); + pen (background (p), 0, thickness, linetype); + plot (pic); + end plot +END PROC erase; + +PROC show (PICTURE CONST pic): + INT VAR colour, thickness, linetype; + BOOL VAR hidden; + + selected pen (p, pen (pic), colour, thickness, linetype, hidden); + begin plot; + hidden lines (TRUE); + pen (background (p), colour, thickness, linetype); + plot (pic); + end plot +END PROC show; + +END PACKET graphic editor; + diff --git a/system/std.zusatz/1.8.7/source-disk b/system/std.zusatz/1.8.7/source-disk new file mode 100644 index 0000000..085c0a7 --- /dev/null +++ b/system/std.zusatz/1.8.7/source-disk @@ -0,0 +1 @@ +grundpaket/04_std.zusatz.img diff --git a/system/std.zusatz/1.8.7/src/AT Generator b/system/std.zusatz/1.8.7/src/AT Generator new file mode 100644 index 0000000..d3bfd6d --- /dev/null +++ b/system/std.zusatz/1.8.7/src/AT Generator @@ -0,0 +1,135 @@ +(*************************************************************************) +(*** Generiert Für IBM-AT einen neuen SYSUR-Zweig. ***) +(*** Danach wird die eingebaute Hardwareuhr für die Systemzeit benutzt ***) +(*** und andere Partitionen können mit neuem 'shutup' gebootet werden. ***) +(*** ***) +(*** Autor : W. Sauerwein Stand : 15.07.86 ***) +(*************************************************************************) + +LET ack = 0, + nak = 1; + +cl eop (1, 4); +erzeuge collector; +erzeuge archive manager; +erzeuge operator; +erzeuge configurator; +loesche collector; +forget ("AT Generator", quiet); +break. + +loesche collector : + end (/"colly"); + put ("Collector gelöscht."); + line (2). + +erzeuge collector : + put line ("Generating 'Collector'..."); + begin ("colly", PROC generate collector, t); + warte auf meldung; + IF answer = nak THEN end (/"colly"); + errorstop (meldung) + FI. + TASK VAR t. + +erzeuge archive manager : + put line ("Generating 'ARCHIVE'..."); + end (/"ARCHIVE"); + begin ("ARCHIVE", PROC archive manager, t). + +erzeuge operator : + put line ("Generating 'OPERATOR'..."); + end (/"OPERATOR"); + begin ("OPERATOR", PROC monitor, t). + +erzeuge configurator : + put line ("Generating 'configurator'..."); + end (/"configurator"); + begin ("configurator", PROC generate configurator, t); + warte auf meldung; + IF answer = nak THEN errorstop (meldung) FI. + +warte auf meldung : + DATASPACE VAR ds; INT VAR answer; + wait (ds, answer, t); + BOUND TEXT VAR m := ds; + TEXT VAR meldung := m; + forget (ds). + +PROC generate collector : + + disable stop; + fetch all (/"configurator"); + DATASPACE VAR ds := nilspace; + BOUND TEXT VAR m := ds; m := ""; + send (father, mess, ds); + forget (ds); + free global manager. + +mess : IF is error THEN m := error message; + nak + ELSE ack FI. + +END PROC generate collector; + +PROC generate configurator : + + disable stop; + fetch all (/"colly"); + DATASPACE VAR ds := nilspace; + BOUND TEXT VAR m := ds; m := ""; + send (father, mess, ds); + forget (ds); + enable stop; + new configuration; + setup; + global manager (PROC ( DATASPACE VAR, INT CONST, INT CONST, TASK CONST) + configuration manager with time). + +mess : IF is error THEN m := error message; + nak + ELSE ack FI. + +END PROC generate configurator; + +TEXT PROC inverse (TEXT CONST t): + ""15"" + t + " " + ""14"" +END PROC inverse; + +PROC put center (TEXT CONST t): + put center (t, 80) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t): + put center (zeile, t, 80) +END PROC put center; + +PROC put center (TEXT CONST t, INT CONST gesamtbreite): + INT VAR cy; + get cursor (cy, cy); + put center (cy, t, gesamtbreite) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite): + cursor ((gesamtbreite - length (t)) DIV 2, zeile); + put (t). +END PROC put center; + +PROC cl eol: + out (""5"") +END PROC cl eol; + +PROC cl eop: + out (""4"") +END PROC cl eop; + +PROC cl eol (INT CONST cx, cy): + cursor (cx, cy); + cl eol +END PROC cl eol; + +PROC cl eop (INT CONST cx, cy): + cursor (cx, cy); + cl eop +END PROC cl eop; + diff --git a/system/std.zusatz/1.8.7/src/AT Utilities b/system/std.zusatz/1.8.7/src/AT Utilities new file mode 100644 index 0000000..760e728 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/AT Utilities @@ -0,0 +1,1057 @@ +(*************************************************************************) +(*** AT-spezifische Software, die zum Lesen der Hardwareuhr und ***) +(*** Booten in anderen Partitionen benötigt wird. ***) +(*** ***) +(*** Zusammengestellt und geändert : Werner Sauerwein, GMD ***) +(*** Stand : 31.10.86 ***) +(*************************************************************************) + +PACKET splitting DEFINES low byte, (* Copyright (C) 1985 *) + high byte, (* Martin Schönbeck, Spenge *) + low word, (* Stand: 13.09.85 *) + high word: + +INT PROC high byte (INT CONST value): + + TEXT VAR x := " "; + replace (x, 1, value); + code (x SUB 2) + +END PROC high byte; + +INT PROC low byte (INT CONST value): + + TEXT VAR x := " "; + replace (x, 1, value); + code (x SUB 1) + +END PROC low byte; + +INT PROC high word (REAL CONST double precission int): + + int (double precission int / 65536.0) + +END PROC high word; + +INT PROC low word (REAL CONST double precission int): + + string of low bytes ISUB 1. + +string of low bytes: + code (int (double precission int MOD 256.0)) + + code (int ((double precission int MOD 65536.0) / 256.0)). + +END PROC low word; + +END PACKET splitting; + + +PACKET basic block io DEFINES + + read block, + write 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 block no, + INT VAR return code): + write block; + retry if write error. + +write block: + block out (ds, ds page no, 0, 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; + +PROC read block (DATASPACE VAR ds, INT CONST ds page, + REAL CONST archive block): + + enable stop; + read block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht gelesen werden"); + CASE 2: error stop ("Lesefehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + +END PROC read block; + +PROC write block (DATASPACE CONST ds, INT CONST ds page, + REAL CONST archive block): + + enable stop; + write block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht geschrieben werden"); + CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + +END PROC write block; + +PROC read block (DATASPACE VAR ds, + INT CONST ds page no, + REAL CONST block no, + INT VAR return code): + read block; + retry if read error. + +read block: + block in (ds, ds page no, high word (block no), + low word (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, + REAL CONST block no, + INT VAR return code): + write block; + retry if write error. + +write block: + block out (ds, ds page no, high word (block no), + low word (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; + +END PACKET basic block io; + + +PACKET utilities DEFINES getchoice, cleol, cleop, inverse, put center: + +INT PROC get choice (INT CONST von, bis, TEXT VAR retchar): + get choice (von, bis, von, retchar) +END PROC get choice; + +INT PROC get choice (INT CONST von, bis, zusatz, TEXT VAR retchar): + LET return = ""13"", + escape = ""27"", + left = ""8""; + TEXT VAR buffer; + INT VAR cx, cy; + get cursor (cx, cy); out (" " + left); + REP + REP + cursor (cx, cy); buffer := incharety; + UNTIL input ok OR buffer = escape PER; + IF buffer = escape THEN retchar := escape; + LEAVE get choice WITH 0 + FI; + out (buffer); + leseschleife bis left or ret; + IF retchar = left THEN out (left + " ") FI; + IF retchar = escape THEN LEAVE get choice WITH 0 FI + UNTIL retchar = return OR retchar = escape PER; + int (buffer). + +input ok : (buffer >= text (von) AND buffer <= text (bis)) OR buffer = text (zusatz). + +leseschleife bis left or ret: + REP + inchar (retchar) + UNTIL retchar = return OR retchar = left OR retchar = escape PER. + +END PROC get choice; + +PROC cl eol (INT CONST cx, cy): + cursor (cx, cy); + cl eol +END PROC cl eol; + +PROC cl eop (INT CONST cx, cy): + cursor (cx, cy); + cl eop +END PROC cl eop; + + +PROC cl eol: + out (""5"") +END PROC cl eol; + +PROC cl eop: + out (""4"") +END PROC cl eop; + +TEXT PROC inverse (TEXT CONST t): + ""15"" + t + " " + ""14"" +END PROC inverse; + +PROC put center (TEXT CONST t): + put center (t, 80) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t): + put center (zeile, t, 80) +END PROC put center; + +PROC put center (TEXT CONST t, INT CONST gesamtbreite): + INT VAR cy; + get cursor (cy, cy); + put center (cy, t, gesamtbreite) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite): + cursor ((gesamtbreite - length (t)) DIV 2, zeile); + put (t). +END PROC put center; + +END PACKET utilities + + +PACKET part DEFINES activate, show actual partition table: + (* Copyright (C) 1985 *) + (* Martin Schönbeck, Spenge *) + (* Stand : 02.02.86 *) + (* Changed by : W.Sauerwein *) + (* I.Ley *) + (* Stand : 03.10.86 *) + LET fd channel = 28; + +ROW 256 INT VAR boot block; +INT VAR boot block session := session - 1; + +PROC get boot block: + IF boot block session <> session + THEN hole aktuellen boot block + FI. + +hole aktuellen boot block: + disable stop; + DATASPACE VAR dummy ds := nilspace; + BOUND STRUCT (ALIGN dummy, + ROW 256 INT block) VAR partition table := dummy ds; + get external block (dummy ds, 2, 0, fd channel); + IF NOT is error + THEN transfer data to boot block + FI; + forget (dummy ds). + +transfer data to boot block: + IF not valid boot block + THEN try to get valid boot block from file + FI; + boot block := partition table. block; + boot block session := session. + +not valid boot block: + partition table. block [256] <> boot indicator OR + it is an old boot block of eumel. + +boot indicator: -21931. + +it is an old boot block of eumel: + partition table. block [1] = 1514. + +try to get valid boot block from file: + forget (dummy ds); + partition table := old ("bootblock"); + IF is error THEN LEAVE transfer data to boot block FI. + +END PROC get boot block; + +PROC put boot block: + IF boot block ist uptodate + THEN schreibe block auf platte + ELSE errorstop ("boot block nicht uptodate") + FI. + +boot block ist uptodate: + boot block session = session. + +schreibe block auf platte: + disable stop; + DATASPACE VAR dummy ds := nilspace; + BOUND STRUCT (ALIGN dummy, + ROW 256 INT block) VAR partition table := dummy ds; + transfer data to dataspace; + put external block (dummy ds, 2, 0, fd channel); + forget (dummy ds). + +transfer data to dataspace: + partition table. block := boot block. + +END PROC put boot block; + +INT PROC partition type (INT CONST partition): + low byte (boot block [entry (partition) + 2]) +END PROC partition type; + +REAL PROC partition start (INT CONST partition): + unsigned low word + high word. + +unsigned low word: + real (low byte (boot block [entry (partition) + 4])) + + real (high byte (boot block [entry (partition) + 4])) * 256.0. + +high word: + real (boot block [entry (partition) + 5]). + +END PROC partition start; + +INT PROC partition word 0 (INT CONST partition): + boot block (entry (partition)) +END PROC partition word 0; + +INT PROC first track (INT CONST partition): + high byte (boot block [entry (partition) + 1]) + + 4 * (low byte (boot block [entry (partition) + 1]) AND (128 + 64)) +END PROC first track; + +INT PROC last track (INT CONST partition): + high byte (boot block [entry (partition) + 3]) + + 4 * (low byte (boot block [entry (partition) + 3]) AND (128 + 64)) +END PROC last track; + +BOOL PROC partition activ (INT CONST partition): + low byte (boot block [entry (partition)]) = 128 +END PROC partition activ; + +REAL PROC partition size (INT CONST partition): + unsigned low word + high word. + +unsigned low word: + real (low byte (boot block [entry (partition) + 6])) + + real (high byte (boot block [entry (partition) + 6])) * 256.0. + +high word: + real (boot block [entry (partition) + 7]). + +END PROC partition size; + +INT PROC tracks: + get value (-10, fd channel) +END PROC tracks; + +PROC activate (INT CONST part type): + IF partition type exists AND is possible type + THEN deactivate all partitions and + activate desired partition + ELSE errorstop ("Gewünschte Partitionart gibt es nicht") + FI. + +is possible type: + part type > 0 AND + part type < 256. + +partition type exists: + INT VAR partition; + FOR partition FROM 1 UPTO 4 REP + IF partition type (partition) = part type + THEN LEAVE partition type exists WITH TRUE + FI; + PER; + FALSE. + +deactivate all partitions and activate desired partition: + FOR partition FROM 1 UPTO 4 REP + deactivate this partition; + IF partition type (partition) = part type + THEN activate partition + FI + PER; + put boot block. + +deactivate this partition: + set bit (boot block [entry (partition)], 7); + (* first setting needed, because reset bit does xor *) + reset bit (boot block [entry (partition)], 7). + +activate partition: + set bit (boot block [entry (partition)], 7) + +END PROC activate; + +INT PROC entry (INT CONST partition): + get boot block; + 256 - 5 * 8 + (partition * 8) +END PROC entry; + +INT PROC get value (INT CONST control code, channel for value): + enable stop; + INT VAR old channel := channel; + continue (channel for value); + INT VAR value; + control (control code, 0, 0, value); + continue (old channel); + value +END PROC get value; + +PROC get external block (DATASPACE VAR ds, INT CONST ds page, + archive block, get channel): + INT VAR old channel := channel; + continue (get channel); + disable stop; + read block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht gelesen werden"); + CASE 2: error stop ("Lesefehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + continue (old channel). +END PROC get external block; + +PROC put external block (DATASPACE CONST ds, INT CONST ds page, + archive block, get channel): + INT VAR old channel := channel; + continue (get channel); + disable stop; + write block (ds, ds page, archive block, error); + INT VAR error; + SELECT error OF + CASE 0: + CASE 1: error stop ("Platte kann nicht geschrieben werden"); + CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block)); + CASE 3: error stop ("Versorgungsfehler Archiv"); + OTHERWISE error stop ("unbekannter Fehler auf Platte"); + END SELECT; + continue (old channel). +END PROC put external block; + +(**************************************************************************) + + LET max partitions = 4; + ROW max partitions INT VAR part list; + ROW max partitions INT VAR part type, part active, + part first track, part last track; + ROW max partitions REAL VAR part start, + part size; + INT VAR zylinder, + startzeile tabelle :: 1, + active partition, + partitions, + partition, i, j, help; + + +PROC get actual partition data : + get boot block; + zylinder := tracks; + FOR i FROM 1 UPTO max partitions REP + part type (i) := partition type (i); + part first track (i) := first track (i); + part last track (i) := last track (i); + part start (i) := partition start (i); + part size (i) := partition size (i); + part active (i) := partition word 0 (i); + IF partition activ (i) THEN active partition := i FI + PER; + get number of installed partitions; + generate part list. + +get number of installed partitions : + partitions := 0; + FOR i FROM 1 UPTO max partitions REP + IF part type (i) <> 0 THEN partitions INCR 1 FI + PER. + +generate part list : + FOR i FROM 1 UPTO max partitions REP + IF part type (i) <> 0 THEN part list (i) := i + ELSE part list (i) := 0 + FI; + PER; + schiebe nullen nach hinten; + sort part list. + +schiebe nullen nach hinten : + i := 1; INT VAR k := 0; + REP k INCR 1; + IF part list (i) = 0 THEN circle + ELSE i INCR 1 + FI + UNTIL k = max partitions - 1 PER. + +circle : + FOR j FROM i UPTO max partitions - 1 REP + part list (j) := part list (j + 1) + PER; + part list (max partitions) := 0. + +sort part list : + FOR i FROM 2 UPTO partitions REP + FOR j FROM 1 UPTO i - 1 REP + IF part first track (part list (i)) < part first track (part list (j)) + THEN tausche FI + PER + PER. + +tausche : + help := part list (i); + part list (i) := part list (j); + part list (j) := help. + +END PROC get actual partition data; + + +PROC show partition table : + headline; + devide table; + columns; + underlines; + rows; + footlines. + +head line : + cl eop (1, startzeile tabelle); + put center (inverse (" " + + "Aktuelle Partitions - Tabelle" + + " ")). + +devide table : + FOR i FROM 1 UPTO 8 + REP + cursor (50, startzeile tabelle + i); out (inverse ("")) + PER. + +columns : + cursor ( 1, startzeile tabelle + 2); + out (" Nr. System Typ-Nr. Zustand Größe Start Ende"); + cursor (54, startzeile tabelle + 2); + out ("Plattengröße / Zylinder "). + +underlines : + cursor ( 1, startzeile tabelle + 3); + out ("-------------------------------------------------"); + cursor (52, startzeile tabelle + 3); + out ("--------------------------"). + +rows : + FOR i FROM 1 UPTO max partitions + REP cursor (2, startzeile tabelle + 3 + i); + put (text (i) + " :") + PER. + +footlines: + cursor (1, startzeile tabelle + 9); + put center (inverse (75 * " ")). + +END PROC show partition table; + +PROC update table : + get actual partition data; + FOR i FROM 1 UPTO partitions REP update partition PER; + FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER; + zeige plattengroesse. + +update partition : + partition := part list (i); + show partition. + +rubout partition : + cursor (6, startzeile tabelle + 3 + i); + out (" "). + +show partition : + cursor (6, startzeile tabelle + 3 + i); + put (name + type + zustand + groesse + startspur + endspur). + +name : subtext (subtext (part name, 1, 9) + + " ", 1, 10). + +type : text (part type (partition), 5) + " ". + +zustand : IF active partition = partition THEN (" aktiv ") + ELSE (" ") + FI. + +startspur : " " + text (part first track (partition), 5). +endspur : text (part last track (partition), 6). +groesse : text (part groesse, 5). + +zeige plattengroesse : + put gesamt; + put noch freie; + put maximaler zwischenraum. + +put maximaler zwischenraum : + cursor (54, startzeile tabelle + 6); + put ("max. zusammenh. : " + text (maximaler zwischenraum, 4)). + +put gesamt : + cursor (54, startzeile tabelle + 4); + put ("insgesamt : " + text (zylinder, 4)). + +put noch freie : + cursor (54, startzeile tabelle + 5); + put ("davon noch frei : " + text (freie zylinder, 4)). + +part groesse : + partition groesse (partition). + +part name : + SELECT part type (partition) OF + CASE 1 : "DOS" + CASE 69, 70, 71, 72 : "EUMEL" + OTHERWISE text (part type (partition)) + END SELECT. + +freie zylinder : + zylinder - belegte zylinder. + +belegte zylinder : + help := 0; + FOR i FROM 1 UPTO partitions REP + help INCR partition groesse (part list (i)) + PER; + help. + +END PROC update table; + +INT PROC maximaler zwischenraum : + IF partitions = 0 THEN zylinder + ELSE max (maximaler platz vor und zwischen den partitionen, + platz hinter letzter partition) + FI. + +maximaler platz vor und zwischen den partitionen : + help := platz vor erster partition; + FOR i FROM 1 UPTO partitions - 1 + REP + help := max (help, begin of part i plus 1 - end of part i - 1) + PER; + help. + +platz vor erster partition : + part first track (part list (1)). + +platz hinter letzter partition : + zylinder - part last track (part list (partitions)) - 1. + +begin of part i plus 1 : + part first track (part list (i + 1)). + +end of part i : + part last track (part list (i)). + +END PROC maximaler zwischenraum; + +INT PROC partition groesse (INT CONST part) : + part last track (part) - part first track (part) + 1 +END PROC partition groesse; + +PROC show actual partition table: + show partition table; + update table; + line (4) +END PROC show actual partition table; + +PROC show actual partition table (ROW max partitions INT VAR typnr): + show actual partition table; + FOR i FROM 1 UPTO max partitions REP + typnr (i) := partition type (part list (i)) + PER; +END PROC show actual partition table; + +END PACKET part; + + +PACKET hw clock DEFINES hw clock: (* Copyright (C) 1985 *) + (* Martin Schönbeck, Spenge *) +LET clock length = 7, (* Stand: 06.11.85 *) + clock command = 4; + +BOUND STRUCT (ALIGN dummy, + ROW clock length INT clock field) VAR clock data; + +REAL PROC hw clock: + + disable stop; + get clock; + hw date + hw time. + +get clock: + DATASPACE VAR ds := nilspace; + clock data := ds; + INT VAR return code, actual channel := channel; + go to shard channel; + blockin (ds, 2, -clock command, 0, return code); + IF actual channel = 0 THEN break (quiet) + ELSE continue (actual channel) + FI; + IF return code <> 0 + THEN errorstop ("Keine Hardware Uhr vorhanden"); + FI; + put clock into text; + forget (ds). + +put clock into text: + TEXT VAR clock text := clock length * " "; + INT VAR i; + FOR i FROM 1 UPTO clock length REP + replace (clock text, i, clock data. clock field [i]); + PER. + +go to shard channel: + INT VAR retry; + FOR retry FROM 1 UPTO 20 REP + continue (32); + IF is error + THEN clear error; + pause (30) + FI; + UNTIL channel = 32 PER. + +hw date: + date (day + "." + month + "." + year). + +day: subtext (clock text, 7, 8). + +month: subtext (clock text, 5, 6). + +year: subtext (clock text, 1, 4). + +hw time: + time (hour + ":" + minute + ":" + second). + +hour: subtext (clock text, 9, 10). + +minute: subtext (clock text, 11, 12). + +second: subtext (clock text, 13, 14). + +END PROC hw clock; + +END PACKET hw clock + + +PACKET old shutup DEFINES old shutup, (* Copyright (C) 1985 *) + old save system: (* Martin Schönbeck, Spenge *) + (* Stand: 06.11.85 *) +PROC old shutup : shutup END PROC old shutup; + +PROC old save system : save system END PROC old save system; + +END PACKET old shutup; + + +PACKET new shutup DEFINES shutup, + shutup dialog, + save system, + generate shutup manager, + generate shutup dialog manager: + +LET ack = 0; + +PROC shutup: + + system down (PROC old shutup) + +END PROC shutup; + +PROC shutup (INT CONST new system): + + IF new system <> 0 + THEN prepare for new system + FI; + system down (PROC old shutup). + +prepare for new system: + activate (new system); + prepare for rebooting. + +prepare for rebooting: + INT VAR old channel := channel; + continue (32); + INT VAR dummy; + control (-5, 0, 0, dummy); + break (quiet); + continue (old channel). + +END PROC shutup; + +PROC save system: + + IF yes ("Leere Floppy eingelegt") + THEN system down (PROC old save system) + FI + +END PROC save system; + +PROC system down (PROC operation): + + BOOL VAR dialogue :: command dialogue; + command dialogue (FALSE); + operation; + command dialogue (dialogue); + IF command dialogue + THEN wait for configurator; + show date; + FI. + +show date: + page; + line (2); + put (" Heute ist der"); putline (date); + put (" Es ist"); put (time of day); putline ("Uhr"); + line (2). + +END PROC system down; + +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). + +END PROC wait for configurator; + +PROC generate shutup manager: + + generate shutup manager ("shutup", 0); + +END PROC generate shutup manager; + +PROC generate shutup manager (TEXT CONST name, INT CONST new system): + + TASK VAR son; + shutup question := name; + new system for manager := new system; + begin (name, PROC shutup manager, son) + +END PROC generate shutup manager; + +INT VAR new system for manager; +TEXT VAR shutup question; + +PROC shutup manager: + + disable stop; + command dialogue (TRUE); + REP + break; + line ; + IF yes (shutup question) + THEN clear error; + shutup (new system for manager); + pause (300); + FI; + PER + +END PROC shutup manager; + +PROC shutup dialog: + init; + show actual partition table (typnr); + REP + enter part number; + get cursor (cx, cy); + IF NOT escaped CAND yes (shutup question) + THEN message; + shutup (partition type); + LEAVE shutup dialog + FI; + PER. + +shutup question: + IF partition null + THEN "Shutup ausführen" + ELSE "Shutup nach Partition mit Typnummer " + text (typnr (partition)) + " ausführen" + FI. + +message: + cl eol (1, cy); + put line ("Bitte auf ENDE - Meldung warten !"). + +partition type: + IF partition = 0 + THEN 0 + ELSE typnr (partition) + FI. + +init: + LET startzeile menu = 12, + escape = ""27"", + max partitions = 4; + + ROW max partitions INT VAR typnr; + INT VAR partition, cx, cy; + TEXT VAR retchar. + +partition null: + partition = 0 COR typnr (partition) = 0. + +enter part number : + cl eop (1, startzeile menu); + cursor (54, startzeile menu ); put ("Abbruch mit <ESC>"); + cursor (54, startzeile menu + 1); put ("Shutup ohne Wechsel mit <0>"); + cursor ( 1, startzeile menu); + put ("Zu welcher Partition wollen Sie wechseln :"); + get cursor (cx, cy); + REP + REP cursor (cx, cy); + partition := get choice (0, 4, retchar); + IF sure escaped THEN LEAVE shutup dialog FI; + UNTIL NOT escaped PER; + IF partition <> 0 CAND NOT partition exists + THEN fehler; + put ("Diese Partition gibt es nicht") + FI; + UNTIL partition = 0 OR partition exists PER; + cl eol (54, startzeile menu); + cl eol (54, startzeile menu + 1); + cl eop (1, cy + 2). + +partition exists: + typnr (partition) <> 0. + +escaped : + retchar = escape. + +sure escaped : + IF escaped THEN cl eop (1, 20); cursor (1, 22); + IF yes ("Shutup-Dialog abbrechen") THEN TRUE + ELSE cl eop (1, 20); + FALSE + FI + ELSE FALSE + FI. + +fehler : + cl eop (1, 20); + put (""7"" + inverse ("FEHLER :")); line (2). + +END PROC shutup dialog; + +PROC generate shutup dialog manager: + TASK VAR son; + begin ("shutup dialog", PROC shutup dialog manager, son) +END PROC generate shutup dialog manager; + +PROC shutup dialog manager: + disable stop; + command dialogue (TRUE); + REP + break; line; + clear error; + INT VAR sess := session; + shutup dialog; + IF sess <> session THEN pause (300) FI; + PER; +END PROC shutup dialog manager; + +END PACKET new shutup + + +PACKET config manager with time DEFINES configuration manager , + configuration manager with time : + (* Copyright (C) 1985 *) +INT VAR old session := 0; (* Martin Schönbeck, Spenge *) + (* Stand: 06.11.85 *) +PROC configuration manager: + + configurate; + break; + global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) + configuration manager with time) + +END PROC configuration manager; + +PROC configuration manager with time (DATASPACE VAR ds, INT CONST order, + phase, TASK CONST order task): + + IF old session <> session + THEN + disable stop; + set clock (hw clock); + set clock (hw clock); (* twice, to avoid all paging delay *) + IF is error THEN IF online THEN put error; clear error; pause (100) + ELSE clear error + FI FI; + old session := session; + set autonom; + FI; + configuration manager (ds, order, phase, order task); + +END PROC configuration manager with time; + +END PACKET config manager with time; + diff --git a/system/std.zusatz/1.8.7/src/AT install b/system/std.zusatz/1.8.7/src/AT install new file mode 100644 index 0000000..11f9b55 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/AT install @@ -0,0 +1,93 @@ +(*************************************************************************) +(*** Insertiert alle notwendigen Pakete, damit ein AT-System generiert ***) +(*** werden kann, das die Hardwareuhr lesen und Partitionen bedienen ***) +(*** kann. Startet den "AT Generator". ***) +(*** ***) +(*** Autor : W. Sauerwein Stand : 15.07.86 ***) +(*************************************************************************) + +erste bildschirmmeldung; +IF ich bin single THEN putline ("Die AT-spezifische Software ist nur auf Multi-User-Systemen benutzbar !") + ELSE hole dateien vom archiv; + insertiere alle pakete; + put line ("Running ""AT Generator""..."); + run ("AT Generator") +FI; +forget ("AT install", quiet). + +ich bin single : (pcb (9) AND 255) <= 1. + +insertiere alle pakete : + insert and say ("AT Utilities"). + +erste bildschirmmeldung : + page; + put center (" Generator für AT-spezifische Software gestartet."); line; + put center ("--------------------------------------------------"); + line (2). + +hole dateien vom archiv : + TEXT VAR datei; + datei := "AT Utilities"; hole wenn noetig; + datei := "AT Generator"; hole wenn noetig; + release (archive); + line. + +hole wenn noetig : + IF NOT exists (datei) THEN + put line ("Loading """ + datei + """..."); + fetch (datei, archive) + FI. + +PROC insert and say (TEXT CONST datei) : + + INT VAR cx, cy; + put line ("Inserting """ + datei + """..."); + get cursor (cx, cy); + insert (datei); + cl eop (cx, cy); line; + forget (datei, quiet). + +END PROC insert and say; + +TEXT PROC inverse (TEXT CONST t): + ""15"" + t + " " + ""14"" +END PROC inverse; + +PROC put center (TEXT CONST t): + put center (t, 80) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t): + put center (zeile, t, 80) +END PROC put center; + +PROC put center (TEXT CONST t, INT CONST gesamtbreite): + INT VAR cy; + get cursor (cy, cy); + put center (cy, t, gesamtbreite) +END PROC put center; + +PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite): + cursor ((gesamtbreite - length (t)) DIV 2, zeile); + put (t). +END PROC put center; + +PROC cl eol: + out (""5"") +END PROC cl eol; + +PROC cl eop: + out (""4"") +END PROC cl eop; + +PROC cl eol (INT CONST cx, cy): + cursor (cx, cy); + cl eol +END PROC cl eol; + +PROC cl eop (INT CONST cx, cy): + cursor (cx, cy); + cl eop +END PROC cl eop; + diff --git a/system/std.zusatz/1.8.7/src/complex b/system/std.zusatz/1.8.7/src/complex new file mode 100644 index 0000000..e2139d0 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/complex @@ -0,0 +1,115 @@ + +PACKET complex DEFINES COMPLEX,:=,complex zero,complex one,complex i, + complex,realpart,imagpart,CONJ,+,-,*,/,=,<>, + put,get, ABS, sqrt, phi, dphi : + +TYPE COMPLEX = STRUCT(REAL re,im); +COMPLEX PROC complex zero: COMPLEX :(0.0,0.0). END PROC complex zero; +COMPLEX PROC complex one : COMPLEX :(1.0,0.0). END PROC complex one; +COMPLEX PROC complex i : COMPLEX :(0.0,1.0). END PROC complex i; + +OP := (COMPLEX VAR dest, COMPLEX CONST source) : + + CONCR (dest) := CONCR (source) + +ENDOP := ; + +COMPLEX PROC complex(REAL CONST re,im): + COMPLEX :(re,im). +END PROC complex; + +REAL PROC realpart(COMPLEX CONST number): + number.re. +END PROC realpart; + +REAL PROC imagpart(COMPLEX CONST number): + number.im. +END PROC imagpart ; + +COMPLEX OP CONJ(COMPLEX CONST number): + COMPLEX :( number.re,- number.im). +END OP CONJ; + +BOOL OP =(COMPLEX CONST a,b): + IF a.re=b.re + THEN a.im=b.im + ELSE FALSE + FI. +END OP =; + +BOOL OP <>(COMPLEX CONST a,b): + IF a.re=b.re + THEN a.im<>b.im + ELSE TRUE + FI. +END OP <>; + +COMPLEX OP +(COMPLEX CONST a,b): + COMPLEX :(a.re+b.re,a.im+b.im). +END OP +; + +COMPLEX OP -(COMPLEX CONST a,b): + COMPLEX :(a.re-b.re,a.im-b.im). +END OP -; + +COMPLEX OP *(COMPLEX CONST a,b): + REAL VAR re of a::a.re,im of a ::a.im, + re of b::b.re,im of b ::b.im; + COMPLEX :(re of a*re of b- im of a *im of b, + re of a*im of b+ im of a*re of b). +END OP *; + +COMPLEX OP /(COMPLEX CONST a,b): + REAL VAR re of a::a.re,im of a::a.im, + re of b::b.re,im of b::b.im; + REAL VAR sqare sum of re and im ::b.re*b.re+b.im*b.im; + COMPLEX :( (re of a * re of b + im of a * im of b)/sqare sum of re and im, + (im of a *re of b - re of a*im of b)/sqare sum of re and im). +END OP /; + +PROC get(COMPLEX VAR a): + REAL VAR realpart,imagpart; + get(realpart);get(imagpart); + a:= COMPLEX :(realpart,imagpart); +END PROC get; + +PROC put(COMPLEX CONST a): + put(a.re);put(" ");put(a.im); +END PROC put; + +REAL PROC dphi(COMPLEX CONST x): + IF imagpart(x)=0.0 THEN reell + ELIF realpart(x)=0.0 THEN imag + ELIF realpart(x)>0.0 THEN realpositiv + ELSE realnegativ + FI. +reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI. +imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI. +realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x)) + ELSE +arctand(realpart(x)/imagpart(x))+360.0 FI. +realnegativ: arctand(realpart(x)/imagpart(x))+180.0. +END PROC dphi; + +REAL PROC phi(COMPLEX CONST x): +dphi(x)*3.141592653689793/180.0. +END PROC phi; + +COMPLEX PROC sqrt(COMPLEX CONST x): +IF x=complex zero THEN x +ELIF realpart(x)<0.0 THEN +complex(imagpart(x)/(2.0*real(sign(imagpart(x))) + *sqrt((ABSx-realpart(x))/2.0)), + real(sign(imagpart(x)))*sqrt((ABS x-realpart(x))/2.0)) +ELSE complex(sqrt((ABS x+realpart(x))/2.0), + imagpart(x)/(2.0*sqrt((ABS x+realpart(x))/2.0))) +FI. + +END PROC sqrt; + +REAL OP ABS(COMPLEX CONST x): + sqrt(realpart(x)*realpart(x)+imagpart(x)*imagpart(x)). +END OP ABS; + +END PACKET complex; + diff --git a/system/std.zusatz/1.8.7/src/crypt b/system/std.zusatz/1.8.7/src/crypt new file mode 100644 index 0000000..b04728a --- /dev/null +++ b/system/std.zusatz/1.8.7/src/crypt @@ -0,0 +1,138 @@ +(* ------------------- VERSION 2 vom 21.04.86 ------------------- *) +PACKET cryptograf DEFINES (* Autor: J.Liedtke *) + + crypt , + decrypt : + +TEXT VAR char , in buffer, out buffer ; +INT VAR in pos , key index ; +DATASPACE VAR scratch space ; +FILE VAR in, out; + +PROC crypt (TEXT CONST file, key) : + + open (file) ; + initialize crypt (key) ; + WHILE NOT eof REP + read char ; + crypt char ; + write char + PER ; + close (file) . + +crypt char : + char := code (( character + random char + key char ) MOD 250) ; + IF key index = LENGTH key + THEN key index := 1 + ELSE key index INCR 1 + FI . + +character : code (char) . + +random char : random (0,250). + +key char : code (key SUB key index) . + +ENDPROC crypt ; + +PROC decrypt (TEXT CONST file, key) : + + open (file) ; + initialize crypt (key) ; + WHILE NOT eof REP + read char ; + decrypt char ; + write char + PER ; + close (file) . + +decrypt char : + char := code (( character - random char - key char ) MOD 250) ; + IF key index = LENGTH key + THEN key index := 1 + ELSE key index INCR 1 + FI . + +character : code (char) . + +random char : random (0,250) . + +key char : code (key SUB key index) . + +ENDPROC decrypt ; + +PROC initialize crypt (TEXT CONST key) : + + INT VAR random key := 0 ; + FOR key index FROM 1 UPTO LENGTH key REP + random key := (random key + code (key SUB key index)) MOD 32000 + PER ; + initialize random (random key) ; + key index := 1 + +ENDPROC initialize crypt ; + +PROC open (TEXT CONST source file) : + + in := sequential file (input, source file) ; + getline (in, in buffer) ; + in pos := 1 ; + forget (scratch space) ; + scratch space := nilspace ; + out := sequential file (output, scratch space) ; + out buffer := "" . + +ENDPROC open ; + +PROC close (TEXT CONST source file) : + + IF out buffer <> "" + THEN putline (out, out buffer) + FI ; + forget (source file, quiet) ; + copy (scratch space, source file) ; + forget (scratch space) . + +ENDPROC close ; + +BOOL PROC eof : + + IF in pos > LENGTH in buffer + THEN eof (in) + ELSE FALSE + FI + +ENDPROC eof ; + +PROC read char : + + IF in pos > 250 + THEN getline (in, in buffer) ; + in pos := 1 ; + read char + ELIF in pos > LENGTH in buffer + THEN in pos := 1 ; + getline (in, in buffer) ; + char := ""13"" + ELSE char := in buffer SUB in pos ; + in pos INCR 1 + FI . + +ENDPROC read char ; + +PROC write char : + + IF char = ""13"" + THEN putline (out, out buffer) ; + out buffer := "" + ELSE out buffer CAT char + FI ; + IF LENGTH out buffer = 250 + THEN putline (out, out buffer) ; + out buffer := "" + FI . + +ENDPROC write char ; + +ENDPACKET cryptograf ; + diff --git a/system/std.zusatz/1.8.7/src/eumel printer.5 b/system/std.zusatz/1.8.7/src/eumel printer.5 new file mode 100644 index 0000000..e61a073 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/eumel printer.5 @@ -0,0 +1,3473 @@ +PACKET eumel printer (* Autor : Rudolf Ruland *) + (* Version : 5 *) + (* Stand : 25.04.88 *) + 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, + +(* >>> ***************************************************************** <<< *) +(* >>> Aus Kompatibilitätsgründen zur Textverarbeitung der Version 1.8.0 <<< *) +(* >>> siehe bei 'Berechnung des Zeilenvorschubs' <<< *) + + old linefeed : + +BOOL VAR old linefeed calculation := TRUE; + +PROC old linefeed (BOOL CONST value) : old linefeed calculation := value END PROC old linefeed; + +BOOL PROC old linefeed : old linefeed calculation END PROC old linefeed; + +(* >>> ***************************************************************** <<< *) + +INT CONST int length := length of one int; + +. length of one int : + INT VAR int counter := 0, int value := max int; + REP int counter INCR 1; + int value := int value DIV 256; + UNTIL int value = 0 PER; + int counter +.; + +(* >>> ***************************************************************** <<< *) + +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 = """", + kommentar zeichen = "-", + + punkt = ".", + + leer = 0, + + kommando token = 0, + text token = 1, + + underline linetype = 1, +(* fraction linetype = 2, + root linetype = 3, +*) + 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, + + text code = 1, +(* error code = 2, *) + token code = 3, + + tag type = 1, + bold type = 2, + number type = 3, + text type = 4, + delimiter type = 6, + eof type = 7; + + +INT CONST null ausgang := minint, + erweiterungs ausgang := maxint, + blank ausgang := maxint - 1, + anweisungs ausgang := maxint - 2, + d code ausgang := maxint - 3, + max breite := maxint - 4, + + linien token := -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, fuehrende anweisungen, + einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite, + aktuelle zeilentiefe der letzten zeile, + 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, linien verschiebung, + rest, neue modifikationen, modifikations modus, pass, + + int param, anweisungs index, anzahl params, + + 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 + +. 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; + a block token := FALSE; +.; + +(******************************************************************) + +LET zeilen nr laenge = 4, + teil einrueckung = 5, + + headline pre = "Zeile **** E L A N EUMEL 1.8.2 **** ", + 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, select counter; + +BOOL VAR vor erstem packet, innerhalb einer liste; + +TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile; + + +. symbol : fuell zeichen +. naechstes symbol : d string +. elan text : d token. text +.; + +(******************************************************************) +(*** Berechnung des Zeilenvorschubs ***) + +INT VAR fonthoehe, fonttiefe, fontdurchschuss, + groesste fonthoehe, groesste fonttiefe, + groesste analysatorhoehe, groesste analysatortiefe, + letzte zeilenhoehe, letzte zeilentiefe, + aktuelle zeilenhoehe, aktuelle zeilentiefe; +REAL VAR real fontgroesse; + +. fontgroesse : fonthoehe + fonttiefe +. groesste fontgroesse : groesste fonthoehe + groesste fonttiefe +. letzte zeilengroesse : letzte zeilenhoehe + letzte zeilentiefe +. aktuelle zeilengroesse : aktuelle zeilenhoehe + aktuelle zeilentiefe + +. + initialisiere zeilenvorschub : + aktuelle zeilenhoehe := letzte zeilenhoehe; + aktuelle zeilentiefe := letzte zeilentiefe; + groesste fonthoehe := fonthoehe; + groesste fonttiefe := fonttiefe; + groesste analysatorhoehe := 0; + groesste analysatortiefe := 0; + +. + ueberpruefe groesste fontgroesse : + IF old linefeed calculation + THEN +(* >>> Maximumsbestimmung über Fontgröße ******************************* <<< *) + IF fontgroesse >= groesste fontgroesse + THEN groesste fonthoehe := fonthoehe; + groesste fonttiefe := fonttiefe; + FI; + ELSE +(* >>> Maximumsbestimmung über Fonthöhe und Fonttiefe ****************** <<< *) + groesste fonthoehe := max (fonthoehe, groesste fonthoehe); + groesste fonttiefe := max (fonttiefe, groesste fonttiefe); + FI; + +. + berechne fontgroesse : + fonthoehe INCR (fontdurchschuss DIV 2 + fontdurchschuss MOD 2); + fonttiefe INCR fontdurchschuss DIV 2; + real fontgroesse := real (fontgroesse); + +. + berechne letzte zeilengroesse : + REAL CONST zeilengroesse := real fontgroesse * linefeed faktor; + letzte zeilenhoehe := int (real (fonthoehe) * zeilengroesse / real fontgroesse + 0.5); + letzte zeilentiefe := int (zeilengroesse + 0.5) - letzte zeilenhoehe; +.; + +PROC berechne aktuelle zeilengroesse : + + IF linefeed faktor >= 1.0 + THEN aktuelle zeilenhoehe := max (groesste fonthoehe, letzte zeilenhoehe); + aktuelle zeilentiefe := max (groesste fonttiefe, letzte zeilentiefe); + ELSE + IF old linefeed calculation + THEN +(* >>> Maximumsbestimmung über Fontgröße ******************************* <<< *) + IF letzte zeilengroesse >= aktuelle zeilengroesse + THEN aktuelle zeilenhoehe := letzte zeilenhoehe; + aktuelle zeilentiefe := letzte zeilentiefe; + FI; + ELSE +(* >>> Maximumsbestimmung über Fonthöhe und Fonttiefe ****************** <<< *) + aktuelle zeilenhoehe := max (letzte zeilenhoehe, aktuelle zeilenhoehe); + aktuelle zeilentiefe := max (letzte zeilentiefe, aktuelle zeilentiefe); + FI; + FI; + aktuelle zeilenhoehe := max (groesste analysatorhoehe, aktuelle zeilenhoehe); + aktuelle zeilentiefe := max (groesste analysatortiefe, aktuelle zeilentiefe); + +END PROC berechne aktuelle zeilengroesse; + +(******************************************************************) +(*** tokenspeicher ***) + +LET max number token = 3000, + max number 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 number token TOKEN token liste, + ROW max number 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, hoechster index zaehler; +TEXT VAR letzte index breite, xpos vor index, zeilenpos nach index, grosse fonts, + index verschiebung; + +PROC loesche indexspeicher : + + index zaehler := 0; + hoechster index zaehler := 0; + letzte index breite := ""; + xpos vor index := ""; + zeilenpos nach index := ""; + index verschiebung := ""; + grosse fonts := ""; + +END PROC loesche indexspeicher; + + +PROC loesche hoehere index level : + + IF hoechster index zaehler > index zaehler + THEN letzte index breite := subtext (letzte index breite, 1, int length * index zaehler); + xpos vor index := subtext (xpos vor index, 1, int length * index zaehler); + zeilenpos nach index := subtext (zeilenpos nach index, 1, int length * index zaehler); + index verschiebung := subtext (index verschiebung, int length * index zaehler); + grosse fonts := subtext (grosse fonts, 1, int length * index zaehler); + hoechster index zaehler := index zaehler; + FI; + +END PROC loesche hoehere index level; + +(******************************************************************) +(*** 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 int length +.; + +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 l) : + + zeilen zaehler := 0; + anzahl durchschuss := anzahl; + IF anzahl > 0 + THEN IF wechsel + THEN durchschuss 1 := rest l DIV anzahl durchschuss; + durchschuss 2 := durchschuss 1 + sign (rest l); + anzahl durchschuss 1 := anzahl durchschuss - + abs (rest l) MOD anzahl durchschuss; + wechsel := FALSE; + ELSE durchschuss 2 := rest l DIV anzahl durchschuss; + durchschuss 1 := durchschuss 2 + sign (rest l); + anzahl durchschuss 1 := abs (rest l) 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 : + + INT VAR index; + 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 modifikationen fuer x move := 0; + aktuelle zeilentiefe der letzten zeile := 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; +THESAURUS VAR elan bolds := empty thesaurus; + +insert (elan bolds, "PACKET"); insert (elan bolds, "PROC"); +insert (elan bolds, "PROCEDURE"); insert (elan bolds, "OP"); +insert (elan bolds, "OPERATOR"); insert (elan bolds, "LET"); +insert (elan bolds, "ROW"); insert (elan bolds, "STRUCT"); +insert (elan bolds, "TYPE"); insert (elan bolds, "BOUND"); +insert (elan bolds, "IF"); insert (elan bolds, "REP"); +insert (elan bolds, "REPEAT"); insert (elan bolds, "FOR"); +insert (elan bolds, "WHILE"); insert (elan bolds, "SELECT"); + +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 (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 is 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, + PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) std analysator, + elan listings erlaubt CAND is elan source (eingabe), + headline (eingabe) ); + +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, + PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator ) : + + eingabe := file; + input (eingabe); + print (PROC (TEXT VAR) lese zeile, BOOL PROC is 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, + PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator, + elan listings erlaubt CAND is elan source (eingabe), + headline (eingabe) ); + +END PROC print; + +PROC lese zeile (TEXT VAR zeile l) : getline (eingabe, zeile l) END PROC lese zeile; + +BOOL PROC is eof : eof (eingabe) END PROC is eof; + + +BOOL PROC is elan source (FILE VAR eingabe l) : + +hole erstes symbol; +elan programm tag COR elan programm bold COR kommentar COR elanlist anweisung + +. 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 : + (elan bolds CONTAINS symbol) COR deklaration COR proc oder op (naechstes symbol) + + . deklaration : + next symbol (naechstes symbol); + naechstes symbol = "VAR" OR naechstes symbol = "CONST" + +. kommentar : + pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0 + +. elanlist anweisung : + symbol = "#" AND elanlist folgt + + . elanlist folgt : + next symbol (naechstes symbol); + naechstes symbol = "elanlist" + +. + hole erstes symbol : + hole erstes nicht blankes symbol; + scan (zeile); + next symbol (symbol, symbol type); + + . hole erstes nicht blankes symbol : + IF eof (eingabe l) THEN LEAVE is elan source WITH FALSE FI; + REP getline (eingabe l, zeile); + UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe l) PER; + reset (eingabe l); + +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, + PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator, + 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, + PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator, + elan listing, file name ); +IF is error THEN behandle fehlermeldung FI; + +. behandle fehlermeldung : + TEXT CONST fehler meldung := error message; + INT CONST fehler zeile := error line, + fehler code := error code; + 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 (fehler code, fehler meldung (* + " -> " + text (fehler zeile) *) ); + +END PROC print; + +d xpos := 0; +d ypos := 0; +d token. offset index := 1; +material wert := ""; +gedruckte seiten := 0; + +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 : - d token. offset index 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, + PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator, + 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 (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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; + 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; + + . seitenlaenge ueberschritten : + a ypos + aktuelle zeilentiefe > seitenlaenge + + . papierlaenge ueberschritten : + a ypos + aktuelle zeilentiefe > papierlaenge + + . neue seite oder spalte : + IF in letzter spalte + THEN INT CONST aktuelles y wanted := y wanted bei seitenwechel ohne page; + 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; + + . y wanted bei seitenwechel ohne page : + IF seitenlaenge ueberschritten + THEN y wanted + ELSE 0 + FI + + . analysiere zeile nochmal : + setze auf alte werte zurueck; + loesche anweisungsspeicher; + analysiere zeile (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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; + berechne letzte zeilengroesse; + 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 := TRUE; + open (document, x size, y size); + vor erster seite := FALSE; + + . 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 einer liste := FALSE; + vor erstem packet := TRUE; + zeilen nr := 0; + select counter := 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; + ELIF pos (zeile, "#elanlist#") <> 1 + THEN 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 innerhalb einer liste + THEN leeres layout; + pruefe ende der liste + ELIF pos (zeile, "P") <> 0 COR pos (zeile, ":") <> 0 + THEN analysiere elan zeile + ELIF innerhalb einer select kette + THEN leeres layout; + pruefe ende der select kette + ELIF pos (zeile, "SELECT") <> 0 + THEN analysiere select kette + ELSE leeres layout + 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 type anfang + THEN type layout + ELIF proc op anfang + THEN proc op layout + ELSE IF innerhalb einer select kette + THEN pruefe ende der select kette; + leeres layout + ELIF refinement anfang + THEN refinement layout + ELSE leeres layout + FI; + FI; + + + . packet anfang : + symbol = "PACKET" + + . type anfang : + symbol = "TYPE" + + . 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 = ":" + + . packet layout : + IF nicht am seiten anfang AND + (NOT vor erstem packet OR gedruckte seiten > 1) + THEN seiten wechsel + FI; + layout (" ", naechstes symbol, "*") ; + vor erstem packet := FALSE; + select counter := 0; + innerhalb einer liste := TRUE; + pruefe ende der liste; + + . type layout : + layout (" ", naechstes symbol, "."); + select counter := 0; + + . 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, "."); + select counter := 0; + innerhalb einer liste := TRUE; + pruefe ende der liste; + + . 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 + + . pruefe ende der liste : + IF pos (zeile, ":") <> 0 + THEN scan (zeile); + WHILE innerhalb einer liste + REP next symbol (symbol); + IF symbol = ":" THEN innerhalb einer liste := FALSE FI; + UNTIL symbol = "" PER; + FI; + + . innerhalb einer select kette : + select counter > 0 + + . analysiere select kette : + scan (zeile); + naechstes symbol := ""; + REP symbol := naechstes symbol; + next symbol (naechstes symbol); + IF naechstes symbol = "SELECT" CAND symbol <> "END" + THEN select counter := 1; + untersuche select kette; + FI; + UNTIL naechstes symbol = "" PER; + leeres layout; + + . pruefe ende der select kette : + IF pos (zeile, "SELECT") <> 0 + THEN scan (zeile); + naechstes symbol := ""; + untersuche select kette; + FI; + + . untersuche select kette : + REP symbol := naechstes symbol; + next symbol (naechstes symbol); + IF naechstes symbol = "SELECT" + THEN select counter INCR select step + ELIF naechstes symbol = "ENDSELECT" + THEN select counter DECR 1 + FI; + UNTIL naechstes symbol = "" PER; + + . select step : + IF symbol = "END" THEN -1 ELSE 1 FI + +. + 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; + aktuelle zeilentiefe der letzten zeile := 0; + 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; + +END PROC layout ; + + +PROC elan text cat blanks (INT CONST anzahl) : + + par2 := anzahl * " "; + elan text CAT par2; + +END PROC elan text cat blanks; + + +(***********************************************************************) + +PROC analysiere zeile (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator) : + +loesche analysespeicher; +behandle fuehrende blanks; +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; +IF zeile ist keine anweisungszeile + THEN berechne zeilenvorschub; + pruefe ob markierung rechts; + ELSE behandle anweisungszeile; +FI; + +. + 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; + letzte zeile war absatzzeile := zeile ist absatzzeile; + IF letzte zeile war absatzzeile THEN neue einrueckung FI; + IF zeilenpos = 0 + THEN behandle leerzeile; + LEAVE analysiere zeile; + ELSE initialisiere analyse; + FI; + + . behandle leerzeile : + a ypos INCR (letzte zeilenhoehe + + aktuelle zeilentiefe der letzten zeile + durchschuss); + aktuelle zeilentiefe der letzten zeile := letzte zeilentiefe; + 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; + 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; + fuehrende anweisungen := 0; + initialisiere zeilenvorschub; + IF zeile muss geblockt werden THEN initialisiere tab variablen FI; + IF hoechster index zaehler > 0 THEN loesche index speicher FI; + + . laenge der zeile : + IF zeile ist absatzzeile + THEN LENGTH zeile - 1 + ELSE LENGTH zeile + FI + +. + pruefe ob markierung links : + INT VAR linkes markierungs token; + IF markierung links + THEN mark token (mark index l). xpos := + left margin - mark token (mark index l). breite; + linkes markierungs token := token index f + 1; + lege markierungs token an (mark index l); + erstes token der zeile := token index f + 1; + initialisiere tab variablen; + ELSE linkes markierungs token := 0; + FI; + +. + analysiere tabellenzeile : + anfangs blankmodus := doppel blank; + alte zeilenpos := zeilen pos; + a xpos := left margin; + 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 token an (zeile, token zeiger, zeilen pos - 1, text token); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + + . rechtsbuendige spalte : + bestimme token bis terminator oder zeilenende + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + schreibe zeile rechtsbuendig (tab position); + + . zentrierte spalte : + bestimme token bis terminator oder zeilenende + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + +. + test auf aufzaehlung : + anfangs blankmodus := einfach blank; + bestimme token bis terminator oder zeilenende + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + + +. + 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 token an (zeile, token zeiger, zeilen pos - 1, text token); + 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 token an (zeile, token zeiger, zeilen pos - 1, text token); + FI; +. + werte indexspeicher aus : + INT VAR index; + IF index zaehler > 0 + THEN FOR index FROM index zaehler DOWNTO 1 + REP a ypos DECR (index verschiebung ISUB index); + IF (letzte index breite ISUB index) <> 0 + THEN a xpos := (xpos vor index ISUB index) + + min (a xpos - (xpos vor index ISUB index), + letzte index breite ISUB index); + FI; + PER; + stelle neuen font ein (grosse fonts ISUB 1); + FI; +. + zeile ist keine anweisungszeile : + fuehrende anweisungen <> zeilen laenge +. + berechne zeilenvorschub : + verschiebung := aktuelle zeilenhoehe + + aktuelle zeilentiefe der letzten zeile + durchschuss; + aktuelle zeilentiefe der letzten zeile := aktuelle zeilentiefe; + 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; +. + behandle anweisungszeile : + IF linkes markierungs token > 0 + THEN IF erstes token der zeile = token index f + 1 + THEN loesche analysespeicher; + ELSE FOR token index FROM linkes markierungs token + UPTO erstes token der zeile - 1 + REP t. text := ""; + t. xpos := 0; + t. breite := 0; + PER; + FI; + 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 + (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator): + +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 (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator); + 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 token an (zeile, token zeiger, zeilen pos - 1, text token) FI; + +END PROC bestimme token bis terminator oder zeilen ende; + + +PROC analysiere anweisung (PROC (INT CONST, TEXT VAR, + INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator) : + + bestimme anweisung; + IF anweisung ist kommando + THEN lege token an (anweisung, 1, maxint, kommando token); + ELIF anweisung ist kein kommentar + THEN werte anweisung aus; + FI; + + . anweisungsende : zeilen pos - 2 + + . erstes zeichen : par1 + +. bestimme anweisung : + INT CONST 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; + IF fuehrende anweisungen = anweisungsanfang - 2 THEN fuehrende anweisungen := zeilen pos 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 + +. anweisung ist kein kommentar : + erstes zeichen <> kommentar zeichen + +. + 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 + ELSE rufe analysator + FI; + END SELECT; + + . type anweisung : + change all (par1, " ", ""); + stelle neuen font ein (font (par1)); + a modifikationen := 0; + ueberpruefe groesste fontgroesse; + IF nicht innerhalb eines indexes + THEN berechne aktuelle zeilengroesse FI; + + . nicht innerhalb eines indexes : + index zaehler = 0 + + . 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, grosse fonttiefe := fonttiefe; + 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 verschiebung := verschiebung fuer kleinen font + ELSE verschiebung := verschiebung fuer grossen font + FI; + a ypos INCR verschiebung; + merke index werte; + + . verschiebung fuer kleinen font : + IF anweisungs index = a down + THEN 15 PROZENT (grosse fonthoehe + grosse fonttiefe) + ELSE - ( 4 PROZENT (grosse fonthoehe + grosse fonttiefe) ) + - (grosse fonthoehe + grosse fonttiefe - fonthoehe - fonttiefe) + FI + + . verschiebung fuer grossen font : + IF anweisungs index = a down + THEN 25 PROZENT (fonthoehe + fonttiefe) + ELSE - (50 PROZENT (fonthoehe + fonttiefe) ) + FI + + . merke index werte : + index zaehler INCR 1; + IF hoechster index zaehler < index zaehler + THEN neues index level + ELSE altes index level + FI; + IF index zaehler = 1 + THEN alter blankmodus := blankmodus; + blankmodus := keine blankanalyse; + FI; + + . neues index level : + hoechster index zaehler := index zaehler; + letzte index breite CAT 0; + xpos vor index CAT a xpos; + zeilenpos nach index CAT -1; + index verschiebung CAT verschiebung; + grosse fonts CAT grosser font; + + . altes index level : + IF (zeilenpos nach index ISUB index zaehler) = anweisungsanfang - 1 + AND sign (index verschiebung ISUB index zaehler) <> sign (verschiebung) + THEN doppelindex gefunden; + ELSE replace (xpos vor index, index zaehler, a xpos); + FI; + replace (index verschiebung, index zaehler, verschiebung); + replace (grosse fonts, index zaehler, grosser font); + + . doppelindex gefunden : + replace (letzte index breite, index zaehler, + a xpos - (xpos vor index ISUB index zaehler)); + a xpos := xpos vor index ISUB index zaehler; + + . end index anweisung : + IF index zaehler > 0 + THEN schalte auf alte index werte zurueck; + FI; + + . schalte auf alte index werte zurueck : + IF index zaehler = 1 THEN blankmodus := alter blankmodus FI; + a ypos DECR (index verschiebung ISUB index zaehler); + stelle neuen font ein (grosse fonts ISUB index zaehler); + IF (letzte index breite ISUB index zaehler) <> 0 + THEN berechne doppelindex + ELSE replace (zeilenpos nach index, index zaehler, zeilenpos); + FI; + index zaehler DECR 1; + + . berechne doppelindex : + a xpos := (xpos vor index ISUB index zaehler) + + max (a xpos - (xpos vor index ISUB index zaehler), + letzte index breite ISUB index zaehler); + replace (zeilenpos nach index, index zaehler, -1); + replace (letzte index breite, index zaehler, 0); + + . 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 token an (zeile, token zeiger, zeilen pos - 1, text token); + 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; + + . rufe analysator : + INT CONST alte xpos := a xpos, alte y pos := a ypos; + INT VAR analysatorbreite, analysatorhoehe, analysatortiefe, + analysator font := a font, + analysator modifikationen := a modifikationen; + zeilen pos := anweisungsanfang - 1; +disable stop; + analysator (text code, zeile, zeilen pos, + analysator font, analysator modifikationen, + analysatorbreite, analysatorhoehe, analysatortiefe, dummy); +IF is error + THEN par1 := error message; + par1 CAT " a1-> "; + par1 CAT text (errorline); + clear error; + errorstop (par1); +FI; +enable stop; + hole token der analyse; + a xpos := alte xpos + analysatorbreite; + a ypos := alte ypos; + a modifikationen := analysator modifikationen; + groesste analysatorhoehe := max (analysatorhoehe, groesste analysator hoehe); + groesste analysatortiefe := max (analysatortiefe, groesste analysator tiefe); + IF analysator font <> a font + THEN stelle neuen font ein (analysator font); + ueberpruefe groesste fontgroesse; + IF nicht innerhalb eines indexes + THEN berechne aktuelle zeilengroesse FI; + ELSE aktuelle zeilenhoehe := max (groesste analysatorhoehe, + aktuelle zeilenhoehe); + aktuelle zeilentiefe := max (groesste analysatortiefe, + aktuelle zeilentiefe); + FI; + + . hole token der analyse : + INT VAR token nr := 0, token font, token xpos, token ypos, token typ; + BOOL VAR font changed := FALSE; + token text := ""; + REP +disable stop; + analysator (token code, token text, token nr, + token font, a modifikationen, a breite, + token xpos, token ypos, token typ); +IF is error + THEN par1 := error message; + par1 CAT " a2-> "; + par1 CAT text (errorline); + clear error; + errorstop (par1); +FI; +enable stop; + IF token nr = 0 + THEN IF font changed THEN a font := -1 FI; + LEAVE hole token der analyse + FI; + IF token font <> a font + THEN a font := token font; + font offsets := y offsets (a font); + offsets := LENGTH font offsets > 2; + font changed := TRUE; + FI; + a xpos := alte xpos + token xpos; + a ypos := alte ypos + token ypos; + lege token an (token text, 1, max int, token typ) + PER; + + . token text : par1 + +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, fontdurchschuss, fonthoehe, fonttiefe, + zeichenbreiten); + 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 > int length; + berechne fontgroesse; + berechne letzte zeilengroesse; + 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 token an (TEXT CONST token text, + INT CONST token anfang, token ende, token typ) : + + INT VAR anfang := token anfang; + aktuelle ypos := a ypos + (font offsets ISUB 1); + neuer token index; + uebertrage token (tf, token text, token anfang, token ende, token typ); + IF token typ >= text token + THEN IF offsets THEN lege offsets an (font offsets) FI; + stranalyze (zeichen zaehler, anzahl zeichen, max int, + token text, anfang, token ende, ausgang); + a xpos INCR a breite; + FI; + a breite := 0; + a modifikationen fuer x move := 0; + a block token := FALSE; + +END PROC lege token an; + + +PROC uebertrage token (TOKEN VAR tf, TEXT CONST token text, + INT CONST token anfang, token ende, token typ) : + + tf. text := subtext (token text, token anfang, token ende); + 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 := token typ; + tf. block token := a block token; + +END PROC uebertrage 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 > int length + +END PROC lege markierungs token an; + + +PROC lege offsets an (TEXT CONST offsets l) : + + INT CONST anzahl offsets := LENGTH offsets l DIV int length; + INT VAR index; + offset token := tf; + offset token. block token := FALSE; + reset bit (offset token. modifikationen, underline bit); + reset bit (offset token. modifikationen fuer x move, underline bit); + FOR index FROM 2 UPTO anzahl offsets + REP aktuelle ypos := a ypos + (offsets l 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 l) : + + token index := erstes tab token; + WHILE token index <= token index f + REP t. xpos INCR verschiebung l; + token index INCR 1; + PER; + +END PROC verschiebe token xpos; + + +PROC verschiebe token ypos (INT CONST verschiebung l) : + + ypos index := erster ypos index a; + WHILE ypos index <> 0 + REP y. ypos INCR verschiebung l; + ypos index := y. naechster ypos index; + PER; + +END PROC verschiebe token ypos; + + +PROC sortiere neue token ein : + +INT VAR index; +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; + + . drucke token : + IF NOT token passt in zeile + THEN IF token ist text token + THEN berechne token teil + ELSE LEAVE drucke token + FI; + 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); + ELIF token ist linien token + THEN gib linien token aus + ELSE gib kommando token aus + FI; + + . gib linien token aus : + linien verschiebung := d token. breite; + ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + + . 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); + gib cr aus; + gehe zum ersten token dieser ypos; + REP gib token nochmal aus UNTIL kein token mehr vorhanden PER; + schalte modifikationen aus wenn noetig; + + . 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); + gib cr aus; + schalte modifikationen aus wenn noetig; + gehe zum ersten token dieser ypos; + REP unterstreiche token UNTIL kein token mehr vorhanden PER; + + . 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; + ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + 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 : + IF bit (d token. modifikationen, underline bit) + THEN linien verschiebung := d token. xpos + + d token. breite - d xpos + ELSE linien verschiebung := d token. xpos - d xpos + FI; + d token. offset index := - underline line type; + + +. 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 ist linien token : + d token. offset index <= linien 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; + +. + 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; + +. gib cr aus : + IF d xpos <> 0 + THEN execute (carriage return, "", d xpos, 0); + d xpos := 0; + FI; + +END PROC drucke tokenspeicher; + + +PROC ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + IF linien verschiebung > 0 + THEN disable stop; + d xpos INCR linien verschiebung; + execute (draw, "", linien verschiebung, 0); + IF is error + THEN ziehe horizontale linie nach cr; + FI; + enable stop; + FI; + + . ziehe horizontale linie nach cr : + clear error; + d xpos DECR linien verschiebung; + verschiebung := d xpos; + gib cr aus; + x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + d xpos INCR linien verschiebung; + execute (draw, "", linien verschiebung, 0); + IF is error + THEN clear error; + d xpos DECR linien verschiebung; + FI; + + . gib cr aus : + IF d xpos <> 0 + THEN execute (carriage return, "", d xpos, 0); + d xpos := 0; + FI; + +END PROC ziehe horizontale linie; + + +PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + IF verschiebung <> 0 + THEN gib cr aus; + 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; + + . gib cr aus : + IF d xpos <> 0 + THEN execute (carriage return, "", d xpos, 0); + d xpos := 0; + 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 bei x move 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 bei x move 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 : + IF d xpos <> 0 + THEN execute (carriage return, "", d xpos, 0); + d xpos := 0; + FI; + +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 minint; + 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; +gib cr 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; + aktuelle zeilentiefe der letzten zeile := 0; + +. gib cr aus : + IF d xpos <> 0 + THEN execute (carriage return, "", d xpos, 0); + d xpos := 0; + FI; + +. 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 l, y wanted l, + 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 l; + y start := y wanted l; + open (page, x start, y start); + gedruckte seiten INCR 1; + seite ist offen := TRUE; + +. initialisiere neue seite : + INT CONST dif left margin := x wanted l - x start - left margin + indentation, + dif top margin := y wanted l - 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 : + execute (carriage return, "", d xpos, 0); + d xpos := 0; + 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/std.zusatz/1.8.7/src/eumelmeter b/system/std.zusatz/1.8.7/src/eumelmeter new file mode 100644 index 0000000..ba92476 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/eumelmeter @@ -0,0 +1,131 @@ + (* Author: J.Liedtke*) +PACKET eumelmeter DEFINES (* Stand: 11.10.83 *) + + init log , + log : + + +LET snapshot interval = 590.0 ; + +REAL VAR next snapshot time , + time , timex , + paging wait , paging wait x , + paging busy , paging busy x , + fore cpu , fore cpu x , + back cpu , back cpu x , + system cpu , system cpu x , + delta t ; +INT VAR storage max, used ; +TEXT VAR record ; + +PROC init log : + + time := clock (1) ; + paging wait := clock (2) ; + paging busy := clock (3) ; + fore cpu := clock (4) ; + back cpu := clock (5) ; + system cpu := clock (6) ; + next snapshot time := time + snapshot interval + +ENDPROC init log ; + +PROC log (INT CONST active terminals, active background) : + + new snapshot time if was clock reset ; + IF clock (1) >= next snapshot time + THEN save values ; + get new values ; + create stat record ; + put log (record) ; + define next snapshot time + FI . + +new snapshot time if was clock reset : + IF clock (1) < next snapshot time - snapshot interval + THEN next snapshot time := clock (1) + FI . + +save values : + time x := time ; + paging wait x := paging wait ; + paging busy x := paging busy ; + fore cpu x := fore cpu ; + back cpu x := back cpu ; + system cpu x := system cpu . + +get new values : + time := clock (1) ; + paging wait := clock (2) ; + paging busy := clock (3) ; + fore cpu := clock (4) ; + back cpu := clock (5) ; + system cpu := clock (6) ; + storage (storage max, used) . + +create stat record : + record := text (used, 5) ; + record CAT text (active terminals,3) ; + record CAT text (active background,3) ; + delta t := (time - time x) ; + percent (paging wait, paging wait x) ; + percent (paging busy, paging busy x) ; + percent (fore cpu, fore cpu x) ; + percent (back cpu, back cpu x) ; + percent (system cpu, system cpu x) ; + percent (last, 0.0) ; + percent (nutz, 0.0) . + +last : paging wait + paging busy + fore cpu + back cpu + system cpu + - paging waitx - paging busyx - fore cpux - back cpux - system cpux . + +nutz : time - paging wait - system cpu + - timex + paging waitx + system cpux . + +define next snapshot time : + next snapshot time := time + snapshot interval . + +ENDPROC log ; + +PROC percent (REAL CONST neu, alt ) : + + record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%" + +ENDPROC percent ; + +ENDPACKET eumelmeter ; + +INT VAR active terminals , active background ; + +task password ("-") ; +break ; +command dialogue (FALSE) ; +forget ("eumelmeter") ; +init log ; +REP + pause (6000) ; + count active processes (active terminals, active background) ; + log (active terminals, active background) +PER ; + +PROC count active processes (INT VAR active terminals, active background) : + + active terminals := 0 ; + active background := 0 ; + TASK VAR process := myself ; + REP + next active (process) ; + IF user process + THEN IF process at terminal + THEN active terminals INCR 1 + ELSE active background INCR 1 + FI + FI + UNTIL process = myself PER . + +user process : NOT (process < supervisor) . + +process at terminal : channel (process) >= 0 . + +ENDPROC count active processes ; + diff --git a/system/std.zusatz/1.8.7/src/font convertor 9 b/system/std.zusatz/1.8.7/src/font convertor 9 new file mode 100644 index 0000000..a5d0ea7 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/font convertor 9 @@ -0,0 +1,1095 @@ +PACKET font convertor (* Autor : Rudolf Ruland *) + (* Stand : 29.03.88 *) + DEFINES create font table , + add fonts, + create font file : + +(* >>> ***************************************************************** <<< *) + +INT CONST int length := length of one int, + highest bit := int length * 8 - 1; + +. length of one int : + INT VAR int counter := 0, int value := max int; + REP int counter INCR 1; + int value := int value DIV 256; + UNTIL int value = 0 PER; + int counter +.; + +(* >>> ***************************************************************** <<< *) + +LET t tag = 1, + t bold = 2, + t number = 3, + t text = 4, + t operator = 5, + t delimiter = 6, + t end of file = 7, + + nil modus = 0, + font table modus = 1, + font modus = 2, + extension modus = 3, + + x unit = 1, + y unit = 2, + on string = 3, + off string = 4, + indentation pitch = 5, + font lead = 6, + font height = 7, + font depth = 8, + larger font = 9, + smaller font = 10, + font string = 11, + y off sets = 12, + bold off set = 13; + +THESAURUS VAR names, english identification := empty thesaurus, + german identification := empty thesaurus; + +insert (english identification, "xunit"); +insert (english identification, "yunit"); +insert (english identification, "onstring"); +insert (english identification, "offstring"); +insert (english identification, "indentationpitch"); +insert (english identification, "fontlead"); +insert (english identification, "fontheight"); +insert (english identification, "fontdepth"); +insert (english identification, "nextlargerfont"); +insert (english identification, "nextsmallerfont"); +insert (english identification, "fontstring"); +insert (english identification, "yoffsets"); +insert (english identification, "boldoffset"); + +insert (german identification, "xeinheit"); +insert (german identification, "yeinheit"); +insert (german identification, "onsequenz"); +insert (german identification, "offsequenz"); +insert (german identification, "einrueckbreite"); +insert (german identification, "durchschuss"); +insert (german identification, "fonthoehe"); +insert (german identification, "fonttiefe"); +insert (german identification, "groessererfont"); +insert (german identification, "kleinererfont"); +insert (german identification, "fontsequenz"); +insert (german identification, "yverschiebungen"); +insert (german identification, "boldverschiebung"); + +INT VAR modus, last modus, symbol type, int symbol, pitch, + identification nr, link nr, extension code 1, + char code 1, char code, char pos, vorzeichen, + replacements length, index; +TEXT VAR symbol, font table name, replacement, char, buffer, z; +BOOL VAR english; +FILE VAR file, font file; + +(*****************************************************************) + +LET 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 , + + ); + +BOUND FONTTABLE VAR font table; + +DATASPACE VAR ds; + +INT VAR font nr, extension nr; + +. font : font table. fonts (font nr) +. extension : font table. extensions (extension nr) +. line nr : line no (file) - 1 +.; + +(*****************************************************************) + + +PROC create font table : + + create font table (last param) + +END PROC create font table; + + +PROC create font table (TEXT CONST font file name) : + +file := sequential file (input, font file name); +disable stop; +ds := nilspace; +modus := nil modus; +load; +IF is error THEN error (errormessage) FI; +forget (ds); + +END PROC create font table; + + +PROC add fonts (TEXT CONST font tab name, font file name) : + +file := sequential file (input, font file name); +font table name := font tab name; +change all (font table name, " ", ""); +IF NOT exists (font table name) COR type (old (font table name)) <> font table type + THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht") +FI; +disable stop; +ds := old (font table name); +fonttable := ds; +modus := font modus; +font nr := fonttable. last font; +extension nr := fonttable. last extension; +load; +IF is error THEN error (errormessage) FI; +forget (ds); + +END PROC add fonts; + + +PROC load : + +enable stop; +initialize loading; +REP get kennung; + get identification; + get char specifications; +UNTIL symbol type >= t end of file PER; +font table found; + +. initialize loading : + scan (file); + get next symbol; + +. font table found : + IF font nr = 0 + THEN errorstop ("Fonts zur Fonttabelle """ + + font table name + """ fehlen"); + ELSE font table. last font := font nr; + font table. last extension := extension nr; + forget (font table name, quiet); + copy (ds, font table name); + type (old (font table name), font table type); + forget (ds); ds := nilspace; + FI; + +. get next symbol : + next symbol (file, symbol, symbol type); + +. get semicolon : + get next symbol; + IF symbol <> ";" OR symbol type <> t delimiter + THEN errorstop ("';' erwartet") FI; + +. + get kennung : + cout (line nr); + IF symbol type <> t bold + THEN errorstop ("Kennung erwartet") FI; + IF symbol = "FONTTABLE" OR symbol = "FONTTABELLE" + THEN initialize font table; + get font table name; + ELIF symbol = "FONT" + THEN initialize font; + get font names; + ELIF symbol = "EXTENSION" OR symbol = "ERWEITERUNG" + THEN get extension char; + initialize extension; + ELIF modus = nil modus + THEN errorstop ("Kennung 'FONTTABLE' oder 'FONTTABELLE' zu Beginn der Datei erwartet") + ELSE errorstop ("unzulaessige Kennung") + FI; + + . initialize font table : + IF modus <> nil modus THEN font table found FI; + modus := font table modus; + font nr := 0; + extension nr := 0; + font table := ds; + font table. font names := empty thesaurus; + font table. replacements := ""; + font table. font name links := ""; + font table. extension chars := ""; + font table. extension indexes := ""; + font table. x unit := 10.0/2.54; + font table. y unit := 6.0/2.54; + font table. replacements table := 0; + FOR index FROM 1 UPTO 4 + REP font table. on strings (index) := ""; + font table. off strings (index) := ""; + PER; + + . get font table name : + get name list; + symbol type := t text; + symbol := name (names, 1); + IF exists (symbol) + THEN forget (symbol); + IF exists (symbol) + THEN errorstop ("Fonttabelle existiert schon") FI; + FI; + font table name := symbol; + + . initialize font : + IF font nr = max fonts + THEN errorstop ("zu viele Fonts") FI; + font nr INCR 1; + modus := font modus; + replacements length := LENGTH font table. replacements; + font. font string := ""; + font. font name indexes := ""; + font. replacements := ""; + font. extension chars := ""; + font. extension indexes := ""; + font. y offsets := int length * ""0""; + font. indentation pitch := int (font table. x unit * 2.54 / 10.0); + font. font lead := 0; + font. font height := int (font table. y unit * 2.54 / 6.0); + font. font depth := 0; + font. next larger font := 0; + font. next smaller font := 0; + font. bold offset := 0; + font. pitch table := font. indentation pitch; + font. replacements table := font table. replacements table; + FOR index FROM 1 UPTO LENGTH font table. extension chars + REP font. replacements table + ( code (font table. extension chars SUB index) + 1 ) := maxint; + PER; + + . get font names : + get name list; + index := 0; + symbol type := t text; + WHILE next font name + REP link nr := link (font table. font names, symbol); + IF link nr = 0 + THEN insert (font table. font names, symbol, link nr); + font table. font name links CAT font nr; + ELIF (font table. font name links ISUB link nr) = 0 + THEN replace (font table. font name links, link nr, font nr); + ELSE errorstop ("Font existiert in Fonttabelle """ + + font table name + """ schon") + FI; + font. font name indexes CAT link nr; + PER; + + . next font name : + get (names, symbol, index); + symbol <> "" + + . get extension char : + IF NOT two bytes + THEN errorstop ("Erweiterungen nur im zwei-Byte-Modus erlaubt") FI; + get name list; + symbol type := t text; + symbol := name (names, 1); + IF LENGTH symbol <> 1 + THEN errorstop ("nur ein Zeichen bei Erweiterung erlaubt") FI; + extension code 1 := code (symbol) + 1; + IF NOT is kanji esc (symbol) + THEN errorstop ("Kanji-ESC-Zeichen erwartet") FI; + + . initialize extension : + IF extension nr = max extensions + THEN errorstop ("zu viele Erweiterungen") FI; + extension nr INCR 1; + IF modus <> extension modus THEN last modus := modus FI; + modus := extension modus; + IF last modus = font table modus + THEN initalize font table extension + ELSE initalize font extension + FI; + + . initalize font table extension : + IF pos (font table. extension chars, symbol) <> 0 + THEN errorstop ("Erweiterung wurde schon definiert") FI; + extension. replacements := ""; + extension. std pitch := 0; + extension. pitch table := 0; + extension. replacements table := 0; + font table. extension chars CAT symbol; + font table. extension indexes CAT extension nr; + font table. replacements table (extension code 1) := max int; + replacements length := 0; + + . initalize font extension : + IF pos (font. extension chars, symbol) <> 0 + THEN errorstop ("Erweiterung wurde schon definiert") FI; + extension. replacements := ""; + extension. std pitch := font. pitch table (extension code 1) XOR (-maxint-1); + extension. pitch table := extension. std pitch; + font. extension chars CAT symbol; + font. extension indexes CAT extension nr; + char pos := pos (font table. extension chars, symbol); + IF char pos <> 0 + THEN index := font table. extension indexes ISUB char pos; + extension. replacements table := + font table. extensions (index). replacements table; + replacements length := + LENGTH font table. extensions (index). replacements; + font. replacements table (extension code 1) := max int; + ELSE extension. replacements table := 0; + replacements length := 0; + FI; + +. + get identification : + WHILE identification found + REP cout (line nr); + determine identification link nr; + select identification; + PER; + + . identification found : + get next symbol; + symbol type = t tag + + . determine identification link nr : + identification nr := link (english identification, symbol); + english := TRUE; + IF identification nr = 0 + THEN identification nr := link (german identification, symbol); + english := FALSE; + IF identification nr = 0 + THEN errorstop ("unzulaesige Identifikation") FI; + FI; + + . select identification : + get next symbol; + IF symbol <> "=" OR symbol type <> t operator + THEN errorstop ("'=' nach Identifikation fehlt") FI; + get next symbol; + SELECT identification nr OF + CASE x unit : x unit found + CASE y unit : y unit found + CASE on string : on string found + CASE off string : off string found + CASE indentation pitch : indentation pitch found + CASE font lead : font lead found + CASE font height : font height found + CASE font depth : font depth found + CASE larger font : larger font found + CASE smaller font : smaller font found + CASE font string : font string found + CASE y offsets : y offsets found + CASE bold offset : bold offset found + END SELECT; + + . x unit found : + check modus (font table modus); + font table. x unit := real (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("REAL-Denoter nach 'x unit' erwartet") + ELSE errorstop ("REAL-Denoter nach 'x einheit' erwartet") + FI; + FI; + get semicolon; + + . y unit found : + check modus (font table modus); + font table. y unit := real (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("REAL-Denoter nach 'y unit' erwartet") + ELSE errorstop ("REAL-Denoter nach 'y einheit' erwartet") + FI; + FI; + get semicolon; + + . on string found : + check modus (font table modus); + FOR index FROM 1 UPTO 4 + REP IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'on string' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'on sequenz' erwartet") + FI; + FI; + font table. on strings (index) := symbol; + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + IF symbol = ";" THEN LEAVE on string found FI; + IF index = 4 THEN errorstop ("';' erwartet") FI; + get next symbol; + PER; + + . off string found : + check modus (font table modus); + FOR index FROM 1 UPTO 4 + REP IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'off string' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'off sequenz' erwartet") + FI; + FI; + font table. off strings (index) := symbol; + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + IF symbol = ";" THEN LEAVE off string found FI; + IF index = 4 THEN errorstop ("';' erwartet") FI; + get next symbol; + PER; + + . indentation pitch found : + check modus (font modus); + font. indentation pitch := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'indentation pitch' erwartet") + ELSE errorstop ("INT-Denoter nach 'einrueckbreite' erwartet") + FI; + FI; + font. pitch table := font. indentation pitch; + get semicolon; + + . font lead found : + check modus (font modus); + font. font lead := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'font lead' erwartet") + ELSE errorstop ("INT-Denoter nach 'durchschuss' erwartet") + FI; + FI; + get semicolon; + + . font height found : + check modus (font modus); + font. font height := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'font height' erwartet") + ELSE errorstop ("INT-Denoter nach 'fonthoehe' erwartet") + FI; + FI; + get semicolon; + + . font depth found : + check modus (font modus); + font. font depth := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'font depth' erwartet") + ELSE errorstop ("INT-Denoter nach 'fonttiefe' erwartet") + FI; + FI; + get semicolon; + + . larger font found : + check modus (font modus); + IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'next larger font' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'groesserer font' erwartet") + FI; + FI; + determine link nr; + font. next larger font := link nr; + get semicolon; + + . smaller font found : + check modus (font modus); + IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'next smaller font' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'kleinerer font' erwartet") + FI; + FI; + determine link nr; + font. next smaller font := link nr; + get semicolon; + + . determine link nr : + change all (symbol, " ", ""); + IF symbol = "" + THEN link nr := 0 + ELSE link nr := link (font table. font names, symbol); + IF link nr = 0 + THEN insert (font table. font names, symbol, link nr); + font table. font name links CAT 0; + FI; + FI; + + . font string found : + check modus (font modus); + IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'font string' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'fontsequenz' erwartet") + FI; + FI; + font. font string := symbol; + get semicolon; + + . y offsets found : + check modus (font modus); + font. y offsets := ""; + REP IF symbol = "-" AND symbol type = t operator + THEN vorzeichen := -1; + get next symbol; + ELSE vorzeichen := 1; + FI; + int symbol := vorzeichen * int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'y offsets' erwartet") + ELSE errorstop ("INT-Denoter nach 'y verschiebungen' erwartet") + FI; + FI; + font. y offsets CAT int symbol; + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + IF symbol = ";" THEN LEAVE y offsets found FI; + get next symbol; + PER; + + . bold offset found : + check modus (font modus); + IF symbol = "-" AND symbol type = t operator + THEN vorzeichen := -1; + get next symbol; + ELSE vorzeichen := 1; + FI; + font. bold offset := vorzeichen * int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'bold offset' erwartet") + ELSE errorstop ("INT-Denoter nach 'bold verschiebungen' erwartet") + FI; + FI; + get semicolon; + +. + get char specifications : + WHILE char found + REP cout (line nr); + char specification; + get next symbol; + PER; + + . char found : + symbol type = t text + + . char specification : + IF LENGTH symbol <> 1 + THEN errorstop ("nur ein Zeichen bei Zeichenangabe erlaubt") FI; + char := symbol; + char code 1 := code (char) + 1; + look for specification; + look for specification; + get semicolon; + + . look for specification : + get next symbol; + IF symbol = ";" AND symbol type = t delimiter + THEN LEAVE char specification + ELIF symbol = "," AND symbol type = t delimiter + THEN get specification + ELSE errorstop ("',' oder ';' bei Zeichenspezifikation erwartet") + FI; + + . get specification : + get next symbol; + IF symbol type = t number + THEN pitch specification; + ELIF symbol type = t text + THEN replacement specification + ELSE errorstop ("unzulaessiger Wert bei Zeichenspezifikation") + FI; + + . pitch specification : + int symbol := int (symbol); + IF NOT last conversion ok + THEN errorstop ("INT-Denoter bei Breitenangabe erwartet") FI; + IF modus = font modus + THEN font. pitch table (char code 1) := int symbol; + IF is kanji esc (char) + THEN set bit (font. pitch table (char code 1), highest bit) FI; + ELIF modus = extension modus + THEN IF last modus = font modus AND + font. pitch table (extension code 1) <> max int + THEN font. pitch table (extension code 1) := max int FI; + extension. pitch table (char code 1) := int symbol; + FI; + + . replacement specification : + IF LENGTH symbol > 255 + THEN errorstop ("Ersatzdarstellungen duerfen nur 255 Zeichen haben") FI; + IF modus = font table modus + THEN font table. replacements table (char code 1) := + (LENGTH font table. replacements + 1); + font table. replacements CAT code (LENGTH symbol); + font table. replacements CAT symbol; + IF is kanji esc (char) + THEN set bit (font table. replacements table (char code 1), highest bit) FI; + ELIF modus = font modus + THEN font. replacements table (char code 1) := + (replacements length + LENGTH font. replacements + 1); + font. replacements CAT code (LENGTH symbol); + font. replacements CAT symbol; + IF is kanji esc (char) + THEN set bit (font. replacements table (char code 1), highest bit) FI; + ELIF modus = extension modus + THEN IF last modus = font modus AND + font. replacements table (extension code 1) <> max int + THEN font. replacements table (extension code 1) := max int FI; + extension. replacements table (char code 1) := + (replacements length + LENGTH extension. replacements + 1); + extension. replacements CAT code (LENGTH symbol); + extension. replacements CAT symbol; + FI; + +END PROC load; + + +PROC get name list : + + names := empty thesaurus; + get next symbol; + IF symbol <> ":" OR symbol type <> t delimiter + THEN errorstop ("':' nach Kennung erwartet") FI; + REP get next symbol; + change all (symbol, " ", ""); + IF symbol type <> t text + THEN errorstop ("TEXT-Denoter in Namesliste erwartet") FI; + IF symbol = "" + THEN errorstop ("'niltext' als Name nicht erlaubt") FI; + insert (names, symbol); + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + UNTIL symbol = ";" PER; + + . get next symbol : + next symbol (file, symbol, symbol type); + +END PROC get name list; + + +OP := (ROW 256 INT VAR l, INT CONST r) : + +INT VAR i; +IF modus = extension modus OR NOT two bytes + THEN FOR i FROM 1 UPTO 256 REP l (i) := r PER; + ELSE FOR i FROM 1 UPTO 129 REP l (i) := r PER; + FOR i FROM 130 UPTO 160 REP l (i) := r - maxint - 1 PER; + FOR i FROM 161 UPTO 224 REP l (i) := r PER; + FOR i FROM 225 UPTO 240 REP l (i) := r - maxint - 1 PER; + FOR i FROM 241 UPTO 256 REP l (i) := r PER; +FI; + +END OP :=; + + +PROC check modus (INT CONST mod) : + + IF mod <> modus THEN errorstop ("unzulaessige Identifikation") FI; + +END PROC check modus; + + +PROC error (TEXT CONST message) : + +(*INT CONST l := error line;*) + clear error; + errorstop ("Zeile " + text (line nr) + " bei " + letztes symbol + + " : " + message (* + errorline if neccessary *) ); + + . letztes symbol : + IF symbol type = t text + THEN decode (symbol); + """" + symbol + """" + ELIF symbol type >= t end of file + THEN "EOF" + ELSE symbol + FI +(* + . errorline if neccessary : + IF l = 0 + THEN "" + ELSE " -> " + text (l) + FI +*) +END PROC error; + + +(*******************************************************************) + + +PROC create font file (TEXT CONST font tab name, font file name) : + +enable stop; +connect font table; +put font table in font file; + +. + connect font table : + buffer := font tab name; + change all (buffer, " ", ""); + IF NOT exists (buffer) COR type (old (buffer)) <> font table type + THEN errorstop ("Fonttabelle """ + buffer + """ gibt es nicht") + FI; + font table := old (buffer); + +. + put font table in font file : + INT VAR font file nr := 0; + enable stop; + font file := sequential file (output, font file name); + max line length (font file, 16000); + check file overflow; + z := " "; + put font table; + FOR font nr FROM 1 UPTO font table. last font REP put font PER; + + . check file overflow : + WHILE lines (font file) > 3600 + REP font file nr INCR 1; + font file := sequential file (output, font file name + "." + text (font file nr)); + max line length (font file, 16000); + PER; + +. put font table : + put z; + z CAT "FONTTABLE : """; z CAT buffer; z CAT """;"; put z; + z CAT " x unit = "; z CAT text (font table. x unit); z CAT ";"; put z; + z CAT " y unit = "; z CAT text (font table. y unit); z CAT ";"; put z; + z CAT " on string = """; z cat on strings; z CAT """;"; put z; + z CAT " off string = """; z cat off strings; z CAT """;"; put z; + put font table replacements; + put font table extensions; + put z; + + . z cat on strings : + FOR index FROM 1 UPTO 4 + REP buffer := font table. on strings (index); + decode (buffer); + z CAT buffer; + IF index <> 4 THEN z CAT """, """ FI; + PER; + + . z cat off strings : + FOR index FROM 1 UPTO 4 + REP buffer := font table. off strings (index); + decode (buffer); + z CAT buffer; + IF index <> 4 THEN z CAT """, """ FI; + PER; + + . put font table replacements : + put z; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + link nr := font table. replacements table (char code 1); + reset bit (link nr, highest bit); + IF link nr > 0 AND link nr <> maxint + THEN z CAT " "; + put char code; + put font table replacement; + put z; + FI; + PER; + + . put font table replacement : + replacement := subtext (font table. replacements, link nr + 1, + link nr + code (font table. replacements SUB link nr) ); + put replacement; + + . put font table extensions : + IF font table. extension chars <> "" + THEN FOR index FROM 1 UPTO LENGTH font table. extension chars + REP put font table extension PER; + FI; + + . put font table extension : + check file overflow; + put z; + z CAT " EXTENSION : """""; + z CAT text 3 (code (font table. extension chars SUB index)); + z CAT """"";"; + put z; put z; + replacements length := 0; + extension nr := font table. extension indexes ISUB index; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + link nr := extension. replacements table (char code 1); + IF link nr > 0 + THEN z CAT " "; + put char code; + put extension replacement; + put z; + FI; + PER; + +. put font : + check file overflow; + put z; + z CAT " FONT : "; z cat font names; z CAT ";"; put z; + z CAT " indentation pitch = "; + z CAT text(font. indentation pitch); + z CAT ";"; put z; + IF font. font lead <> 0 + THEN z CAT " font lead = "; + z CAT text(font. font lead); + z CAT ";"; put z; + FI; + z CAT " font height = "; + z CAT text(font. font height); + z CAT ";"; put z; + IF font. font depth <> 0 + THEN z CAT " font depth = "; + z CAT text(font. font depth); + z CAT ";"; put z; + FI; + IF next larger <> "" + THEN z CAT " next larger font = """; + z CAT next larger; + z CAT """;"; put z; + FI; + IF next smaller <> "" + THEN z CAT " next smaller font = """; + z CAT next smaller; + z CAT """;"; put z; + FI; + IF font. font string <> "" + THEN z CAT " font string = """; + z CAT font string; + z CAT """;"; put z; + FI; + IF (font. y offsets ISUB 1) <> 0 OR LENGTH font. y offsets > int length + THEN z CAT " y offsets = "; + z cat y offsets; + z CAT ";"; put z; + FI; + IF font. bold offset <> 0 + THEN z CAT " bold offset = "; + z CAT text(font. bold offset); + z CAT ";"; put z; + FI; + put font pitches and replacements; + put font extensions; + + . next larger : name (font table. font names, font. next larger font) + . next smaller : name (font table. font names, font. next smaller font) + . font string : buffer := font. font string; decode (buffer); buffer + + . z cat font names : + z CAT """"; + z CAT name (font table. font names, font. font name indexes ISUB 1); + z CAT """"; + FOR index FROM 2 UPTO LENGTH font. font name indexes DIV int length + REP z CAT ", """; + z CAT name (font table. font names, font. font name indexes ISUB index); + z CAT """"; + PER; + + . z cat y offsets : + z CAT text (font. y offsets ISUB 1); + FOR index FROM 2 UPTO LENGTH font. y offsets DIV int length + REP z CAT ", "; + z CAT text (font. y offsets ISUB index); + PER; + + . put font pitches and replacements : + BOOL VAR ausgabe := FALSE; + replacements length := LENGTH font table. replacements; + put z; + z CAT " "; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + pitch := font. pitch table (char code 1); + reset bit (pitch, highest bit); + link nr := font. replacements table (char code 1); + reset bit (link nr, highest bit); + IF (pitch <> font. indentation pitch) OR + (link nr > replacements length AND link nr <> maxint) + THEN put font char pitch and replacement; + IF ausgabe + THEN put z; + ausgabe := FALSE; + ELSE ausgabe := TRUE; + FI; + z CAT " "; + FI; + PER; + IF ausgabe THEN put z ELSE z := " " FI; + + . put font char pitch and replacement : + put char code; + put font char pitch; + IF link nr > replacements length AND link nr <> maxint + THEN put font replacement; + IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI; + ELIF ausgabe + THEN z CAT ";" + ELSE z CAT "; "; + FI; + + . put font char pitch : + IF pitch = max int + THEN char pos := pos (font. extension chars, code (char code)); + IF char pos <> 0 + THEN pitch := font table. extensions + (font. extension indexes ISUB char pos). std pitch + FI; + FI; + put char pitch; + + . put font replacement : + link nr DECR replacements length; + replacement := subtext (font. replacements, link nr + 1, + link nr + code (font. replacements SUB link nr) ); + put replacement; + + . put font extensions : + IF font. extension chars <> "" + THEN FOR index FROM 1 UPTO LENGTH font. extension chars + REP put font extension PER; + FI; + + . put font extension : + check file overflow; + put z; + z CAT " EXTENSION : """""; + z CAT text 3 (code (font. extension chars SUB index)); + z CAT """"";"; + put z; put z; z CAT " "; + detemine replacements length; + extension nr := font. extension indexes ISUB index; + ausgabe := FALSE; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + pitch := extension. pitch table (char code 1); + link nr := extension. replacements table (char code 1); + IF pitch <> extension. std pitch OR link nr > replacements length + THEN put extension char pitch and replacement; + IF ausgabe + THEN put z; + ausgabe := FALSE; + ELSE ausgabe := TRUE; + FI; + z CAT " "; + FI; + PER; + IF ausgabe THEN put z ELSE z := " " FI; + + . detemine replacements length : + char pos := pos (font table. extension chars, + font. extension chars SUB index); + IF char pos <> 0 + THEN replacements length := LENGTH font table. extensions + (font table. extension indexes ISUB char pos). replacements; + ELSE replacements length := 0; + FI; + + . put extension char pitch and replacement : + put char code; + put char pitch; + IF link nr > replacements length + THEN put extension replacement; + IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI; + ELIF ausgabe + THEN z CAT ";" + ELSE z CAT "; "; + FI; + +. put extension replacement : + link nr DECR replacements length; + replacement := subtext (extension. replacements, link nr + 1, + link nr + code (extension. replacements SUB link nr) ); + put replacement; + +. put char code : + IF (char code >= 32 AND char code <= 122) OR + (char code >= 214 AND char code <= 223) OR + char code = 124 OR char code = 126 OR char code = 251 + THEN z CAT "(* "; + z CAT code (char code); + z CAT " *) """""; + ELSE z CAT " """""; + FI; + z CAT text 3 (char code); + z CAT """"""; + +. put char pitch : + z CAT ","; + z CAT text (pitch, 5); + +. put replacement : + decode (replacement); + z CAT ", """; + z CAT replacement; + z CAT """;" + +END PROC create font file; + + +PROC put z : + + putline (font file, z); + cout (lines (font file)); + z := " "; + +END PROC put z; + + +PROC decode (TEXT VAR string) : + + INT VAR p; + change all (string, """", """"""); + p := pos (string, ""0"", ""31"", 1); + WHILE p <> 0 + REP change (string, p, p, """" + text (code(string SUB p)) + """"); + p := pos (string, ""0"", ""31"", p); + PER; + p := pos (string, ""127"", ""255"", 1); + WHILE p <> 0 + REP change (string, p, p, """" + text (code(string SUB p)) + """"); + p := pos (string, ""127"", ""255"", p); + PER; + +END PROC decode; + + +TEXT PROC text 3 (INT CONST value) : + + buffer := text (value, 3); + change all (buffer, " ", "0"); + buffer + +END PROC text 3; + +END PACKET font convertor; + diff --git a/system/std.zusatz/1.8.7/src/free channel b/system/std.zusatz/1.8.7/src/free channel new file mode 100644 index 0000000..3814f9d --- /dev/null +++ b/system/std.zusatz/1.8.7/src/free channel @@ -0,0 +1,430 @@ +PACKET free channel DEFINES (* Autor: J.Liedtke *) + (* Stand: 10.06.86 *) + FCHANNEL , + := , + free channel , + open , + close , + out , + in , + dialogue , + save , + fetch : + + + +LET ack = 0 , + nak = 1 , + error nak = 2 , + empty message code = 256 , + long message code = 257 , + file send code = 1024 , + file receive code = 2048 , + open code = 1000 , + close code = 1001 , + + file type = 1003 ; + +INT CONST task not existing := - 1 ; + + +TYPE FCHANNEL = STRUCT (TASK server, TEXT input buffer, server name) ; + +INT VAR message code , response code ; +TASK VAR partner ; +DATASPACE VAR ds ; + +BOUND TEXT VAR msg ; +TEXT VAR response, char, esc char , record ; + +FILE VAR file ; + + +OP := (FCHANNEL VAR dest, FCHANNEL CONST source) : + + dest.server := source.server ; + dest.input buffer := "" ; + dest.server name := source.server name ; + open (dest) + +ENDOP := ; + +FCHANNEL PROC free channel (TEXT CONST channel name) : + + FCHANNEL:(niltask,"", channel name) + +ENDPROC free channel ; + +PROC open (FCHANNEL VAR channel) : + + INT VAR receipt ; + + initialize message dataspace ; + send open code ; + IF receipt <> ack + THEN errorstop ("channel not free") + FI . + +initialize message dataspace : + forget (ds) ; + ds := nilspace . + +send open code : + ping pong (channel.server, open code, ds, receipt) ; + IF receipt = task not existing + THEN channel.server := task (channel.server name) ; + ping pong (channel.server, open code, ds, receipt) + FI . + +ENDPROC open ; + +PROC close (FCHANNEL VAR channel) : + + forget (ds) ; + ds := nilspace ; + call (channel.server, close code, ds, response code) + +ENDPROC close ; + +PROC close (TEXT CONST channel server) : + + forget (ds) ; + ds := nilspace ; + call (task (channel server), close code, ds, response code) + +ENDPROC close ; + + +PROC out (FCHANNEL VAR channel, TEXT CONST message) : + + send message ; + get response . + +send message : + IF message = "" + THEN call (channel.server, empty message code, ds, response code) + ELSE msg := ds ; + CONCR (msg) := message ; + call (channel.server, long message code, ds, response code) + FI . + +get response : + IF response code < 0 + THEN errorstop ("channel not ready") + ELIF response code < 256 + THEN channel.input buffer CAT code (response code) + ELIF response code = long message code + THEN msg := ds ; + channel.input buffer CAT CONCR (msg) + FI . + +ENDPROC out ; + +PROC in (FCHANNEL VAR channel, TEXT VAR response) : + + out (channel, "") ; + response := channel.input buffer ; + channel.input buffer := "" + +ENDPROC in ; + +PROC save (FCHANNEL VAR channel, TEXT CONST file name, control chars) : + + prepare ds ; + call (channel.server, file send code, ds, response code) ; + IF response code = error nak + THEN BOUND TEXT VAR error msg := ds ; + errorstop (error msg) + FI . + +prepare ds : + forget (ds) ; + ds := old (file name, file type) ; + FILE VAR f := sequential file (modify, ds) ; + headline (f, control chars) . + +ENDPROC save ; + +PROC fetch (FCHANNEL VAR channel, TEXT CONST file name, control chars) : + + IF NOT exists (file name) COR yes ("""" + file name + """ loeschen") + THEN fetch first part ; + WHILE more to fetch REP + fetch next part + PER + FI . + +fetch first part : + INT VAR part := 0 ; + receive file (channel, file name, control chars) . + +fetch next part : + part INCR 1 ; + receive file (channel, file name + "." + text (part), control chars) . + +more to fetch : response code = file receive code . + +ENDPROC fetch ; + +PROC receive file (FCHANNEL VAR channel,TEXT CONST file name, control chars): + + prepare ds ; + call (channel.server, file receive code, ds, response code); + IF response code = error nak + THEN BOUND TEXT VAR error msg := ds ; + errorstop (error msg) + ELSE forget (file name, quiet) ; + copy (ds, file name) ; + forget (ds) ; + ds := nilspace ; + FI . + +prepare ds : + forget (ds) ; + ds := nilspace ; + BOUND TEXT VAR ctl := ds ; + ctl := control chars . + +ENDPROC receive file ; + + +PROC dialogue (FCHANNEL CONST channel, TEXT CONST esc) : + + forget (ds) ; + ds := nilspace ; + partner := channel.server ; + esc char := esc ; + enable stop ; + + response code := empty message code ; + REP + get and send message charety ; + out response option + PER . + +get and send message charety : + IF response code = empty message code + THEN char := incharety (10) + ELSE char := incharety + FI ; + IF char = "" + THEN call (partner, empty message code, ds, response code) + ELIF char = esc char + THEN LEAVE dialogue + ELSE call (partner, code (char), ds, response code) + FI . + +out response option : + IF response code < 256 + THEN out (code (response code)) + ELIF response code = long message code + THEN msg := ds ; + out (CONCR (msg)) + FI . + +ENDPROC dialogue ; + +PROC free channel (INT CONST nr) : + + INT CONST my channel := nr ; + break ; + disable stop ; + REP + wait (ds, message code, partner) ; + IF message code = open code + THEN connect to my channel ; + use channel ; + break (quiet) + ELIF message code >= 0 + THEN send (partner, nak, ds) + FI + PER . + +use channel : + ping pong (partner, ack, ds, message code) ; + WHILE message code <> close code AND message code >= 0 REP + IF message code <= long message code THEN dialogue + ELIF message code = file receive code THEN receive file + ELIF message code = file send code THEN send file + ELIF message code = open code THEN ignore open + ELSE errorstop ("falsche Sendung") + FI + UNTIL is error PER ; + IF is error + THEN send error message + ELSE send handshake ack + FI . + +dialogue : + IF message code < 256 + THEN out (code (message code)) + ELIF message code = long message code + THEN msg := ds ; + out (CONCR (msg)) + FI ; + response := incharety (1) ; + IF response = "" + THEN ping pong (partner, empty message code, ds, message code) + ELSE short or long response + FI . + +short or long response : + char := incharety ; + IF char = "" + THEN short response + ELSE long response + FI . + +short response : + ping pong (partner, code (response), ds, message code) . + +long response : + msg := ds ; + response CAT char ; + msg := response ; + REP + cat input (msg, char) ; + msg CAT char + UNTIL char = "" OR LENGTH msg > 500 PER ; + ping pong (partner, long message code, ds, message code) . + +connect to my channel : + continue (my channel) ; + WHILE is error REP + clear error ; + pause (100) ; + continue (my channel) + PER . + +send handshake ack : + send (partner, ack, ds) . + +send error message : + forget (ds) ; + ds := nilspace ; + BOUND TEXT VAR error msg := ds ; + error msg := error message ; + clear error ; + send (partner, error nak, ds) . + +ignore open : + ping pong (partner, ack, ds, message code) . + +ENDPROC free channel ; + +PROC send file : + + enable stop ; + file := sequential file (input,ds) ; + get control chars ; + skip chars ; + REP + getline (file, record) ; + out (record) ; + end of line + UNTIL eof (file) PER ; + end of transmission ; + send ack reply . + +get control chars : + TEXT CONST + control chars := headline (file) , + end of file char := control chars SUB 1 , + end of line char := control chars SUB 2 , + handshake char := control chars SUB 3 . + +end of line : + out (end of line char) ; + IF handshake char <> "" + THEN wait for handshake + FI . + +wait for handshake : + REP + char := incharety (300) ; + IF char = "" + THEN errorstop ("timeout") + FI + UNTIL char = handshake char PER . + +end of transmission : + skip chars ; + out (end of file char) . + +skip chars : + WHILE incharety (3) <> "" REP PER . + +send ack reply : + forget (ds) ; + ds := nilspace ; + ping pong (partner, ack, ds, message code) . + +ENDPROC send file ; + +PROC receive file : + + enable stop ; + get control chars ; + open file ; + INT VAR line no := 0 ; + REP + receive line ; + IF eof received + THEN ping pong (partner, ack, ds, message code) ; + LEAVE receive file + FI ; + putline (file, record) ; + line no INCR 1 + UNTIL near file overflow PER ; + ping pong (partner, file receive code, ds, message code) . + +get control chars : + BOUND TEXT VAR control chars := ds ; + TEXT CONST + end of file char := control chars SUB 1 , + end of line char := control chars SUB 2 , + handshake char := control chars SUB 3 , + handshake prompt := control chars SUB 4 . + +open file : + forget (ds) ; + ds := nilspace ; + file := sequential file (output, ds) . + +receive line : + record := "" ; + REP + cat input (record, char) ; + IF char = "" + THEN wait for char + FI ; + IF char = handshake prompt THEN out (handshake char) + ELIF char = ""9"" THEN expand tabs + ELIF char = ""12"" THEN page + FI + UNTIL char = end of line char OR char = end of file char PER . + +wait for char : + char := incharety (300) ; + IF char = "" + THEN errorstop ("timeout") + ELIF char >= ""32"" + THEN record CAT char + FI . + +expand tabs: + record CAT (8-(LENGTH record MOD 8)) * " " . + +page: + record := "#page# " . + +eof received : + char = end of file char OR (record SUB LENGTH record ) = end of file char . + +near file overflow : + line no > 3999 OR (line no > 3800 AND record = "#page# ") . + +ENDPROC receive file ; + +ENDPACKET free channel ; + diff --git a/system/std.zusatz/1.8.7/src/longint b/system/std.zusatz/1.8.7/src/longint new file mode 100644 index 0000000..e78bb52 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/longint @@ -0,0 +1,423 @@ +PACKET longint DEFINES LONGINT, (* Autoren: S.Baumann,A.Bentrup *) + :=, (* T.Sillke *) + <, (* Stand: 17.03.81 *) + >, + <=, + >=, + <>, + =, + -, + +, + *, + **, + ABS, + abs, + DECR, + DIV, + get, + INCR, + int, + (*last rest,*) + longint, + max, + max longint, + min, + MOD, + put, + random, + SIGN, + sign, + text, + zero: + +TYPE LONGINT = TEXT; + +LONGINT VAR result,aleft,aright; +TEXT VAR ergebnis,x,y,z,h; +INT VAR v byte,slr,sll; +INT CONST snull :: code("0"), mtl :: 300 ; +TEXT CONST negativ :: code(127),max digit :: code(99),null :: code(0), + overflow :: "LONGINT overflow",eins :: code(1); +BOOL VAR vorl,vorr,vleft,vright; + +OP := (LONGINT VAR left, LONGINT CONST right) : + CONCR(left) := CONCR(right) +END OP :=; + +BOOL OP < (LONGINT CONST left,right) : + slr := sign(right)*length(right); + sll := sign(left )*length(left ); + IF slr <> sll THEN + IF slr > sll THEN TRUE ELSE FALSE FI + ELSE IF slr>0 + THEN CONCR(left) < CONCR(right) + ELSE CONCR(left) > CONCR(right) FI + FI +END OP < ; + +BOOL OP > (LONGINT CONST left,right) : + slr := sign(right)*length(right); + sll := sign(left )*length(left ); + IF slr <> sll THEN + IF slr < sll THEN TRUE ELSE FALSE FI + ELSE IF slr>0 + THEN CONCR(left) > CONCR(right) + ELSE CONCR(left) < CONCR(right) FI + FI +END OP > ; + +BOOL OP <= (LONGINT CONST left,right) : + NOT (left > right) +END OP <=; + +BOOL OP >= (LONGINT CONST left,right) : + NOT (left < right) +END OP >=; + +BOOL OP <> (LONGINT CONST left,right) : + CONCR (left) <> CONCR (right) +END OP <>; + +BOOL OP = (LONGINT CONST left,right) : + CONCR (left) = CONCR (right) +END OP = ; + +LONGINT OP - (LONGINT CONST arg) : + SELECT code(CONCR(arg)SUB1) OF + CASE 0 : zero + CASE 127: LONGINT : (subtext(CONCR(arg),2)) + OTHERWISE LONGINT : (negativ + CONCR(arg)) + END SELECT +END OP -; + +LONGINT OP + (LONGINT CONST arg) : arg END OP +; + +LONGINT OP - (LONGINT CONST left,right) : + IF CONCR(left ) = null THEN LEAVE - WITH -right + ELIF CONCR(right) = null THEN LEAVE - WITH left + ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI; + betrag(left,right); + BOOL CONST betrag max :: aleft > aright; + IF betrag max + THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright)) + ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI; + kuerze fuehrende nullen(CONCR(result),null); + IF vleft XOR betrag max THEN -result ELSE result FI +END OP -; + +LONGINT OP + (LONGINT CONST left,right) : + IF sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI; + betrag(left,right); + IF aleft > aright + THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright)) + ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI; + IF vleft THEN result ELSE -result FI +END OP +; + +LONGINT OP * (LONGINT CONST left,right) : + IF CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero + ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI; + betrag(left,right); + IF aleft < aright + THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft )) + ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright)) FI; + IF length(CONCR(result)) = mtl THEN errorstop(overflow) FI; + IF vleft XOR vright THEN -result ELSE result FI +END OP *; + +LONGINT OP ** (LONGINT CONST arg,exp) : + IF exp > longint(max int) THEN errorstop (overflow) FI; + arg ** int(exp) +END OP **; + +LONGINT OP ** (LONGINT CONST arg,INT CONST exp) : + IF exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp") + ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI; + IF exp = 0 THEN one + ELIF exp = 1 THEN arg + ELIF sign(arg) = -1 AND exp MOD 2 <> 0 + THEN -LONGINT:(CONCR(abs(arg))EXPexp) + ELSE LONGINT:(CONCR(abs(arg))EXPexp) FI +END OP **; + +LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS; + +LONGINT PROC abs (LONGINT CONST a) : + IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI +END PROC abs; + +OP DECR (LONGINT VAR result,LONGINT CONST ab) : + result := result - ab; +END OP DECR; + +LONGINT OP DIV (LONGINT CONST left,right) : + IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI; + betrag(left,right); h := CONCR(aright); + y := null + CONCR(aleft ); vorl := vleft; + z := null + CONCR(aright); vorr := vright; + IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI; + INT VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw; + BOOL VAR sh :: length(z) <> 2; + IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI; + CONCR(result) := ""; + FOR i FROM 0 UPTO length(y)-length(z) REP + laufe eine abschaetzung durch; + CONCR (result) CAT code(try) + PER; kuerze fuehrende nullen(y,null); + IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI; + IF vleft XOR vright THEN -result ELSE result FI. + + laufe eine abschaetzung durch : + zw := 100*code(y SUB i+1) + code(y SUB i+2); + IF zw < 3276 AND sh THEN IF zw < 327 + THEN try := min((100*zw + code(ySUBi+3)) DIV cr3, 99) + ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI + ELSE try := min( zw DIV cr1, 99) FI; + x := z MUL code(try); + WHILE x > subtext(y,i+1,i+length(x)) REP + try DECR 1; x := x SUB z PER; + replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x) +END OP DIV; + +PROC get (LONGINT VAR result) : + get (ergebnis); + result := longint(ergebnis); +END PROC get; + +PROC get (FILE VAR file,LONGINT VAR result) : + get(file,ergebnis); + result := longint(ergebnis); +END PROC get; + +OP INCR (LONGINT VAR result,LONGINT CONST dazu) : + result := result + dazu; +END OP INCR; + +INT PROC int (LONGINT CONST longint) : + IF length(longint) > 3 + THEN max int + 1 + ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint)); + (code(ergebnis SUB 1) * 10000 + + code(ergebnis SUB 2) * 100 + + code(ergebnis SUB 3)) * sign(longint) + FI +END PROC int; + +LONGINT PROC longint (INT CONST int) : + CONCR(result) := code( abs(int) DIV 10000) + + code((abs(int) MOD 10000) DIV 100) + + code( abs(int) MOD 100); + kuerze fuehrende nullen (CONCR(result),null); + IF int < 1 THEN -result ELSE result FI +END PROC longint; + +LONGINT PROC longint (TEXT CONST text) : + INT VAR i; + ergebnis := compress(text); + BOOL VAR minus :: (ergebnisSUB1) = "-"; + IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI; + kuerze fuehrende nullen(ergebnis,"0"); + kuerze die unzulaessigen zeichen aus ergebnis; + schreibe ergebnis im hundertersystem in result; + result mit vorzeichen. + + kuerze die unzulaessigen zeichen aus ergebnis : + ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen). + letztes zulaessiges zeichen : + FOR i FROM 1 UPTO length(ergebnis) REP + UNTIL pos("0123456789", ergebnis SUB i) = 0 PER; + i - 1. + schreibe ergebnis im hundertersystem in result : + sll := length(ergebnis); + IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI; + i := 1; CONCR(result) := ""; + REP schreibe ein zeichen im hundertersystem in result; + i INCR 2 + UNTIL i >= sll PER. + schreibe ein zeichen im hundertersystem in result : + CONCR(result) CAT code((code(ergebnis SUB i ) - snull) * 10 + + code(ergebnis SUB i + 1) - snull). + result mit vorzeichen : + IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI +END PROC longint; + +LONGINT PROC max (LONGINT CONST left,right) : + IF left > right THEN left ELSE right FI +END PROC max; + +LONGINT PROC max longint : + LONGINT : ((mtl - 1) * max digit) +END PROC max longint; + +LONGINT PROC min (LONGINT CONST left,right) : + IF left < right THEN left ELSE right FI +END PROC min; + +LONGINT OP MOD (LONGINT CONST left,right) : + IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI; + result := left DIV right; last rest +END OP MOD; + +PROC put (LONGINT CONST longint) : + INT VAR i :: 1,zwei ziffern; + IF sign(longint) = -1 THEN out("-"); i:=2 FI; + out(text(code(CONCR(longint) SUB i))); + FOR i FROM i + 1 UPTO length(CONCR(longint)) REP + zwei ziffern := code(CONCR(longint) SUB i); + out(code(zwei ziffern DIV 10 + snull)); + out(code(zwei ziffern MOD 10 + snull)); + PER;out(" ") +END PROC put; + +PROC put (FILE VAR file,LONGINT CONST longint) : + put(file,text(longint)); +END PROC put; + +LONGINT PROC random (LONGINT CONST lower bound,upper bound) : + INT VAR i; x := CONCR(upper bound - lower bound - one); y := ""; + FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER; + upper bound - (LONGINT : (y) MOD LONGINT : (x)) +END PROC random; + +INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN; + +INT PROC sign (LONGINT CONST arg) : + SELECT code(CONCR(arg) SUB 1) OF + CASE 0 : 0 + CASE 127 : -1 + OTHERWISE 1 + END SELECT +END PROC sign; + +TEXT PROC text (LONGINT CONST longint) : + INT VAR i::1,zwei ziffern; ergebnis := ""; + IF sign(longint) = -1 THEN ergebnis := "-"; i:=2 FI; + ergebnis CAT text (code (CONCR (longint) SUB i ) ) ; + FOR i FROM i+1 UPTO length(CONCR(longint)) REP + zwei ziffern := code(CONCR(longint) SUB i); + ergebnis CAT code(zwei ziffern DIV 10 + snull); + ergebnis CAT code(zwei ziffern MOD 10 + snull) + PER; ergebnis +END PROC text; + +TEXT PROC text (LONGINT CONST longint,INT CONST length) : + x := text(longint); sll := LENGTH x; + IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI +END PROC text; + +LONGINT PROC last rest : + IF y=null THEN LEAVE last rest WITH zero FI; + IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null); + vorl := TRUE FI; + IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y) +END PROC last rest; + +LONGINT PROC zero : LONGINT : (null) END PROC zero; +LONGINT PROC one : LONGINT : (""1"") END PROC one; + + +(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *) + +TEXT OP ADD (TEXT CONST left,right) : + INT VAR carrybit :: 0,i,dif :: length(left) - length(right); + ergebnis := left; + FOR i FROM length(left) DOWNTO dif + 1 REP + replace(ergebnis,i,das result der addition) + PER; + IF carrybit = 1 THEN addiere den uebertrag FI; + ergebnis. + + das result der addition : + v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit); + IF v byte > 99 + THEN carrybit := 1; code(v byte - 100) + ELSE carrybit := 0; code(v byte) + FI. + addiere den uebertrag : + FOR i FROM i DOWNTO 1 + WHILE (ergebnis SUB i) >= max digit REP + replace(ergebnis,i,null) + PER; + IF (ergebnis SUB 1) = null OR dif = 0 + THEN pruefe auf longint overflow + ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1)) + FI. + pruefe auf longint overflow : + IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI; + ergebnis := eins + ergebnis +END OP ADD; + +PROC betrag (LONGINT CONST a, b) : + vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ; + IF vleft THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI; + IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI +END PROC betrag; + +TEXT OP EXP (TEXT CONST arg,INT CONST exp) : + INT VAR zaehler :: exp; + x := arg; z := eins; + REP IF zaehler MOD 2 = 1 THEN z := z MUL x FI; + zaehler := zaehler DIV 2; x := x MUL x + UNTIL zaehler = 1 PER; + x MUL z +END OP EXP; + +PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) : + INT VAR i; + text := subtext(text,erste nicht snull). + + erste nicht snull : + FOR i FROM 1 UPTO length (text) - 1 REP + UNTIL (text SUB i) <> snull PER; + i +END PROC kuerze fuehrende nullen; + +INT PROC length (LONGINT CONST a) : + IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI +END PROC length; + +TEXT OP MUL (TEXT CONST left,right) : + INT VAR i,j,carrybit,v,w; + ergebnis := (length(left) + length(right) - 1) * null; + FOR i FROM length(ergebnis) DOWNTO length(left) REP + v := i - length(left); w := length(right) - length(ergebnis) + i; + carrybit := 0; + FOR j FROM length(left) DOWNTO 1 REP + replace(ergebnis,v + j,result der addition) + PER; + replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit)); + PER; + IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI. + + result der addition : + v byte := code(right SUB w) * code(left SUB j) + carrybit + + code(ergebnis SUB v + j); + carrybit := v byte DIV 100; + code(v byte MOD 100) +END OP MUL; + +TEXT OP SUB (TEXT CONST left,right) : + INT VAR carrybit :: 0,i,dif :: length(left) - length(right); + ergebnis := left; + FOR i FROM length(left) DOWNTO dif + 1 REP + replace(ergebnis,i,das result der subtraktion); + PER; + IF carrybit = 1 THEN subtrahiere den uebertrag FI; + ergebnis. + + das result der subtraktion : + v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit); + IF v byte < 0 + THEN carrybit := 1;code(v byte + 100) + ELSE carrybit := 0;code(v byte) + FI. + subtrahiere den uebertrag : + FOR i FROM i DOWNTO 2 + WHILE (ergebnis SUB i) = null REP + replace(ergebnis,i,max digit) + PER; + replace(ergebnis,i,code(code(ergebnis SUB i) - 1)) +END OP SUB; + +END PACKET longint; + diff --git a/system/std.zusatz/1.8.7/src/matrix b/system/std.zusatz/1.8.7/src/matrix new file mode 100644 index 0000000..d9de9fb --- /dev/null +++ b/system/std.zusatz/1.8.7/src/matrix @@ -0,0 +1,482 @@ +PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 16.06.86 wk *) + :=, sub, (* Autor : H.Indenbirken *) + row, column, + COLUMNS, + ROWS, + DET, + INV, + TRANSP, + transp, + replace row, replace column, + replace element, + get, put, + =, <>, + +, -, * : + +TYPE MATRIX = STRUCT (INT rows, columns, VECTOR elems); +TYPE INITMATRIX = STRUCT (INT rows, columns, REAL value, BOOL idn); + +MATRIX VAR a :: idn (1); +INT VAR i; + +(**************************************************************************** +PROC dump (MATRIX CONST m) : + put line (text (m.rows) + " Reihen, " + text (m.columns) + " Spalten."); + dump (m.elems) . + +END PROC dump; +****************************************************************************) + +OP := (MATRIX VAR l, MATRIX CONST r) : + CONCR (l) := CONCR (r); +END OP :=; + +OP := (MATRIX VAR l, INITMATRIX CONST r) : + l.rows := r.rows; + l.columns := r.columns; + l.elems := vector (r.rows*r.columns, r.value); + IF r.idn + THEN idn FI . + +idn : + INT VAR i; + FOR i FROM 1 UPTO r.rows + REP replace (l.elems, calc pos (l.columns, i, i), 1.0) PER + +END OP :=; + +INITMATRIX PROC matrix (INT CONST rows, columns, REAL CONST value) : + IF rows <= 0 + THEN errorstop ("PROC matrix : rows <= 0") + ELIF columns <= 0 + THEN errorstop ("PROC matrix : columns <= 0") FI; + + INITMATRIX : (rows, columns, value, FALSE) + +END PROC matrix; + +INITMATRIX PROC matrix (INT CONST rows, columns) : + matrix (rows, columns, 0.0) + +END PROC matrix; + +INITMATRIX PROC idn (INT CONST size) : + IF size <= 0 + THEN errorstop ("MATRIX PROC idn : size <= 0") FI; + + INITMATRIX : (size, size, 0.0, TRUE) + +END PROC idn; + +VECTOR PROC row (MATRIX CONST m, INT CONST i) : + VECTOR VAR v :: vector (m.columns); + INT VAR j, k :: 1, pos :: (i-1) * m.columns; + FOR j FROM pos+1 UPTO pos + m.columns + REP replace (v, k, m.elems SUB j); + k INCR 1 + PER; + v + +END PROC row; + +VECTOR PROC column (MATRIX CONST m, INT CONST j) : + VECTOR VAR v :: vector (m.rows); + INT VAR i, k :: j; + FOR i FROM 1 UPTO m.rows + REP replace (v, i, m.elems SUB k); + k INCR m.columns + PER; + v + +END PROC column; + +INT OP COLUMNS (MATRIX CONST m) : + m.columns + +END OP COLUMNS; + +INT OP ROWS (MATRIX CONST m) : + m.rows + +END OP ROWS; + +REAL PROC sub (MATRIX CONST a, INT CONST row, column) : + a.elems SUB calc pos (a.columns, row, column) + +END PROC sub; + +PROC replace row (MATRIX VAR m, INT CONST rowindex, VECTOR CONST rowvalue) : + test ("PROC replace row : ", "LENGTH rowvalue", "COLUMNS m", + LENGTH rowvalue, m.columns); + test ("PROC replace row : row ", rowindex, m.rows); + + INT VAR i, pos :: (rowindex-1) * m.columns; + FOR i FROM 1 UPTO m.columns + REP replace (m.elems, pos+i, rowvalue SUB i) PER + +END PROC replace row; + +PROC replace column (MATRIX VAR m, INT CONST columnindex, + VECTOR CONST columnvalue) : + test ("PROC replace column : ", "LENGTH columnvalue", "ROWS m", + LENGTH columnvalue, m.rows); + test ("PROC replace column : column ", columnindex, m.columns); + + INT VAR i; + FOR i FROM 1 UPTO m.rows + REP replace (m.elems, calc pos (m.columns, i, columnindex), + columnvalue SUB i) PER + +END PROC replace column; + +PROC replace element (MATRIX VAR a, INT CONST row, column, REAL CONST x) : + test ("PROC replace element : row ", row, a.rows); + test ("PROC replace element : column ", column, a.columns); + replace (a.elems, calc pos (a.columns, row, column), x) + +END PROC replace element; + +BOOL OP = (MATRIX CONST l, r) : + IF l.rows <> r.rows + THEN FALSE + ELIF l.columns <> r.columns + THEN FALSE + ELSE l.elems = r.elems FI + +END OP =; + +BOOL OP <> (MATRIX CONST l, r) : + IF l.rows <> r.rows + THEN TRUE + ELIF l.columns <> r.columns + THEN TRUE + ELSE l.elems <> r.elems FI + +END OP <>; + +INT PROC calc pos (INT CONST columns, z, s) : + (z-1) * columns + s +END PROC calc pos; + +MATRIX OP + (MATRIX CONST m) : + m + +END OP +; + +MATRIX OP + (MATRIX CONST l, r) : + test ("MATRIX OP + : ", "ROWS l", "ROWS r", l.rows, r.rows); + test ("MATRIX OP + : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns); + + a := l; + INT VAR i; + FOR i FROM 1 UPTO l.rows * l.columns + REP replace (a.elems, i, (l.elems SUB i) + (r.elems SUB i)) + PER; + a + +END OP +; + +MATRIX OP - (MATRIX CONST m) : + a := m; + INT VAR i; + FOR i FROM 1 UPTO m.rows * m.columns + REP replace (a.elems, i, -a.elems SUB i) + PER; + a + +END OP -; + +MATRIX OP - (MATRIX CONST l, r) : + test ("MATRIX OP - : ", "ROWS l", "ROWS r", l.rows, r.rows); + test ("MATRIX OP - : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns); + + a := l; + INT VAR i; + FOR i FROM 1 UPTO l.rows * l.columns + REP replace (a.elems, i, (l.elems SUB i) - (r.elems SUB i)) + PER; + a + +END OP -; + +MATRIX OP * (REAL CONST x, MATRIX CONST m) : + m*x + +END OP *; + +MATRIX OP * (MATRIX CONST m, REAL CONST x) : + a := m; + INT VAR i; + FOR i FROM 1 UPTO m.rows * m.columns + REP replace (a.elems, i, x*m.elems SUB i) PER; + a + +END OP *; + +VECTOR OP * (VECTOR CONST v, MATRIX CONST m) : + test ("VECTOR OP * : ", "LENGTH v", "ROWS m", LENGTH v, m.rows); + VECTOR VAR result :: vector (m.columns); (*wk*) + INT VAR i; + FOR i FROM 1 UPTO m.columns + REP replace (result, i, v * column (m, i)) PER; + result . + +END OP *; + +VECTOR OP * (MATRIX CONST m, VECTOR CONST v) : + test ("VECTOR OP * : ", "COLUMNS m", "LENGTH v", COLUMNS m, LENGTH v); + VECTOR VAR result :: vector (m.rows); (*wk*) + INT VAR i; + FOR i FROM 1 UPTO m.rows + REP replace (result, i, row (m, i) * v) PER; + result . + +END OP *; + +MATRIX OP * (MATRIX CONST l, r) : + test ("MATRIX OP * : ","COLUMNS l","ROWS r", l.columns, r.rows); + + a.rows := l.rows; + a.columns := r.columns; + a.elems := vector (a.rows*a.columns) + INT VAR i, j; + FOR i FROM 1 UPTO a.rows + REP FOR j FROM 1 UPTO a.columns + REP VECTOR VAR rl :: row (l, i), cr :: column (r, j); + replace (a.elems, calc pos (a.columns, i, j), rl * cr) + PER + PER; + a . + +END OP *; + +PROC get (MATRIX VAR a, INT CONST rows, columns) : + + a := matrix (rows,columns); + INT VAR i, j; + VECTOR VAR v; + FOR i FROM 1 UPTO rows + REP get (v, columns); + store row + PER . + +store row : + FOR j FROM 1 UPTO a.columns + REP replace (a.elems, calc pos (a.columns, i, j), v SUB j) + PER . + +END PROC get; + +PROC put (MATRIX CONST a, INT CONST length, fracs) : + INT VAR i, j; + FOR i FROM 1 UPTO a.rows + REP FOR j FROM 1 UPTO a.columns + REP put (text (sub (a, i, j), length, fracs)) PER; + line (2); + PER + +END PROC put; + +PROC put (MATRIX CONST a) : + INT VAR i, j; + FOR i FROM 1 UPTO a.rows + REP FOR j FROM 1 UPTO a.columns + REP TEXT CONST number :: " " + text (sub (a, i, j)); + put (subtext (number, LENGTH number - 15)) + PER; + line (2); + PER + +END PROC put; + +TEXT VAR error :: ""; +PROC test (TEXT CONST proc, l text, r text, INT CONST left, right) : + IF left <> right + THEN error := proc; + error CAT l text; + error CAT " ("; + error CAT text (left); + error CAT ") <> "; + error CAT r text; + error CAT " ("; + error CAT text (right); + error CAT ")"; + errorstop (error) + FI . + +END PROC test; + +PROC test (TEXT CONST proc, INT CONST i, n) : + IF i < 1 + THEN error := proc; + error CAT "subscript underflow ("; + error CAT text (i); + error CAT ")"; + errorstop (error) + ELIF i > n + THEN error := proc; + error CAT "subscript overflow (i="; + error CAT text (i); + error CAT ", max="; + IF n <= 0 + THEN error CAT "undefined" + ELSE error CAT text (n) FI; + error CAT ")"; + errorstop (error) + FI + +END PROC test; + + +MATRIX OP TRANSP (MATRIX CONST m) : + MATRIX VAR a :: m; + transp (a); + a + +END OP TRANSP; + +PROC transp (MATRIX VAR m) : + INT VAR k :: 1, n :: m.rows*m.columns; + a := m; + FOR i FROM 2 UPTO n + REP replace (m.elems, i, a.elems SUB position) PER; + a := idn (1); + i := m.rows; + m.rows := m.columns; + m.columns := i . + +position : + k INCR m.columns; + IF k > n + THEN k DECR (n-1) FI; + k . +END PROC transp; + +MATRIX OP INV (MATRIX CONST m) : + a := m; + ROW 32 INT VAR pivots; + INT VAR i, j, k :: ROWS a, n :: COLUMNS a, pos; + + IF n <> k + THEN errorstop ("MATRIX OP INV : no square matrix") FI; + + initialisiere die pivotpositionen; + + FOR j FROM 1 UPTO n + REP pivotsuche (a, j, pos); + IF sub (a, pos, pos) = 0.0 + THEN errorstop ("MATRIX OP INV : singular matrix") FI; + zeilentausch (a, j, pos); + merke dir die vertauschung; + transformiere die matrix + PER; + + spaltentausch; + a . + +initialisiere die pivotpositionen : + FOR i FROM 1 UPTO n + REP pivots [i] := i PER . + +merke dir die vertauschung : + IF pos > j + THEN INT VAR hi :: pivots [j]; + pivots [j] := pivots [pos]; + pivots [pos] := hi + FI . + +transformiere die matrix : + REAL VAR h := 1.0/sub (a, j, j); + + FOR k FROM 1 UPTO n + REP IF k <> j + THEN FOR i FROM 1 UPTO n + REP IF i <> j + THEN replace element (a, i, k, sub (a, i, k) - + sub (a, i, j)*sub (a, j, k)*h); + FI + PER; + FI + PER; + + FOR k FROM 1 UPTO n + REP replace element (a, j, k, -h*sub (a, j, k)); + replace element (a, k, j, h*sub (a, k, j)) + PER; + replace element (a, j, j, h) . + +spaltentausch : + VECTOR VAR v :: vector (n); + FOR i FROM 1 UPTO n + REP FOR k FROM 1 UPTO n + REP replace (v, pivots [k], sub(a, i, k)) PER; + replace row (a, i, v) + PER . + +END OP INV; + +REAL OP DET (MATRIX CONST m) : + IF COLUMNS m <> ROWS m + THEN errorstop ("REAL OP DET : no square matrix") FI; + + a := m; + INT VAR i, j, k, n :: COLUMNS m, pos; + REAL VAR merker := 1.0; + FOR j FROM 1 UPTO n + REP pivotsuche (a, j, pos); + IF j<> pos + THEN zeilentausch (a, j, pos); + zeilen tausch merken + FI; + transformiere die matrix + PER; + produkt der pivotelemente . + +transformiere die matrix : + REAL VAR hp := sub(a,j,j); + IF hp = 0.0 + THEN LEAVE DET WITH 0.0 + ELSE REAL VAR h := 1.0/hp; + FI; + FOR i FROM j+1 UPTO n + REP FOR k FROM j+1 UPTO n + REP replace element (a, i, k, sub (a, i, k) - + sub (a, i, j)*h*sub (a, j, k)) + PER + PER . + +produkt der pivotelemente : + REAL VAR produkt :: sub (a, 1, 1); + FOR j FROM 2 UPTO n + REP produkt := produkt * sub (a, j, j) PER; + a := idn (1); + produkt * merker. + +zeilen tausch merken: + merker := merker * (-1.0). + +END OP DET; + +PROC pivotsuche (MATRIX CONST a, INT CONST start pos, INT VAR pos) : + REAL VAR max :: abs (sub (a, start pos, start pos)); + INT VAR i; + pos := start pos; + + FOR i FROM start pos+1 UPTO COLUMNS a + REP IF abs (sub (a, i, start pos)) > max + THEN max := abs (sub (a, i, start pos)); + pos := i + FI + PER . + +END PROC pivotsuche; + +PROC zeilentausch (MATRIX VAR a, INT CONST old pos, pos) : + VECTOR VAR v := row (a, pos); + replace row (a, pos, row (a, old pos)); + replace row (a, old pos, v) . + +END PROC zeilentausch; + +END PACKET matrix; + diff --git a/system/std.zusatz/1.8.7/src/port server b/system/std.zusatz/1.8.7/src/port server new file mode 100644 index 0000000..46c647f --- /dev/null +++ b/system/std.zusatz/1.8.7/src/port server @@ -0,0 +1,164 @@ +PACKET port server: (* Autor : R. Ruland *) + (* Stand : 21.03.86 *) + +INT VAR port station; +TEXT VAR port := "PRINTER"; + +put ("gib Name des Zielspools : "); editget (port); line; +put ("gib Stationsnummer des Zielspools : "); get (port station); + +server channel (15); +spool duty ("Verwalter fuer Task """ + port + + """ auf Station " + text (port station)); + +LET max counter = 10 , + time slice = 300 , + + ack = 0 , + fetch code = 11 , + param fetch code = 21 , + file save code = 22 , + file type = 1003 , + + begin char = ""0"", + end char = ""1""; + + +INT VAR reply, old heap size; +TEXT VAR file name, write pass, read pass, sendername, buffer; +FILE VAR file; + +DATASPACE VAR ds, file ds, send ds; + +BOUND STRUCT (TEXT file name, write pass, read pass, sendername, INT station) VAR msg; +BOUND TEXT VAR error msg ; + +spool manager (PROC save file); + +PROC save file : + + disable stop ; + command dialogue (FALSE); + ds := nilspace; file ds := nilspace; send ds := nil space; + old heap size := heap size; + + REP + execute save file; + + IF is error THEN save error (error message) FI; + + IF heap size > old heap size + 4 + THEN collect heap garbage ; + old heap size := heap size + FI; + + PER + +ENDPROC save file; + + +PROC execute save file : + +enable stop; +forget (file ds) ; file ds := nilspace; +call (father, fetch code, file ds, reply); +IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE save file ds +FI; + +. save file ds : + IF type (file ds) = file type + THEN get file params; + insert file params; + call station (port station, port, file save code, file ds); + ELSE errorstop ("Datenraum hat falschen Typ") + FI; + +. get file params : + forget (ds); ds := nilspace; + call (father, param fetch code, ds, reply); + IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE msg := ds; + file name := msg. file name; + write pass := msg. write pass; + read pass := msg. read pass; + sendername := msg. sender name; + FI; + +. insert file params : + buffer := ""; + in headline (filename); + in headline (write pass); + in headline (read pass); + in headline (sendername); + file := sequential file (input, file ds) ; + headline (file, buffer); + +END PROC execute save file; + + +PROC call station (INT CONST order task station, TEXT CONST order task name, + INT CONST order code, DATASPACE VAR order ds) : + + INT VAR counter := 0; + TASK VAR order task; + disable stop; + REP order task := order task station // order task name; + IF is error CAND pos (error message, "antwortet nicht") > 0 + THEN clear error; + counter := min (max counter, counter + 1); + pause (counter * time slice); + ELSE enable stop; + forget (send ds); send ds := order ds; + call (order task, order code, send ds, reply); + disable stop; + IF reply = ack + THEN forget (order ds); order ds := send ds; + forget (send ds); + LEAVE call station + ELSE error msg := send ds; + errorstop (error msg); + FI; + FI; + PER; + +END PROC call station; + + +TASK OP // (INT CONST station, TEXT CONST name) : + + enable stop; + station / name + +END OP //; + + +PROC in headline (TEXT CONST information) : + IF pos (information, begin char) <> 0 + OR pos (information, end char) <> 0 + THEN errorstop ("Name darf nicht Code 0 oder Code 1 enthalten") FI; + buffer CAT begin char; + buffer CAT information; + buffer CAT end char; +END PROC in headline; + + +PROC save error (TEXT CONST message) : + clear error; + file name CAT "."; + file name CAT sender name; + file name CAT ".ERROR"; + file := sequential file (output, file name); + putline (file, " "); + putline (file, "Uebertragung nicht korrekt beendet "); + putline (file, " "); + put (file, "ERROR :"); put (file, message); + save (file name, public); + clear error; + forget(file name, quiet); +END PROC save error; + +ENDPACKET port server; + diff --git a/system/std.zusatz/1.8.7/src/printer server b/system/std.zusatz/1.8.7/src/printer server new file mode 100644 index 0000000..b1a30bc --- /dev/null +++ b/system/std.zusatz/1.8.7/src/printer server @@ -0,0 +1,99 @@ +PACKET multi user printer : (* Autor : Rudolf Ruland *) + (* Stand : 24.03.86 *) + +INT VAR c; +put ("gib Druckerkanal : "); get (c); + + server channel (c); + station only (FALSE) ; + spool duty ("Ausgabe mit dem Drucker"); + spool control task (myself); + +LET ack = 0 , + + fetch code = 11 , + param fetch code = 21 , + file type = 1003 ; + +INT VAR reply, old heap size, sender station; +TEXT VAR file name, userid, password, sendername; +FILE VAR file ; + +DATASPACE VAR ds, file ds; + +BOUND STRUCT (TEXT file name, userid, password, sendername, INT station) VAR msg; +BOUND TEXT VAR error msg ; + +spool manager (PROC printer); + +PROC printer : + + disable stop ; + command dialogue (FALSE); + ds := nilspace; file ds := nilspace; + continue (server channel) ; + check error ("Kanal belegt"); + + old heap size := heap size ; + REP + execute print ; + + IF is error + THEN put error; + clear error; + FI ; + + IF heap size > old heap size + 4 + THEN collect heap garbage ; + old heap size := heap size + FI + PER + +ENDPROC printer ; + + +PROC execute print : + + enable stop ; + forget (file ds) ; file ds := nilspace ; + call (father, fetch code, file ds, reply) ; + IF reply = ack CAND type (file ds) = file type + THEN get file params; + print file + FI ; + +. get file params : + forget (ds); ds := nilspace; + call (father, param fetch code, ds, reply); + IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE msg := ds; + file name := msg. file name; + userid := msg. userid; + password := msg. password; + sendername := msg. sender name; + sender station := msg. station; + FI; + +. print file : + file := sequential file (input, file ds); + print (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); + +ENDPROC execute print ; + + +PROC check error (TEXT CONST message) : + IF is error + THEN clear error; + rename myself (message); + IF is error THEN clear error; end (myself) FI; + pause (18000); + end (myself); + FI; +END PROC check error; + +ENDPACKET multi user printer ; + diff --git a/system/std.zusatz/1.8.7/src/purge b/system/std.zusatz/1.8.7/src/purge new file mode 100644 index 0000000..55230ff --- /dev/null +++ b/system/std.zusatz/1.8.7/src/purge @@ -0,0 +1,85 @@ +PACKET purge DEFINES purge : + + +TEXT VAR task name, record, file name, dummy ; + +FILE VAR permit ; + + +PROC purge : + + IF exists ("permitted tasks") + THEN access catalogue ; + permit := sequential file (input, "permitted tasks") ; + say (""10""13"TASKS :"10""10""13"") ; + IF myself < supervisor + THEN purge son tasks (brother (supervisor)) + ELSE purge son tasks (myself) + FI + FI ; + IF exists ("permitted files") + THEN permit := sequential file (input, "permitted files") ; + say (""10""13"DATEIEN :"10""10""13"") ; + purge files + FI + +ENDPROC purge ; + +PROC purge son tasks (TASK CONST father task) : + + TASK VAR actual task := son (father task) ; + WHILE NOT is niltask (actual task) REP + purge son tasks (actual task) ; + IF NOT actual task permitted + THEN erase actual task + FI ; + actual task := brother (actual task) + END REP . + +erase actual task : + say ("""") ; say (task name) ; say ("""") ; + IF yes (" loeschen") + THEN end (actual task) + FI . + +actual task permitted : + task name := name (actual task) ; + reset (permit) ; + WHILE NOT eof (permit) REP + getline (permit, record) ; + IF task name = record + THEN LEAVE actual task permitted WITH TRUE + FI + END REP ; + FALSE . + +ENDPROC purge son tasks ; + +PROC purge files : + + begin list ; + get list entry (file name, dummy) ; + WHILE file name <> "" REP + IF NOT file permitted + THEN forget (file name) + FI ; + get list entry (file name, dummy) + END REP . + +file permitted : + IF file name = "permitted tasks" OR file name = "permitted files" + THEN LEAVE file permitted WITH TRUE + FI ; + reset (permit) ; + WHILE NOT eof (permit) REP + getline (permit, record) ; + IF file name = record + THEN LEAVE file permitted WITH TRUE + FI + END REP ; + FALSE . + +ENDPROC purge files ; + +ENDPACKET purge ; + diff --git a/system/std.zusatz/1.8.7/src/referencer b/system/std.zusatz/1.8.7/src/referencer new file mode 100644 index 0000000..2ee65e4 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/referencer @@ -0,0 +1,1077 @@ +(* ------------------- VERSION 10 vom 01.08.86 -------------------- *) +PACKET referencer errors DEFINES report referencer error: + +(* Programm zur Fehlerbehandlung des referencers. + Autor: Rainer Hahn *) + +TEXT VAR fehlerdummy, + message; + +PROC report referencer error (INT CONST error nr, + INT CONST line nr, + TEXT CONST addition): + + einfache fehlermeldung aufbauen; + diese auf terminal ausgeben; + fehlermeldung in fehlerdatei ausgeben. + +einfache fehlermeldung aufbauen: + message := "WARNUNG in Zeile "; + message CAT text (line nr); + message CAT " : "; + message CAT simple message. + +diese auf terminal ausgeben: + line ; + putline (message). + +fehlermeldung in fehlerdatei ausgeben: + note (message); + note line ; + fehlerdummy := " >>> "; + fehlerdummy CAT zusatz; + note (fehlerdummy); + note line. + +simple message: + SELECT error nr OF + CASE 1: "Text Denoter ueber mehr als eine Zeile" + CASE 2: "Nicht beendeter Text Denoter bei Programmende" + CASE 3: "Kommentar ueber mehr als eine Zeile" + CASE 4: "Nicht beendeter Kommentar bei Programmende" + CASE 5: "Ueberdeckung" + CASE 6, 9: "Refinement mehrmals eingesetzt" + CASE 7, 10: "Refinement wird nicht aufgerufen" + CASE 8: "Objekt wird nicht angesprochen" + OTHERWISE "" + ENDSELECT. + +zusatz: + SELECT error nr OF + CASE 1, 2, 3, 4: "Ueber " + addition + " Zeilen" + CASE 5: addition + CASE 6, 7, 8: addition + CASE 9, 10: addition + " in mindestens einer Prozedur" + OTHERWISE "interner Fehler: HRZ Bielefeld benachrichtigen!" + END SELECT. +END PROC report referencer error +END PACKET referencer errors; +(************************************************************************) + +PACKET name table handling + DEFINES NAMETABLE, + empty name table, + put name, + get name, + dump table: + +(* Programm zur Speicherung von Namen. + Autor: Rainer Hahn *) + +LET hash table length = 1024, + hash table length minus one = 1023, + start of name table = 255, + name table length = 2000; + +TYPE NAMETABLE = STRUCT (INT number of entries, + ROW hash table length INT hash table, + ROW name table length INT next, + ROW name table length TEXT name table); + +TEXT VAR dummy, f; + +PROC put name (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer): + INT VAR errechneter index; + hash (name, errechneter index); + IF noch kein eintrag + THEN gaenzlich neuer eintrag + ELSE name in vorhandener kette + FI. + +noch kein eintrag: + n . hash table [errechneter index] = 0. + +gaenzlich neuer eintrag: + n . hash table [errechneter index] := n . number of entries; + neuer eintrag (n, name, pointer). + +name in vorhandener kette: + INT VAR dieser eintrag :: n. hash table [errechneter index]; + REP + IF name ist vorhanden + THEN pointer := dieser eintrag; + LEAVE put name + ELIF kette zu ende + THEN neuer eintrag an vorhandene kette anketten; + neuer eintrag (n, name, pointer); + LEAVE put name + ELSE naechster eintrag in der kette + FI + END REP. + +name ist vorhanden: + n . name table [dieser eintrag] = name. + +kette zu ende: + n . next [dieser eintrag] = 0. + +neuer eintrag an vorhandene kette anketten: + n . next [dieser eintrag] := n . number of entries. + +naechster eintrag in der kette: + dieser eintrag := n . next [dieser eintrag]. +END PROC put name; + +PROC neuer eintrag (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer): + n . name table [n . number of entries] := name; + n . next [n . number of entries] := 0; + pointer := n . number of entries; + n . number of entries INCR 1; + IF n . number of entries > name table length + THEN errorstop ("volle Namenstabelle") + FI +END PROC neuer eintrag; + +PROC hash (TEXT CONST name, INT VAR index) : + INT VAR i; + index := code (name SUB 1); + FOR i FROM 2 UPTO length (name) REP + addmult cyclic + ENDREP. + +addmult cyclic : + index INCR index ; + IF index > hash table length minus one + THEN wrap around + FI; + index := (index + code (name SUB i)) MOD hash table length. + +wrap around : + index DECR hash table length minus one +ENDPROC hash ; + +PROC get name (NAMETABLE CONST n, INT CONST index, TEXT VAR t): + IF index < n . number of entries AND index >= start of name table + THEN t := n . name table [index] + ELSE errorstop ("Interner Fehler 1") + FI +END PROC get name; + +PROC empty name table (NAMETABLE VAR n): +INT VAR i; + n . number of entries := start of name table; + FOR i FROM 1 UPTO hash table length REP + n . hash table [i] := 0 + END REP +END PROC empty name table; + +PROC dump table (NAMETABLE CONST n): + line ; + put ("Bitte Name der Datei, in die die Namenstabelle gehen soll:"); + getline (f); + line ; + file assoziieren; + dump namens ketten; + zusammenfassung. + +file assoziieren: + FILE VAR file :: sequential file (output, f). + +dump namens ketten: + INT VAR i, + anz hash eintraege :: 0, + kette 3 eintraege :: 0; + FOR i FROM 1 UPTO hash table length REP + IF n . hash table [i] <> 0 + THEN anz hash eintraege INCR 1; + INT VAR naechster eintrag :: n . hash table [i]; + dump hash eintrag; + ketten eintraege + FI + END REP. + +dump hash eintrag: + dummy := text (i); + WHILE length (dummy) < 4 REP dummy CAT " " END REP; + dummy CAT ": ". + +ketten eintraege: + INT VAR anz eintraege pro kette :: 0; + WHILE naechster eintrag > 0 REP + anz eintraege pro kette INCR 1; + dummy CAT " "; + dummy CAT text (naechster eintrag); + dummy CAT " -> "; + dummy CAT n . name table [naechster eintrag]; + naechster eintrag := n . next [naechster eintrag]; + END REP; + IF anz eintraege pro kette > 2 + THEN kette 3 eintraege INCR 1 + FI; + putline (file, dummy). + +zusammenfassung: + statistik ueberschrift; + anzahl hash eintraege; + anzahl namens eintraege; + verkettungsfaktor; + anzahl laengerer ketten. + +statistik ueberschrift: + line (file, 2); + dummy := " ---------- "; + dummy CAT "S T A T I S T I K:"; + dummy CAT " ---------- "; + putline (file, dummy); + line (file, 2). + +anzahl hash eintraege: + dummy := "Anzahl Hash-Eintraege (max. "; + dummy CAT text (hash table length); + dummy CAT "): "; + dummy CAT text (anz hash eintraege); + putline (file, dummy). + +anzahl namens eintraege: + dummy := "Anzahl Namen (max. "; + dummy CAT text (name table length - start of name table + 1); + dummy CAT "): "; + dummy CAT text (n . number of entries - start of name table); + putline (file, dummy). + +verkettungsfaktor: + dummy := "Verkettungsfaktor (Anzahl Namen / Anzahl Ketten): "; + dummy CAT text (real (n . number of entries - start of name table) / + real (anz hash eintraege)); + putline (file, dummy). + +anzahl laengerer ketten: + dummy := "Anzahl Ketten > 2 Eintraege: "; + dummy CAT text (kette 3 eintraege); + putline (file, dummy). +END PROC dump table; +END PACKET name table handling; +(***************************************************************************) + +PACKET scanner DEFINES init scanning, + init name table with, + dump name table, + get name, + end scanning, + line number, + symbol: + +(* Programm zum scannen von ELAN-Programmen. + Autor: Rainer Hahn *) + +FILE VAR eingabe; + +DATASPACE VAR ds alt := nilspace, + ds neu := nilspace; + +BOUND NAMETABLE VAR tabelle; + +TEXT VAR zeile, + zeichen, + dummy; + +LET end of program = ""30"", + eop = 1, + identifier = 2, + keyword = 3, + delimiter = 4, + punkt = 46, + doppelpunkt = 58, + init symbol = 30, + assign symbol = 31; + +INT VAR zeilen nr, + zeichen pos; + +PROC init name table with (TEXT CONST worte): +INT VAR index; + forget (ds alt); + ds alt := nilspace; + tabelle := dsalt; + empty name table (CONCR (tabelle)); + INT VAR anf :: 1, + ende :: pos (worte, ",", 1); + WHILE ende > 0 REP + dummy := subtext (worte, anf, ende - 1); + put name (CONCR (tabelle), dummy, index); + anf := ende + 1; + ende := pos (worte, ",", ende + 1) + END REP; + dummy := subtext (worte, anf); + put name (CONCR (tabelle), dummy, index) +END PROC init name table with; + +PROC init scanning (TEXT CONST f): + IF exists (f) + THEN namenstabelle holen; + erste zeile lesen + ELSE errorstop ("Datei existiert nicht") + FI. + +namenstabelle holen: + forget (ds neu); + ds neu := ds alt; + tabelle := ds neu. + +erste zeile lesen: + eingabe := sequential file (input, f); + IF eof (eingabe) + THEN errorstop ("Datei ist leer") + ELSE zeile := ""; + zeilen nr := 0; + zeile lesen; + naechstes non blank zeichen + FI +END PROC init scanning; + +PROC dump name table: + dump table (CONCR (tabelle)) +END PROC dump name table; + +PROC end scanning (TEXT CONST f): + IF anything noted + THEN eingabe := sequential file (modify, f); + note edit (eingabe) + FI +END PROC end scanning; + +PROC get name (INT CONST index, TEXT VAR t): + get name (CONCR (tabelle), index, t) +END PROC get name; + +PROC zeile lesen: + getline (eingabe, zeile); + zeilen nr INCR 1; + cout (zeilen nr); + zeichen pos := 0 +END PROC zeile lesen; + +PROC naechstes non blank zeichen: + REP + zeichen pos := pos (zeile, ""33"", ""254"", zeichen pos + 1); + IF zeichen pos <> 0 + THEN zeichen := (zeile SUB zeichen pos); + LEAVE naechstes non blank zeichen + ELIF eof (eingabe) + THEN zeichen := end of program; + LEAVE naechstes non blank zeichen + ELSE zeile lesen + FI + END REP. +END PROC naechstes non blank zeichen; + +PROC naechstes zeichen: + IF zeichen pos > length (zeile) + THEN IF eof (eingabe) + THEN zeichen := end of program; + LEAVE naechstes zeichen + ELSE zeile lesen + FI + FI; + zeichenpos INCR 1; + zeichen := zeile SUB zeichenpos +END PROC naechstes zeichen; + +INT PROC line number: + IF zeichenpos = pos (zeile, ""33"", ""254"", 1) + THEN zeilen nr - 1 + ELSE zeilen nr + FI +END PROC line number; + +PROC symbol (INT VAR symb, type): + REP + suche naechstes checker symbol + END REP. + +suche naechstes checker symbol: + SELECT code (zeichen) OF + CASE 30: (* end of programn *) + symb := eop; + type := eop; + LEAVE symbol + CASE 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, + 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122: + (* small letters *) + identifier aufsammeln; + put name (CONCR (tabelle), dummy, symb); + type := identifier; + LEAVE symbol + CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, + 82, 83, 84, 85, 86, 87, 88, 89, 90: (* large letters *) + schluesselwort aufsammeln; + put name (CONCR (tabelle), dummy, symb); + type := keyword; + LEAVE symbol + CASE 34: (* " *) + skip text denoter + CASE 40: (* ( *) + IF (zeile SUB zeichen pos + 1) = "*" + THEN skip comment + ELSE symb := code (zeichen); + type := delimiter; + naechstes non blank zeichen; + LEAVE symbol; + FI + CASE 58: (* : *) + IF (zeile SUB zeichenpos + 1) = "=" + THEN symb := assign symbol; + zeichenpos INCR 1 + ELIF (zeile SUB zeichenpos + 1) = ":" + THEN symb := init symbol; + zeichenpos INCR 1 + ELSE symb := doppelpunkt + FI; + type := delimiter; + naechstes non blank zeichen; + LEAVE symbol + CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: (* 0 - 9 *) + int denoter skippen; + IF zeichen = "." + THEN naechstes non blank zeichen; + IF digit + THEN real denoter skippen + ELSE symb := punkt; + type := delimiter; + LEAVE symbol + FI + FI + CASE 41, 44, 46, 59, 61: (* ) , . ; = *) + symb := code (zeichen); + type := delimiter; + naechstes non blank zeichen; + LEAVE symbol + OTHERWISE naechstes non blank zeichen + END SELECT. +END PROC symbol; + +PROC real denoter skippen: + int denoter skippen; + IF zeichen = "e" + THEN naechstes non blank zeichen; + int denoter skippen + FI +END PROC real denoter skippen; + +PROC int denoter skippen: + naechstes non blank zeichen; + WHILE zeichen >= "0" AND zeichen <= "9" REP + naechstes non blank zeichen + ENDREP; + zeichenpos DECR 1; + naechstes non blank zeichen +END PROC int denoter skippen; + +PROC identifier aufsammeln: + dummy := zeichen; + REP + naechstes non blank zeichen; + IF small letter or digit + THEN dummy CAT zeichen + ELSE LEAVE identifier aufsammeln + FI + END REP +END PROC identifier aufsammeln; + +PROC schluesselwort aufsammeln: + dummy := ""; + sammle schluesselwort; + IF dummy = "END" + THEN noch einmal + FI. + +sammle schluesselwort: + WHILE large letter REP + dummy CAT zeichen; + naechstes zeichen + END REP; + IF zeichen = " " + THEN naechstes non blank zeichen + FI. + +noch einmal: + sammle schluesselwort +END PROC schluesselwort aufsammeln; + +PROC skip text denoter: + INT VAR anz zeilen :: 0; + zeichen pos := pos (zeile, """", zeichenpos + 1); + WHILE zeichen pos = 0 REP + naechste zeile einlesen; + zeichen pos := pos (zeile, """"); + END REP; + ende text denoter. + +ende text denoter: + IF anz zeilen > 1 + THEN report referencer error (1, zeilen nr, text (anz zeilen)) + FI; + naechstes non blank zeichen. + +naechste zeile einlesen: + IF eof (eingabe) + THEN report referencer error (2, zeilen nr, text (anz zeilen)); + zeichen := end of program; + LEAVE skip text denoter + ELSE zeile lesen; + anz zeilen INCR 1 + FI. +END PROC skip text denoter; + +PROC skip comment: + INT VAR anz zeilen :: 0; + zeichen pos := pos (zeile, "*)", zeichenpos + 2); + WHILE zeichen pos = 0 REP + naechste zeile einlesen; + zeichen pos := pos (zeile, "*)"); + END REP; + ende comment. + +ende comment: + IF anz zeilen > 1 + THEN report referencer error (3, zeilen nr, text (anz zeilen)) + FI; + zeichen pos INCR 2; + naechstes non blank zeichen. + +naechste zeile einlesen: + IF eof (eingabe) + THEN report referencer error (4, zeilen nr, text (anz zeilen)); + zeichen := end of program; + LEAVE skip comment + ELSE zeile lesen; + anz zeilen INCR 1 + FI. +END PROC skip comment; + +BOOL PROC small letter or digit: + (zeichen >= "0" AND zeichen <= "9") OR (zeichen >= "a" AND zeichen <= "z") +END PROC small letter or digit; + +BOOL PROC small letter: + zeichen >= "a" AND zeichen <= "z" +END PROC small letter; + +BOOL PROC large letter: + zeichen >= "A" AND zeichen <= "Z" +END PROC large letter; + +BOOL PROC digit: + zeichen >= "0" AND zeichen <= "9" +END PROC digit; +END PACKET scanner; +(*************************************************************************) +PACKET referencer2 DEFINES referencer: + +(* Programm fuer den 'referencer' + Autor: Rainer Hahn *) + +INT VAR symb, + typ, + max index; + +TEXT VAR dummy, + dummy2, + name; + +DATASPACE VAR ds; + +BOUND ROW max TEXT VAR liste; + +FILE VAR f; + +BOOL VAR initialisiert :: FALSE, + symbol bereits geholt, + globale deklarationen; + +LET max = 1751, + global text = "<--G", + local text = "<--L", + refinement text = "<--R", + procedure text = "<--P", + eop = 1, + identifier = 2, + keyword = 3, + init symbol = 30, + assign symbol = 31, + klammer auf = 40, + klammer zu = 41, + komma = 44, + punkt = 46, + doppelpunkt = 58, + semikolon = 59, + proc symbol = 255, + end proc symbol = 256, + packet symbol = 257, + end packet symbol = 258, + type symbol = 259, + var symbol = 260, + const symbol = 261, + let symbol = 262, + leave symbol = 263, + op symbol = 264, + endop symbol = 265, + endif symbol = 266, + fi symbol = 266; + +PROC referencer: + referencer (last param) +END PROC referencer; + +PROC referencer (TEXT CONST check file): + referencer (check file, check file + ".r") +END PROC referencer; + +PROC referencer (TEXT CONST check file, dump file): + IF exists (check file) + THEN dump file ggf loeschen + ELSE errorstop ("Eingabe-Datei nicht vorhanden") + FI; + disable stop; + start referencing (check file, dump file); + forget (ds); + enable stop. + +dump file ggf loeschen: + IF exists (dump file) + THEN forget (dump file, quiet) + FI. +END PROC referencer; + +PROC start referencing (TEXT CONST check file, dump file): + enable stop; + ueberschrift; + initialisierung; + verkuerzte syntax analyse; + line ; + in dump file kopieren (dump file); + line ; + end scanning (check file). + +ueberschrift: + page; + put ("REFERENCER:"); + put (check file); + put ("->"); + putline (dump file). + +initialisierung: + IF NOT initialisiert + THEN init name table with +("PROC,ENDPROC,PACKET,ENDPACKET,TYPE,VAR,CONST,LET,LEAVE,OP,ENDOP,ENDIF,FI"); + initialisiert := TRUE + FI; + ds := nilspace; + liste := ds; + max index := end op symbol; + dummy := checkfile. + +verkuerzte syntax analyse: + globale deklarationen := TRUE; + line ; + init scanning (dummy); + symbol bereits geholt := FALSE; + REP + IF symbol bereits geholt + THEN symbol bereits geholt := FALSE + ELSE symbol (symb, typ) + FI; + IF typ = keyword + THEN nach schluesselwort verarbeiten + ELIF symb = punkt + THEN ggf refinement aufnehmen + ELIF typ = identifier + THEN identifier aufnehmen und ggf aktuelle parameter liste + FI + UNTIL typ = eop ENDREP. + +identifier aufnehmen und ggf aktuelle parameter liste: + in die liste (symb, ""); + symbol (symb, typ); + IF symb = klammer auf + THEN aktuelle parameter aufnehmen + ELSE symbol bereits geholt := TRUE + FI. + +nach schluesselwort verarbeiten: + SELECT symb OF + CASE let symbol: + let deklarationen aufsammeln + CASE packet symbol: + namen des interface aufsammeln + CASE end packet symbol: + skip naechstes symbol + CASE var symbol, const symbol: + datenobjekt deklaration aufnehmen + CASE proc symbol: + globale deklarationen := FALSE; + prozedur name und ggf parameter aufsammeln + CASE end proc symbol: + globale deklarationen := TRUE; + skip naechstes symbol + CASE op symbol: + globale deklarationen := FALSE; + operatornamen skippen und ggf parameter aufsammeln + CASE end op symbol: + globale deklarationen := TRUE; + skip until (semikolon) + CASE type symbol: + namen der typ definition aufsammeln + CASE leave symbol: + skip naechstes symbol + OTHERWISE: + ENDSELECT. + +skip naechstes symbol: + symbol (symb, typ). +END PROC start referencing; + +PROC aktuelle parameter aufnehmen: + REP + symbol (symb, typ); + IF typ = identifier + THEN in die liste (symb, "") + FI + UNTIL symb = klammer zu END REP. +END PROC aktuelle parameter aufnehmen; + +PROC ggf refinement aufnehmen: + symbol (symb, typ); + symbol bereits geholt := TRUE; + WHILE typ = identifier REP + doppelpunkt oder selektor + END REP. + +doppelpunkt oder selektor: + INT CONST letzter id :: symb; + symbol (symb, typ); + IF symb = doppelpunkt + THEN in die liste (letzter id, refinement text); + LEAVE ggf refinement aufnehmen + ELSE in die liste (letzter id, ""); + IF symb = punkt + THEN symbol (symb, typ) + ELSE LEAVE ggf refinement aufnehmen + FI + FI +END PROC ggf refinement aufnehmen; + +PROC namen des interface aufsammeln: + packet name ueberspringen; + namen der schnittstelle aufsammeln. + +packet name ueberspringen: + symbol (symb, typ). + +namen der schnittstelle aufsammeln: + REP + symbol (symb, typ); + IF typ = identifier + THEN in die liste (symb, "") + FI + UNTIL symb = doppelpunkt END REP. +END PROC namen des interface aufsammeln; + +PROC let deklarationen aufsammeln: + REP + symbol (symb, typ); + IF typ = identifier + THEN let name aufnehmen + ELIF typ = keyword + THEN bis zum komma oder semikolon + FI; + UNTIL symb = semikolon END REP. + +let name aufnehmen: + IF globale deklarationen + THEN in die liste (symb, global text) + ELSE in die liste (symb, "") + FI; + REP + symbol (symb, typ); + IF typ = identifier + THEN in die liste (symb, "") + FI + UNTIL symb = komma OR symb = semikolon END REP. +END PROC let deklarationen aufsammeln; + +PROC namen der typ definition aufsammeln: + REP + symbol (symb, typ); + bis zum komma oder semikolon + UNTIL symb = semikolon END REP +END PROC namen der typ definition aufsammeln; + +PROC bis zum komma oder semikolon: + INT VAR anz klammern :: 0; + REP + symbol (symb, typ); (* fields aufnehmen weggelassen *) + IF symb = klammer auf + THEN anz klammern INCR 1 + ELIF symb = klammer zu + THEN anz klammern DECR 1 + FI + UNTIL (symb = komma AND anz klammern = 0) OR symb = semikolon ENDREP. +END PROC bis zum komma oder semikolon; + +PROC datenobjekt deklaration aufnehmen: + symbol (symb, typ); + REP + IF globale deklarationen + THEN in die liste (symb, global text) + ELSE in die liste (symb, local text) + FI; + skip ggf initialisierung; + IF symb = komma + THEN symbol (symb, typ) + FI + UNTIL symb = semikolon OR symb = punkt END REP. + +skip ggf initialisierung: + symbol (symb, typ); + IF symb = init symbol OR symb = assign symbol + THEN initialisierung skippen + FI. + +initialisierung skippen: + INT VAR anz klammern :: 0; + REP + INT CONST vorheriges symbol :: symb, + vorheriger typ :: typ; + symbol (symb, typ); + IF symb = klammer auf + THEN anz klammern INCR 1; + IF vorheriger typ = identifier + THEN in die liste (vorheriges symbol, "") + FI + ELIF symb = klammer zu + THEN anz klammern DECR 1; + IF vorheriger typ = identifier + THEN in die liste (vorheriges symbol, "") + FI + ELIF vorheriger typ = identifier AND symb = doppelpunkt + THEN in die liste (vorheriges symbol, refinement text); + LEAVE datenobjekt deklaration aufnehmen + ELIF vorheriger typ = identifier + THEN in die liste (vorheriges symbol, "") + FI + UNTIL (symb = komma AND anz klammern = 0) + OR symb = semikolon OR symb = end proc symbol OR + symb = end op symbol OR symb = endif symbol OR symb = fi symbol + END REP. +END PROC datenobjekt deklaration aufnehmen; + +PROC prozedur name und ggf parameter aufsammeln: + prozedurname aufsammeln; + symbol (symb, typ); + IF symb <> doppelpunkt + THEN formale parameter aufsammeln + FI. + +prozedurname aufsammeln: + symbol (symb, typ); + in die liste (symb, procedure text). +END PROC prozedurname und ggf parameter aufsammeln; + +PROC operatornamen skippen und ggf parameter aufsammeln: + symbol (symb, typ); + IF symb <> doppelpunkt + THEN formale parameter aufsammeln + FI +END PROC operatornamen skippen und ggf parameter aufsammeln; + +PROC formale parameter aufsammeln: + REP + symbol (symb, typ); + IF typ = identifier + THEN in die liste (symb, local text); + FI + UNTIL symb = doppelpunkt END REP +END PROC formale parameter aufsammeln; + +PROC skip until (INT CONST zeichencode): + skip until (zeichencode, 0) +END PROC skip until; + +PROC skip until (INT CONST z1, z2): + REP + symbol (symb, typ) + UNTIL symb = z1 OR symb = z2 END REP +END PROC skip until; + +PROC in die liste (INT CONST index, TEXT CONST zusatz): + IF index > max index + THEN listenelemente initialisieren; + FI; + IF aktueller eintrag = "" + THEN namens eintrag + FI; + aktueller eintrag CAT " "; + aktueller eintrag CAT text (line number); + aktueller eintrag CAT zusatz. + +aktueller eintrag: + liste [index]. + +listenelemente initialisieren: + INT VAR i; + FOR i FROM max index + 1 UPTO index REP + liste [i] := "" + END REP; + max index := index. + +namens eintrag: + get name (index, aktueller eintrag); + WHILE length (aktueller eintrag) < 15 REP + aktueller eintrag CAT " " + END REP; + aktueller eintrag CAT ":". +END PROC in die liste; + +TEXT VAR zeile; + +PROC in dump file kopieren (TEXT CONST dump file): + putline ("Ausgabedatei erstellen"); + f := sequential file (output, dump file); + INT VAR i; + kopieren und ggf fehlermeldung; + modify (f); + ggf sortieren; + zeile ggf aufspalten; + modify (f); + to line (f, 1). + +kopieren und ggf fehlermeldung: + FOR i FROM fi symbol UPTO max index REP + cout (i); + zeile := liste [i]; + IF zeile <> "" + THEN ausgabe der referenz und ggf fehlermeldung + FI + ENDREP. + +ausgabe der referenz und ggf fehlermeldung: + putline (f, zeile); + ggf referencer fehlermeldung. + +ggf sortieren: + IF yes (dump file + " sortieren") + THEN sort (dump file); + FI. + +zeile ggf aufspalten: + i := 0; + to line (f, 1); + WHILE NOT eof (f) REP + i INCR 1; + cout (i); + read record (f, zeile); + ggf aufspalten + END REP. + +ggf aufspalten: +INT VAR anf :: 1, ende :: pos (zeile, " ", 72); + IF ende > 0 + THEN dummy := subtext (zeile, 1, ende - 1); + write record (f, dummy); + spalte bis restzeile auf; + dummy CAT subtext (zeile, anf); + write record (f, dummy); + FI; + down (f). + +spalte bis restzeile auf: + REP + dummy := " "; + anf := ende + 1; + ende := pos (zeile, " ", ende + 55); + down (f); + insert record (f); + IF ende <= 0 + THEN LEAVE spalte bis restzeile auf + FI; + dummy CAT subtext (zeile, anf, ende - 1); + write record (f, dummy); + END REP. +END PROC in dump file kopieren; + +PROC ggf referencer fehlermeldung: + name := subtext (zeile, 1, min( pos(zeile, " "), pos(zeile, ":")) - 1); + dummy := subtext (zeile, pos (zeile, ": ") + 2); + ueberdeckungs ueberpruefung; + not used ueberpruefung; + IF pos (dummy, "R") > 0 + THEN refinement mehr als zweimal verwendet + FI. + +ueberdeckungs ueberpruefung: + IF pos (dummy, global text) > 0 AND pos (dummy, local text) > 0 + THEN dummy2 := "und Zeile "; + dummy2 CAT text (nr (pos (dummy, local text))); + dummy2 CAT ": "; + dummy2 CAT name; + report referencer error + (5, nr (pos (dummy, global text)), dummy2) + FI. + +not used ueberpruefung: + IF pos (dummy, " ") = 0 AND + (pos (dummy, global text) > 0 OR pos (dummy, local text) > 0 OR + pos (dummy, refinement text) > 0) + THEN not used fehlermeldung + FI. + +not used fehlermeldung: + report referencer error + (8, nr (length (dummy) - length (local text) + 1), name). + +refinement mehr als zweimal verwendet: + INT VAR refinement deklarationen :: 0, + refinement aufrufe :: 0, + anf :: 1; + WHILE pos (dummy,"R", anf) > 0 REP + refinement deklarationen INCR 1; + anf := pos (dummy, "R", anf) + 1 + END REP; + anf := 1; + WHILE pos (dummy, " ", anf) > 0 REP + refinement aufrufe INCR 1; + anf := pos (dummy, " ", anf) + 1 + END REP; + IF refinement deklarationen = 1 + THEN IF refinement aufrufe > 1 + THEN report referencer error + (6, nr (pos (dummy, refinement text)), name) + ELIF refinement aufrufe = 0 + THEN report referencer error + (7, nr (pos (dummy, refinement text)), name) + FI + ELIF refinement deklarationen > 1 + THEN IF 2 * refinement deklarationen - 1 > refinement aufrufe + THEN report referencer error (9, 0, name) + ELIF 2 * refinement deklarationen - 1 < refinement aufrufe + THEN report referencer error (10, 0, name) + FI + FI. +END PROC ggf referencer fehlermeldung; + +INT PROC nr (INT CONST ende): + INT VAR von :: ende - 1; + WHILE von > 0 AND ((dummy SUB von) >= "0" AND (dummy SUB von) <= "9") REP + von DECR 1 + END REP; + int (subtext (dummy, von + 1, ende - 1)) +END PROC nr; +END PACKET referencer2; + +(* +REP + referencer ("ref fehler"); + edit ("ref fehler.r"); +UNTIL no ("nochmal") END REP*) + diff --git a/system/std.zusatz/1.8.7/src/reporter b/system/std.zusatz/1.8.7/src/reporter new file mode 100644 index 0000000..4febc32 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/reporter @@ -0,0 +1,531 @@ +(* ------------------- VERSION 12 vom 06.08.86 -------------------- *) +PACKET reporter routines DEFINES generate counts, + count on, + count off, + generate reports, + eliminate reports, + assert, + report on, + report off, + report: + +(* Programm zur Ablaufverfolgung von ELAN Programmen. Das Programm + verfolgt Prozedur- und Refinementaufrufe ('trace') und erstellt + eine Haeufigkeitszaehlung ('count') und beachtet 'assertions'. + Autor: Rainer Hahn *) + +FILE VAR input file; + +INT VAR zeilen nr, + type; + +TEXT VAR zeile, + dummy, + dummy1, + symbol; + +LET quadro fis = "####", + triple fis = "###", + double fis = "##", + tag = 1, + bold = 2; + +DATASPACE VAR ds := nilspace; +BOUND ROW max STRUCT (INT anzahl, BOOL proc) VAR zaehlwerk; + +LET max = 3000; + +(******************* gen report-Routinen ******************************) + +PROC generate reports: + generate reports (last param) +END PROC generate reports; + +PROC generate reports (TEXT CONST name): + disable stop; + gen trace statements (name); + IF is error AND error message = "ende" + THEN clear error; + last param (name) + FI; + to line (input file, 1); + enable stop. +END PROC generate reports; + +PROC gen trace statements (TEXT CONST name): + enable stop; + IF exists (name) + THEN input file := sequential file (modify, name) + ELSE errorstop ("input file does not exist") + FI; + input file modifizieren +END PROC gen trace statements; + +(*************************** Test file modifizieren *****************) + +PROC input file modifizieren: + zeilen nr := 1; + to line (input file, 1); + col (input file, 1); + REP + lese zeile; + IF triple fis symbol + THEN wandele in quadro fis + FI; + IF proc oder op symbol + THEN verarbeite operator oder prozedurkopf + ELIF refinement symbol + THEN verarbeite ggf refinements + FI; + vorwaerts + END REP. + +triple fis symbol: + pos (zeile, triple fis) > 0 AND + (pos (zeile, triple fis) <> pos (zeile, quadro fis)). + +wandele in quadro fis: + change all (zeile, triple fis, quadro fis); + write record (input file, zeile). + +proc oder op symbol: + pos (zeile, "PROC") > 0 OR pos (zeile, "OP") > 0. + +verarbeite operator oder prozedurkopf: + scan (zeile); + symbol lesen; + IF symbol = "PROC" OR symbol = "OP" + THEN + ELIF symbol = "END" + THEN LEAVE verarbeite operator oder prozedurkopf + ELIF type = bold + THEN next symbol (symbol, type); + IF NOT (symbol = "PROC" OR symbol = "OP") + THEN LEAVE verarbeite operator oder prozedurkopf + FI + ELSE LEAVE verarbeite operator oder prozedurkopf + FI; + scanne kopf; + insertiere trace anweisung. + +scanne kopf: + dummy := double fis; + dummy CAT "report("""; + dummy CAT text (line no (input file) + 1); + dummy CAT ": "; + dummy CAT symbol; (* PROC oder OP *) + dummy CAT " "; + symbol lesen; + dummy CAT symbol; + fuege bis namens ende an; + dummy CAT " "; + ueberlese ggf parameterliste. + +fuege bis namens ende an: + REP + symbol lesen; + IF symbol = "(" OR symbol = ":" + THEN LEAVE fuege bis namensende an + FI; + dummy CAT symbol + END REP. + +ueberlese ggf parameterliste: + WHILE symbol <> ":" REP + symbol lesen + END REP. + +insertiere trace anweisung: + WHILE pos (zeile, ":") = 0 REP + vorwaerts; + lese zeile + END REP; + schreibe zeile mit report statement. + +refinement symbol: + INT CONST point pos := pos (zeile, ".") ; + point pos > 0 AND point pos >= length (zeile) - 1. + +verarbeite ggf refinements: + ueberlies leere zeilen ; + IF ist wirklich refinement + THEN insertiere report fuer refinement + FI . + +ueberlies leere zeilen : + REP + vorwaerts; + lese zeile + UNTIL pos (zeile, ""33"", ""254"", 1) > 0 PER . + +ist wirklich refinement : + scan (zeile) ; + next symbol (symbol, type) ; + next symbol (symbol) ; + symbol = ":" AND type = tag . + +insertiere report fuer refinement: + dummy := double fis; + dummy CAT "report("" "; + dummy CAT text (line no (input file) + 1); + dummy CAT ": "; + dummy1 := subtext (zeile, 1, pos (zeile, ":") - 1); + dummy CAT dummy1; + schreibe zeile mit report statement +END PROC input file modifizieren; + +PROC schreibe zeile mit report statement: + dummy CAT """);"; + dummy CAT double fis; + IF doppelpunkt steht am ende der zeile + THEN vorwaerts; + insert record (input file); + write record (input file, dummy) + ELSE insert char (dummy, ":", 1); + change (zeile, ":", dummy); + write record (input file, zeile) + FI. + +doppelpunkt steht am ende der zeile: + (zeile SUB length (zeile)) = ":" OR (zeile SUB length (zeile) - 1) = ":". +END PROC schreibe zeile mit report statement; + +PROC symbol lesen: + next symbol (symbol, type); + IF ende der zeile gescannt + THEN vorwaerts; + lese zeile; + continue scan (zeile); + next symbol (symbol, type) + FI. + +ende der zeile gescannt: + type >= 7. +END PROC symbol lesen; + +PROC vorwaerts: + IF eof (input file) + THEN errorstop ("ende") + FI; + down (input file); + IF eof (input file) + THEN errorstop ("ende") + FI +END PROC vorwaerts; + +PROC lese zeile: + read record (input file, zeile); + cout (zeilen nr); + zeilen nr INCR 1 +END PROC lese zeile; + +(************************ eliminate reports-Routinen ******************) + +PROC eliminate reports: + eliminate reports (last param) +END PROC eliminate reports; + +PROC eliminate reports (TEXT CONST name): + disable stop; + eliminate statements (name); + IF is error AND error message = "ende" + THEN clear error; + last param (name) + FI; + to line (input file, 1); + enable stop. +END PROC eliminate reports; + +PROC eliminate statements (TEXT CONST name): + enable stop; + IF exists (name) + THEN input file := sequential file (modify, name) + ELSE errorstop ("input file does not exist") + FI; + statements entfernen. + +statements entfernen: + to line (input file, 1); + col (input file, 1); + zeilen nr := 1; + WHILE NOT eof (input file) REP + lese zeile; + IF pos (zeile, double fis) > 0 + THEN eliminiere zeichenketten in dieser zeile + ELSE vorwaerts + FI + END REP. + +eliminiere zeichenketten in dieser zeile: + INT VAR anfang := pos (zeile, double fis); + WHILE es ist noch etwas zu eliminieren REP + IF es ist ein quadro fis + THEN wandele es in ein triple fis + ELIF es ist ein triple fis + THEN lass diese sequenz stehen + ELSE entferne zeichenkette + FI + END REP; + IF zeile ist jetzt leer + THEN delete record (input file) + ELSE write record (input file, zeile); + vorwaerts + FI. + +es ist noch etwas zu eliminieren: + anfang > 0. + +es ist ein quadro fis: + pos (zeile, quadro fis, anfang) = anfang. + +wandele es in ein triple fis: + delete char (zeile, anfang); + anfang := pos (zeile, double fis, anfang + 3). + +es ist ein triple fis: + pos (zeile, triple fis, anfang) = anfang. + +lass diese sequenz stehen: + anfang := pos (zeile, triple fis, anfang + 1) + 3. + +entferne zeichenkette: + INT VAR end := pos (zeile, double fis, anfang+2) ; + IF end > 0 + THEN change (zeile, anfang, end + 1, ""); + anfang := pos (zeile, double fis, anfang) + ELSE anfang := pos (zeile, double fis, anfang+2) + FI . + +zeile ist jetzt leer: + pos (zeile, ""33"", ""254"", 1) = 0. +END PROC eliminate statements; + +(********************** Trace-Routinen *******************************) + +FILE VAR trace file; + +BOOL VAR zaehlwerk initialisiert :: FALSE, + trace on, + haeufigkeit on; + +PROC report (TEXT CONST message): + IF exists ("TRACE") + THEN + ELSE trace on := TRUE; + haeufigkeit on := FALSE; + FI; + BOOL CONST ist prozedur :: + pos (message, "PROC") > 0 OR pos (message, "OP") > 0; + trace file := sequential file (modify, "TRACE"); + IF lines (trace file) <= 0 + THEN insert record (trace file); + write record (trace file, "") + ELSE to line (trace file, lines (trace file)); + read record (trace file, dummy); + IF dummy <> "" + THEN down (trace file); + insert record (trace file); + write record (trace file, "") + FI + FI; + IF trace on + THEN write record (trace file, message); + down (trace file); + insert record (trace file); + write record (trace file, "") + FI; + IF haeufigkeit on + THEN haeufigkeits zaehlung + FI. + +haeufigkeits zaehlung: + hole zeilen nr; + zaehle mit. + +hole zeilen nr: + INT CONST von pos :: pos (message, ""33"", ""254"", 1); + zeilen nr := + int (subtext (message, von pos, pos (message, ":", von pos + 1) - 1)). + +zaehle mit: + IF last conversion ok AND zeilen nr > 0 AND zeilen nr <= max + THEN zaehlwerk [zeilen nr] . anzahl INCR 1; + zaehlwerk [zeilen nr] . proc := ist prozedur + FI +END PROC report; + +PROC report (TEXT CONST message, INT CONST value): + report (message, text (value)) +END PROC report; + +PROC report (TEXT CONST message, REAL CONST value): + report (message, text (value)) +END PROC report; + +PROC report (TEXT CONST message, TEXT CONST value): + dummy1 := message; + dummy1 CAT ": "; + dummy1 CAT value; + report (dummy1) +END PROC report; + +PROC report (TEXT CONST message, BOOL CONST value): + dummy1 := message; + dummy1 CAT ": "; + IF value + THEN dummy1 CAT "TRUE" + ELSE dummy1 CAT "FALSE" + FI; + report (dummy1) +END PROC report; + +PROC report on: + trace on := TRUE; + dummy1 := "REPORT ---> ON"; + report (dummy1) +END PROC report on; + +PROC report off: + dummy1 := "REPORT ---> OFF"; + report (dummy1); + trace on := FALSE; +END PROC report off; + +PROC assert (BOOL CONST value): + assert ("", value) +END PROC assert; + +PROC assert (TEXT CONST message, BOOL CONST value): + dummy1 := "ASSERTION:"; + dummy1 CAT message; + dummy1 CAT " ---> "; + IF value + THEN dummy1 CAT "TRUE" + ELSE line; + put ("ASSERTION:"); + put (message); + put ("---> FALSE"); + line; + IF yes ("weiter") + THEN dummy1 CAT "FALSE" + ELSE errorstop ("assertion failed") + FI + FI; + report (dummy1) +END PROC assert; + +(************************** haeufigkeits-zaehlung ****************) + +PROC count on: + report ("COUNT ---> ON"); + haeufigkeit on := TRUE; + initialisiere haeufigkeit. + +initialisiere haeufigkeit: + INT VAR i; + forget (ds); + ds := nilspace; + zaehlwerk initialisiert := TRUE; + zaehlwerk := ds; + FOR i FROM 1 UPTO max REP + zaehlwerk [i] . anzahl := 0 + END REP +END PROC count on; + +PROC count off: + report ("COUNT ---> OFF"); + haeufigkeit on := FALSE +END PROC count off; + +PROC generate counts: + generate counts (last param) +END PROC generate counts; + +PROC generate counts (TEXT CONST name): + disable stop; + insert counts (name); + last param (name); + to line (input file, 1); + enable stop. +END PROC generate counts; + +PROC insert counts (TEXT CONST name): + enable stop; + IF exists (name) + THEN input file := sequential file (modify, name); + col (input file, 1) + ELSE errorstop ("input file does not exist") + FI; + IF NOT zaehlwerk initialisiert + THEN errorstop ("count nicht eingeschaltet") + FI; + counts insertieren; + dataspace loeschen; + statistik ausgeben. + +counts insertieren: + REAL VAR gesamt aufrufe :: 0.0, + proc aufrufe :: 0.0, + andere aufrufe :: 0.0; + zeilen nr := 1; + WHILE zeilen nr <= lines (input file) REP + cout (zeilen nr); + IF zaehlwerk [zeilen nr] . anzahl > 0 + THEN anzahl aufrufe in die eingabe zeile einfuegen; + aufrufe mitzaehlen + FI; + zeilen nr INCR 1 + END REP. + +anzahl aufrufe in die eingabe zeile einfuegen: + to line (input file, zeilen nr); + read record (input file, zeile); + dummy := double fis; + dummy CAT text (zaehlwerk [zeilen nr] . anzahl); + dummy CAT double fis; + change (zeile, 1, 0, dummy); + write record (input file, zeile). + +aufrufe mitzaehlen: + gesamt aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl); + IF zaehlwerk [zeilen nr] . proc + THEN proc aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl) + ELSE andere aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl) + FI. + +dataspace loeschen: + zaehlwerk initialisiert := FALSE; + forget (ds). + +statistik ausgeben: + line (2); + put ("Anzahl der Gesamtaufrufe:"); + ggf int put (gesamt aufrufe); + line; + put ("davon:"); + line; + ggf int put (proc aufrufe); put ("Prozeduren oder Operatoren"); + line; + ggf int put (andere aufrufe); put ("Refinements und andere"); + line. +END PROC insert counts; + +PROC ggf int put (REAL CONST wert): + IF wert >= real (maxint) + THEN put (wert) + ELSE put (int (wert)) + FI +END PROC ggf int put; +END PACKET reporter routines; +(* +REP + IF exists ("rep fehler") + THEN copy ("rep fehler", "zzz") + ELSE errorstop ("rep fehler exisitiert nicht") + FI; + generate reports ("zzz"); + edit("zzz"); + forget ("zzz") +UNTIL no ("nochmal") END REP; +edit("reporter")*) + diff --git a/system/std.zusatz/1.8.7/src/scheduler b/system/std.zusatz/1.8.7/src/scheduler new file mode 100644 index 0000000..cba48e0 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/scheduler @@ -0,0 +1,420 @@ + +PACKET std schedule strategy DEFINES (* Autor: J.Liedtke *) + (* Stand: 15.10.82 *) + strategic decision : + + +PROC strategic decision + (INT CONST foreground workers, background workers, + REAL CONST fore cpu load, back cpu load, paging load, + INT VAR lowest activation prio, max background tasks) : + + IF no background permitted + THEN lowest activation prio := 0 ; + max background tasks := 0 + ELSE lowest activation prio := 10 ; + select max background tasks + FI . + +no background permitted : + foreground workers > 0 AND fore cpu load > 0.03 . + +select max background tasks : + IF fore cpu load > 0.01 + THEN max background tasks := 1 + ELIF paging load < 0.07 + THEN max background tasks := 3 + ELIF paging load < 0.15 + THEN max background tasks := 2 + ELSE max background tasks := 1 + FI . + +ENDPROC strategic decision ; + +ENDPACKET std schedule strategy ; + + + (* Autor: J.Liedtke*) +PACKET eumelmeter DEFINES (* Stand: 11.10.83 *) + + init log , + log : + + +LET snapshot interval = 590.0 ; + +REAL VAR next snapshot time , + time , timex , + paging wait , paging wait x , + paging busy , paging busy x , + fore cpu , fore cpu x , + back cpu , back cpu x , + system cpu , system cpu x , + delta t ; +INT VAR storage max, used ; +TEXT VAR record ; + +PROC init log : + + time := clock (1) ; + paging wait := clock (2) ; + paging busy := clock (3) ; + fore cpu := clock (4) ; + back cpu := clock (5) ; + system cpu := clock (6) ; + next snapshot time := time + snapshot interval + +ENDPROC init log ; + +PROC log (INT CONST active terminals, active background) : + + new snapshot time if was clock reset ; + IF clock (1) >= next snapshot time + THEN save values ; + get new values ; + create stat record ; + put log (record) ; + define next snapshot time + FI . + +new snapshot time if was clock reset : + IF clock (1) < next snapshot time - snapshot interval + THEN next snapshot time := clock (1) + FI . + +save values : + time x := time ; + paging wait x := paging wait ; + paging busy x := paging busy ; + fore cpu x := fore cpu ; + back cpu x := back cpu ; + system cpu x := system cpu . + +get new values : + time := clock (1) ; + paging wait := clock (2) ; + paging busy := clock (3) ; + fore cpu := clock (4) ; + back cpu := clock (5) ; + system cpu := clock (6) ; + storage (storage max, used) . + +create stat record : + record := text (used, 5) ; + record CAT text (active terminals,3) ; + record CAT text (active background,3) ; + delta t := (time - time x) ; + percent (paging wait, paging wait x) ; + percent (paging busy, paging busy x) ; + percent (fore cpu, fore cpu x) ; + percent (back cpu, back cpu x) ; + percent (system cpu, system cpu x) ; + percent (last, 0.0) ; + percent (nutz, 0.0) . + +last : paging wait + paging busy + fore cpu + back cpu + system cpu + - paging waitx - paging busyx - fore cpux - back cpux - system cpux . + +nutz : time - paging wait - system cpu + - timex + paging waitx + system cpux . + +define next snapshot time : + next snapshot time := time + snapshot interval . + +ENDPROC log ; + +PROC percent (REAL CONST neu, alt ) : + + record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%" + +ENDPROC percent ; + +ENDPACKET eumelmeter ; + + + +PACKET background que manager DEFINES (* Autor: J.Liedtke *) + (* Stand: 15.10.82 *) + into background que , + delete from background que , + get first from background que , + get next from background que : + +LET que size = 100 , + ENTRY = STRUCT (TASK task, INT class) ; + +INT VAR end of que := 0 , + actual entry pos ; + +ROW que size ENTRY VAR que ; + + +PROC into background que (TASK CONST task) : + + INT VAR class := prio (task) ; + IF end of que = que size + THEN delete all not existing tasks + FI ; + check whether already in que ; + IF already in que + THEN IF in same class + THEN LEAVE into background que + ELSE delete from background que (task) ; + into background que (task) + FI + ELSE insert new entry + FI . + +check whether already in que : + INT VAR entry pos := 1 ; + WHILE entry pos <= end of que REP + IF que (entry pos).task = task + THEN LEAVE check whether already in que + FI ; + entry pos INCR 1 + PER . + +already in que : entry pos <= end of que . + +in same class : que (entry pos).class = class . + +insert new entry : + end of que INCR 1 ; + que (end of que) := ENTRY:( task, class ) . + +delete all not existing tasks : + INT VAR j ; + FOR j FROM 1 UPTO end of que REP + TASK VAR examined := que (j).task ; + IF NOT exists (examined) + THEN delete from background que (examined) + FI + PER . + +ENDPROC into background que ; + +PROC delete from background que (TASK CONST task) : + + search for entry ; + IF entry found + THEN delete entry ; + update actual entry pos + FI . + +search for entry : + INT VAR entry pos := 1 ; + WHILE entry pos <= end of que REP + IF que (entry pos).task = task + THEN LEAVE search for entry + FI ; + entry pos INCR 1 + PER . + +entry found : entry pos <= end of que . + +delete entry : + INT VAR i ; + FOR i FROM entry pos UPTO end of que - 1 REP + que (i) := que (i+1) + PER ; + end of que DECR 1 . + +update actual entry pos : + IF actual entry or following one deleted + THEN actual entry pos DECR 1 + FI . + +actual entry or following one deleted : + entry pos >= actual entry pos . + +ENDPROC delete from background que ; + +PROC get first from background que (TASK VAR task, INT CONST lowest class) : + + actual entry pos := 0 ; + get next from background que (task, lowest class) + +ENDPROC get first from background que ; + +PROC get next from background que (TASK VAR task, INT CONST lowest class) : + + search next entry of permitted class ; + IF actual entry pos <= end of que + THEN task := que (actual entry pos).task + ELSE task := niltask + FI . + +search next entry of permitted class : + REP + actual entry pos INCR 1 + UNTIL actual entry pos > end of que + COR que (actual entry pos).class <= lowest class PER. + +ENDPROC get next from background que ; + +ENDPACKET background que manager ; + + + +PACKET scheduler DEFINES (* Autor: J.Liedtke *) + (* Stand: 09.12.82 *) + scheduler : + + +LET std background prio = 7 , + highest background prio = 5 , + long slice = 6000 , + short slice = 600 , + blocked busy = 4 ; + +INT VAR slice , + foreground workers , + background workers ; + +BOOL VAR is logging ; + +REAL VAR fore cpu load , back cpu load , paging load ; + + +access catalogue ; +TASK CONST ur task := brother (supervisor) ; + +TASK VAR actual task ; + + +PROC scheduler : + IF yes ("mit eumelmeter") + THEN is logging := TRUE + ELSE is logging := FALSE + FI ; + task password ("-") ; + break ; + set autonom ; + command dialogue (FALSE) ; + forget ("scheduler", quiet) ; + disable stop; + REP scheduler operation; + clear error + PER; + +END PROC scheduler; + +PROC scheduler operation: + enable stop; + IF is logging + THEN init log + FI; + slice := short slice ; + init system load moniting ; + REP + pause (slice) ; + monit system load ; + look at all active user tasks and block background workers ; + activate next background workers if possible ; + IF is logging + THEN log (foreground workers, background workers) + FI + PER . + +init system load moniting : + REAL VAR + time x := clock (1) , + fore cpu x := clock (4) , + back cpu x := clock (5) , + paging x := clock (2) + clock (3) . + +monit system load : + REAL VAR interval := clock (1) - time x ; + fore cpu load := (clock (4) - fore cpu x) / interval ; + back cpu load := (clock (5) - back cpu x) / interval ; + paging load := (clock (2) + clock (3) - paging x) / interval ; + time x := clock (1) ; + fore cpu x := clock (4) ; + back cpu x := clock (5) ; + paging x := clock (2) + clock (3) . + +ENDPROC scheduler operation; + +PROC look at all active user tasks and block background workers : + + foreground workers := 0 ; + background workers := 0 ; + actual task := myself ; + next active (actual task) ; + WHILE NOT (actual task = myself) REP + IF actual task < ur task + THEN look at this task + FI ; + next active (actual task) + END REP . + +look at this task : + IF channel (actual task) >= 0 + THEN foreground workers INCR 1 + ELSE background workers INCR 1 ; + block actual task if simple worker + FI . + +block actual task if simple worker : + IF son (actual task) = niltask + THEN pause (5) ; + block (actual task) ; + IF status (actual task) = blocked busy + THEN set background prio ; + into background que (actual task) + ELIF prio (actual task) < highest background prio + THEN unblock (actual task) + FI + FI . + +set background prio : + IF prio (actual task) < highest background prio + THEN prio (actual task, std background prio) + FI . + +ENDPROC look at all active user tasks and block background workers ; + +PROC activate next background workers if possible : + + INT VAR lowest activation prio , + max background workers , + active background workers := 0 ; + + strategic decision (foreground workers, background workers, + fore cpu load, back cpu load, paging load, + lowest activation prio, max background workers) ; + + IF background permitted + THEN try to activate background workers + FI ; + IF active background workers > 0 + THEN slice := short slice + ELSE slice := long slice + FI . + +background permitted : max background workers > 0 . + +try to activate background workers : + get first from background que (actual task, lowest activation prio) ; + IF NOT is niltask (actual task) + THEN delete from background que (actual task) + FI ; + + WHILE active background workers < max background workers REP + IF is niltask (actual task) + THEN LEAVE try to activate background workers + ELIF status (actual task) <> blocked busy + THEN delete from background que (actual task) + ELSE + unblock (actual task) ; + active background workers INCR 1 + FI ; + get next from background que (actual task, lowest activation prio) + PER . + +ENDPROC activate next background workers if possible ; + +ENDPACKET scheduler ; + +scheduler; + diff --git a/system/std.zusatz/1.8.7/src/spool cmd b/system/std.zusatz/1.8.7/src/spool cmd new file mode 100644 index 0000000..9b43d36 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/spool cmd @@ -0,0 +1,178 @@ +PACKET spool cmd (* Autor : R. Ruland *) + (* Stand : 13.08.87 *) + DEFINES + spool control password, + + kill spool, + first spool, + start spool, + stop spool, + halt spool, + wait for halt : + +LET error nak = 2 , + + entry line code = 23 , + killer code = 24 , + first code = 25 , + start code = 26 , + stop code = 27 , + halt code = 28 , + wait for halt code = 29 ; + +DATASPACE VAR ds; + +BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg; +BOUND TEXT VAR error msg; +INT VAR reply; + +INITFLAG VAR in this task := FALSE; +BOOL VAR dialogue; +TEXT VAR control password, password; + +control password := ""; + +PROC spool control password (TEXT CONST new password): + + IF on line THEN say (""3""13""5"") FI; + disable stop; + do ("enter spool control password (""" + new password + """)"); + clear error; + no do again; + cover tracks; + cover tracks (control password); + control password := new password; + +END PROC spool control password; + + +PROC call spool (INT CONST op code, TEXT CONST name, TASK CONST spool) : + + dialogue := command dialogue; + password := write password; + password CAT "/"; + password CAT read password; + disable stop; + command dialogue (FALSE); + enter password (control password); + command dialogue (dialogue); + call (op code, name, spool); + command dialogue (FALSE); + enter password (password); + command dialogue (dialogue); + +END PROC call spool; + + +PROC start spool (TASK CONST spool) : + + enable stop; + call spool (halt code, "", spool); + call spool (start code, "", spool); + +END PROC start spool; + + +PROC start spool (TASK CONST spool, INT CONST new channel) : + + enable stop; + call spool (halt code, "", spool); + call spool (start code, text (new channel), spool); + +END PROC start spool; + + +PROC stop spool (TASK CONST spool) : + + call spool (stop code, "", spool); + +END PROC stop spool; + +PROC stop spool (TASK CONST spool, TEXT CONST deactive msg) : + + call spool (stop code, deactive msg, spool); + +END PROC stop spool; + + +PROC halt spool (TASK CONST spool) : + + call spool (halt code, "", spool); + +END PROC halt spool; + +PROC halt spool (TASK CONST spool, TEXT CONST deactive msg) : + + call spool (halt code, deactive msg, spool); + +END PROC halt spool; + + +PROC wait for halt (TASK CONST spool) : + + call spool (wait for halt code, "", spool); + +END PROC wait for halt; + +PROC wait for halt (TASK CONST spool, TEXT CONST deactive msg) : + + call spool (wait for halt code, deactive msg, spool); + +END PROC wait for halt; + + +PROC control spool (TASK CONST spool, INT CONST control code, + TEXT CONST question, BOOL CONST leave) : + + enable stop; + initialize control msg; + WHILE valid spool entry + REP IF control question THEN control spool entry FI PER; + + . initialize control msg : + IF NOT initialized (in this task) THEN ds := nilspace FI; + forget (ds); ds := nilspace; control msg := ds; + control msg. entry line := ""; + control msg. password := control password; + control msg. index := 0; + say (""13""10""); + + . valid spool entry : + call (spool, entry line code, ds, reply); + IF reply = error nak + THEN error msg := ds; + errorstop (error msg); + FI; + control msg. index <> 0 + + . control question : + say (control msg. entry line); + yes (question) + + . control spool entry : + call (spool, control code, ds, reply); + IF reply = error nak + THEN error msg := ds; + errorstop (error msg); + FI; + IF leave THEN LEAVE control spool FI; + +END PROC control spool; + + +PROC kill spool (TASK CONST spool) : + + control spool (spool, killer code, " loeschen", FALSE) + +END PROC kill spool; + + +PROC first spool (TASK CONST spool) : + + control spool (spool, first code, " als erstes", TRUE) + +END PROC first spool; + + +END PACKET spool cmd; + diff --git a/system/std.zusatz/1.8.7/src/spool manager b/system/std.zusatz/1.8.7/src/spool manager new file mode 100644 index 0000000..6b4fe55 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/spool manager @@ -0,0 +1,1058 @@ +PACKET spool manager DEFINES (* Autor : R. Ruland *) + (* Stand : 23.02.88 *) + + spool manager , + + server channel , + spool duty, + station only, + auto stop, + enter spool control password, + spool control password, + + start spool, + stop spool, + halt spool, + kill spool, + first spool, + spool entry line, + number spool entries, + spool status, + server task, + clear spool, + list spool, + : + +LET que size = 200 , + + 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 , + 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 , + help code = 49 , + continue code = 100 , + + control codes = ""23""24""25""26""27""28""29"" , + + file type = 1003 , + help file name = "help"; + +LET begin char = ""0"", + end char = ""1""; + +LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station); + +BOUND ROW que size STRUCT (PARAMS ds params, TEXT entry line) VAR que; + + ROW que size DATASPACE VAR que space; + +PARAMS VAR save params; + +DATASPACE VAR que ds, global ds; + +FILE VAR file; + +INT VAR last order, reply, old heap size, que index, fetch index, + station by start, begin pos, end pos, order task station, sp channel; + +TEXT VAR que entries, free entries, order task name, buffer, deactive message, + error message buffer, sp duty, start time, control password; + +BOOL VAR server is waiting, stop cmd pending, start cmd pending, + auto stop pending, stat only; + +TASK VAR last order task, server, calling parent, task in control; + +INITFLAG VAR in this task := FALSE, init que space := FALSE; + +BOUND STRUCT (TEXT name, userid, password) VAR msg; +BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg; +BOUND PARAMS VAR fetch msg; +BOUND THESAURUS VAR all msg; +BOUND TEXT VAR error msg; + + +. que is empty : que entries = "" +. que is full : free entries = "" +. number entries : LENGTH que entries + +. first index : code (que entries SUB 1) +. list index : code (que entries SUB que index) +. last index : code (que entries SUB number entries) + +. fetch entry : que (fetch index) +. list entry : que (list index) +. last entry : que (last index) + +. was define station : station by start <> station (myself) +. is valid fetch entry : fetch index > 0 +.; + +INT VAR command index , params ; +TEXT VAR param 1, param 2 ; +LET spool command list = "start:1.01stop:3.0halt:4.0first:5.0killer:6.0"; + +sp channel := 0; +sp duty := ""; +deactive message := ""; +stat only := FALSE; +auto stop pending := FALSE; +task in control := supervisor; +control password := "-"; + + +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 auto stop (BOOL CONST flag) : + auto stop pending := flag +END PROC auto stop; + +BOOL PROC auto stop : auto stop pending END PROC auto stop; + + +PROC spool duty (TEXT CONST duty) : + sp duty := duty; +END PROC spool duty; + +TEXT PROC spool duty : sp duty END PROC spool duty; + + +PROC enter spool control password (TEXT CONST new password): + disable stop; + cover tracks; + cover tracks (control password); + control password := new password; +END PROC enter spool control password; + +PROC spool control password (TEXT CONST new password): + IF on line THEN say (""3""13""5"") FI; + enter spool control password (new password); +END PROC spool control password; + + +PROC spool manager (PROC server start) : + spool manager (PROC (DATASPACE VAR, INT CONST, + INT CONST, TASK CONST) spool manager, + PROC server start, TRUE) +END PROC spool manager; + + +PROC spool manager (PROC server start, BOOL CONST initial start) : + spool manager (PROC (DATASPACE VAR, INT CONST, + INT CONST, TASK CONST) spool manager, + PROC server start, initial start) +END PROC spool manager; + + +PROC spool manager (PROC (DATASPACE VAR, INT CONST, + INT CONST, TASK CONST) spool, + PROC server start, + BOOL CONST initial start) : + + set autonom; + break; + disable stop; + command dialogue (FALSE); + initialize spool manager; + REP start spool if necessary; + wait for next order; + IF order not allowed THEN reject order + ELIF is first phase THEN first phase + ELIF is second phase THEN second phase + ELSE send nak + FI; + send error if necessary; + collect heap garbage if necessary; + PER + + . initialize spool manager : + initialize if necessary; + stop server; + erase fetch entry; + start cmd pending := initial start; + stop cmd pending := FALSE; + last order task := niltask; + + . initialize if necessary : + IF NOT initialized (in this task) + THEN clear spool; + global ds := nilspace; + que ds := nilspace; + que := que ds; + server := niltask; + calling parent := niltask; + server is waiting := FALSE; + station by start := station (myself); + old heap size := 0; + error message buffer := ""; + FI; + + . start spool if necessary : + IF start cmd pending AND NOT stop cmd pending + THEN start server (PROC server start) FI; + + . wait for next order : + INT VAR order, phase; + TASK VAR order task; + forget (global ds); + wait (global ds, order, order task); + + . order not allowed : + station only CAND station (ordertask) <> station (myself) CAND + ( order > 255 COR pos (control codes, code (order)) = 0 ) + + . reject order : + errorstop ("kein Zugriffsrecht auf Task " + text (station(myself)) + + "/""" + name(myself) + """") + + . is first phase : + order <> second phase ack + + . first phase : + phase := 1; + last order := order; + last order task := order task; + spool (global ds, order, phase, order task); + + . is second phase : + order task = last order task + + . second phase : + phase INCR 1 ; + order := last order; + spool (global ds, order, phase, order task); + + . send nak : + forget (global ds); + global ds := nilspace; + send (order task, nak, global ds); + + . send error if necessary : + IF is error + THEN forget (global ds); + global ds := nilspace; + error msg := global ds; + CONCR (error msg) := error message; + clear error; + send (order task, error nak, global 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 manager (DATASPACE VAR order ds, + INT CONST order, phase, + TASK CONST order task ): + + enable stop; + SELECT order OF + CASE fetch code, help code : out of que or help + CASE param fetch code : send fetch params + CASE save code : new que entry + CASE file save code : new file que entry + CASE exists code : exists que entry + CASE erase code : erase que entry + CASE list code : send spool list + CASE all code : send owners ds names + + CASE entry line code : send next entry line + CASE killer code : kill entry + CASE first code : make to first + CASE start code : start server task + CASE stop code : stop server task + CASE halt code, wait for halt code + : halt server task + + OTHERWISE : + + IF order >= continue code AND order task = supervisor + THEN spool monitor + ELSE wrong operation + FI; + + END SELECT; + +. wrong operation : + IF order > error nak + THEN errorstop ("falscher Auftrag fuer Task " + text (station(myself)) + + "/""" + name(myself) + """") + FI; + +. + out of que or help : + IF order task = server + THEN out of que + ELSE send help file + FI; + + . out of que : + erase fetch entry; + IF stop cmd pending + THEN stop server + ELIF que is empty + THEN IF auto stop pending + THEN stop server + ELSE server is waiting := TRUE + FI; + ELSE send first entry; + FI; + + . send help file : + check server (TRUE); + IF order = fetch code + THEN msg := order ds; + IF msg. name <> help file name + THEN errorstop ("keine Servertask") FI; + FI; + forget (order ds); + order ds := old (help file name); + send (order task, ack, order ds); + +. + send fetch params : + IF order task = server + THEN send params + ELSE errorstop ("keine Servertask") + FI; + + . send params : + forget(order ds); order ds := nilspace; + fetch msg := order ds; + fetch msg := fetch entry. ds params; + send (order task, ack, order ds); + +. + new que entry : + IF phase = 1 + THEN prepare into que + ELSE into que (order ds, order task) + FI; + +. + prepare into que : + msg := order 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 (order ds); order ds := nilspace; + send (order task, second phase ack, order ds); + +. + new file que entry : + IF type (order ds) <> file type + THEN errorstop ("Datenraum hat falschen Typ"); + ELSE get file params; + into que (order ds, order task); + FI; + + . get file params : + file := sequential file (input, order ds); + end pos := 0; + next headline information (save params. name); + next headline information (save params. userid); + next headline information (save params. password); + next headline information (save params. sendername); + next headline information (buffer); + save params. station := int (buffer); + IF NOT last conversion ok + THEN save params. station := station (order task) FI; + IF save params. sendername = "" + THEN save params. sendername := name (order task) FI; + IF save params. name = "" + THEN IF headline (file) <> "" + THEN save params. name := headline (file); + ELSE errorstop ("Name unzulaessig") + FI; + ELSE headline (file, save params. name); + FI; + +. + exists que entry : + msg := order ds ; + order task name := name (order task); + order task station := station (order task); + FOR que index FROM 1 UPTO number entries + REP IF is entry from order task (msg. name) + THEN send ack; + LEAVE exists que entry + FI; + PER ; + forget (order ds); order ds := nilspace; + send (order task, false code, order ds) + +. + erase que entry : + msg := order 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 : + FOR que index FROM 1 UPTO number entries + REP IF is entry from order task (msg. name) + THEN manager question ("""" + msg.name + """ loeschen", order task); + LEAVE erase que entry + FI; + PER ; + manager message ("""" + msg.name + """ existiert nicht", order task); + + . erase entry from order task : + IF is valid que index (que index) CAND is entry from order task (msg. name) + THEN delete que entry; + LEAVE erase que entry + ELSE FOR que index FROM 1 UPTO number entries + 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", order task); + FI; + + . delete que entry : + kill spool (que index); + send ack; + +. + send owners ds names: + order task name := name (order task); + order task station := station (order task); + forget (order ds); order ds := nilspace; all msg := order ds; + all msg := empty thesaurus; + FOR que index FROM 1 UPTO number entries + REP IF is entry from order task ("") + THEN insert (all msg, list entry. ds params. name) + FI; + PER; + send (order task, ack, order ds) + +. + send spool list : + forget (global ds); global ds := nilspace; + file := sequential file (output, global ds); + list spool (file); + send (order task, ack, global ds); + +. + send next entry line : + control msg := order ds; check control password (control msg. password); + IF control msg. index = 0 THEN control msg. actual entries := que entries FI; + get next entry line; + send (order task, ack, order ds); + + . get next entry line : + REP control msg. index INCR 1; + IF control msg. index > LENGTH control msg. actual entries + THEN control msg. index := 0; + control msg. entry line := ""; + LEAVE get next entry line; + FI; + que index := control que index; + UNTIL is valid que index (que index) PER; + control msg. entry line := list entry. entry line; + + . control que index : + pos (que entries, control msg. actual entries SUB control msg. index) + +. + kill entry : + control msg := order ds; check control password (control msg. password); + kill spool (control que index); + send (order task, ack, order ds); + +. + make to first : + control msg := order ds; check control password (control msg. password); + first spool (control que index); + send (order task, ack, order ds); + +. + start server task : + msg := order ds; check control password (msg. password); + IF exists (server) AND NOT stop cmd pending + THEN errorstop ("Spool muß zuerst gestoppt werden") FI; + new server channel is necessary; + start cmd pending := TRUE; + IF server channel <= 0 OR server channel >= 33 + THEN manager message ("WARNUNG : Serverkanal nicht eingestellt", order task); + ELSE send ack + FI; + + . new server channel is necessary : + INT CONST new channel := int (msg. name); + IF last conversion ok THEN server channel (new channel) FI; + +. + stop server task : + msg := order ds; check control password (msg. password); + IF phase = 1 + THEN start cmd pending := FALSE; + deactive message := msg. name; + stop server; + check fetch entry; + ELSE reinsert fetch entry; + send ack; + FI; + +. + halt server task : + msg := order ds; check control password (msg. password); + IF phase = 1 + THEN stop cmd pending := TRUE; + start cmd pending := FALSE; + deactive message := msg. name; + IF NOT exists (server) OR server is waiting + THEN stop server; + check fetch entry; + ELIF order = wait for halt code + THEN calling parent := order task; + ELSE send ack; + FI; + ELSE reinsert fetch entry; + send ack; + FI; + + . check fetch entry : + IF is valid fetch entry + THEN manager question (""13""10"" + + fetch entry. entry line + " neu eintragen", order task); + fetch index := -fetch index; + ELSE send ack; + FI; + +. + send ack : + forget (order ds); order ds := nilspace; + send (order task, ack, order ds) + +. + spool monitor : + continue (order - continue code); + disable stop; + put error message if there is one; + WHILE online + REP command dialogue (TRUE); + sysout (""); + sysin (""); + get command ("gib Spool-Kommando:"); + analyze command (spool command list, 3, command index, params, param1, param2); + reset editor; + SELECT command index OF + CASE 1 : start spool + CASE 2 : start spool (int (param1)) + CASE 3 : stop spool + CASE 4 : halt spool + CASE 5 : first spool + CASE 6 : kill spool + OTHERWISE : do command + END SELECT; + PER; + save error message if there is one; + command dialogue (FALSE); + break (quiet); + set autonom; + + . put error message if there is one : + IF error message buffer <> "" + THEN errorstop (error message buffer); FI; + + . save error message if there is one : + IF is error + THEN error message buffer := error message; + clear error; + ELSE error message buffer := ""; + FI; + + . reset editor : + WHILE aktueller editor > 0 REP quit PER; + clear error; + +END PROC spool manager; + + +PROC send first entry : + + forget (global ds); + global ds := que space (first index); + send (server, ack, global ds, reply) ; + IF reply = ack + THEN fetch index := first index; + que entries := subtext (que entries, 2); + server is waiting := FALSE; + start time := time of day; + start time CAT " am "; + start time CAT date; + FI; + +END PROC send first entry; + + +PROC into que (DATASPACE VAR order ds, TASK CONST order task) : + + IF que is full + THEN errorstop ("Spool ist voll") + ELSE make new entry; + send ack; + awake server if necessary + FI; + + . make new entry : + que entries CAT (free entries SUB 1); + free entries := subtext (free entries, 2); + que space (last index) := order ds; + last entry. ds params := save params; + build entry line; + + . 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 := entry station text; + 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 (order ds)); + last entry. entry line CAT " K)"; + + . entry station text : + IF last entry. ds params. station = 0 + THEN " " + ELSE text (last entry. ds params. station, 3) + FI + + . send ack : + forget (order ds); order ds := nilspace; + send (order task, ack, order ds) + + . awake server if necessary : + IF server is waiting THEN send first entry FI; + +END PROC into que; + + +(*********************************************************************) +(* Hilfsprozeduren zum Spoolmanager *) +(*********************************************************************) + + +PROC reinsert fetch entry : + + IF fetch index <> 0 + THEN insert char (que entries, code (abs (fetch index)), 1); + fetch index := 0; + FI; + +END PROC reinsert fetch entry; + + +PROC erase fetch entry : + + IF fetch index <> 0 + THEN free entries CAT code (abs (fetch index)); + forget (que space (abs (fetch index))); + fetch index := 0; + FI; + +END PROC erase fetch entry; + + +PROC start server (PROC server start): + + stop server; + begin (PROC server start, server); + station by start := station (myself); + start cmd pending := FALSE; + deactive message := ""; + +END PROC start server; + + +PROC stop server : + + IF exists (server) THEN end (server) ELSE check server (FALSE) FI; + server := niltask; + server is waiting := FALSE; + stop cmd pending := FALSE; + send calling parent reply if necessary; + + . send calling parent reply if necessary : + IF exists (calling parent) + THEN forget (global ds); global ds := nilspace; + send (calling parent, ack, global ds); + calling parent := niltask; + FI; + +END PROC stop server; + + +PROC check server (BOOL CONST with stop) : + + IF was define station CAND NOT is niltask (server) + THEN stop old server if necessary FI; + + . stop old server if necessary : + access catalogue; + TASK VAR old server := son (myself); + WHILE NOT is niltask (old server) + REP IF index (old server) = index (server) THEN old server found FI; + old server := brother (old server); + PER; + + . old server found : + IF name (old server) = "-" THEN end (old server) FI; + IF with stop THEN stop server FI; + LEAVE stop old server if necessary; + +END PROC check server; + + +BOOL PROC is valid que index (INT CONST index) : + + 1 <= index AND index <= number entries + +END PROC is valid que index; + + +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 check control password (TEXT CONST password) : + + IF control password = "-" + THEN errorstop ("Kontrolle des Spools nicht erlaubt") + ELIF control password <> "" CAND control password <> password + THEN errorstop ("Passwort falsch") + FI; + +END PROC check control password; + + +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; + +(*********************************************************************) +(* Prozeduren zur Verwaltung der Warteschlange *) +(*********************************************************************) + +PROC start spool : + + enable stop; + IF server channel <= 0 OR server channel >= 33 + THEN display (""13""10"WARNUNG : Serverkanal nicht eingestellt"13""10"") + FI; + halt spool; + start cmd pending := TRUE; + +END PROC start spool; + +PROC start spool (INT CONST new channel) : + + enable stop; + server channel (new channel); + start spool; + +END PROC start spool; + +PROC stop spool (TEXT CONST deactive msg) : + + disable stop; + deactive message := deactive msg; + start cmd pending := FALSE; + stop server; + IF is valid fetch entry CAND on line CAND + yes (""13""10"" + fetch entry. entry line + " neu eintragen") + THEN reinsert fetch entry + ELSE erase fetch entry; + FI; + +END PROC stop spool; + +PROC stop spool : stop spool ("") END PROC stop spool; + +PROC halt spool (TEXT CONST deactive msg) : + + enable stop; + deactive message := deactive msg; + stop cmd pending := TRUE; + start cmd pending := FALSE; + IF NOT exists (server) OR server is waiting THEN stop spool FI; + +END PROC halt spool; + +PROC halt spool : halt spool ("") END PROC halt spool; + + +PROC kill spool : + + enable stop; + say (""13""10""); + que index := 1; + WHILE que index <= number entries + REP IF yes (list entry. entry line + " loeschen") + THEN kill spool (que index) + ELSE que index INCR 1 + FI; + PER; + +END PROC kill spool; + +PROC kill spool (INT CONST index) : + + IF is valid que index (index) + THEN forget (que space (code (que entries SUB index))); + free entries CAT (que entries SUB index); + delete char (que entries, index); + FI; + +END PROC kill spool; + + +PROC first spool : + + enable stop; + say (""13""10""); + FOR que index FROM 1 UPTO number entries + REP IF yes (list entry. entry line + " als erstes") + THEN first spool (que index); + LEAVE first spool + FI; + PER; + +END PROC first spool; + +PROC first spool (INT CONST index) : + + IF is valid que index (index) + THEN insert char (que entries, que entries SUB index, 1); + delete char (que entries, index + 1); + FI; + +END PROC first spool; + + +TEXT PROC spool entry line (INT CONST index) : + + IF index = 0 CAND is valid fetch entry + THEN fetch entry. entry line + ELIF is valid que index (index) + THEN entry. entry line + ELSE "" + FI + + . entry : que (code (que entries SUB index)) + +END PROC spool entry line; + + +INT PROC number spool entries : number entries END PROC number spool entries; + +INT PROC spool status : + + IF exists (server) + THEN IF stop cmd pending + THEN IF start cmd pending + THEN 3 (* aktiviert (neu start) *) + ELSE 2 (* aktiviert (warten auf halt) *) + FI + ELSE IF server is waiting + THEN 0 (* kein Auftrag in Bearbeitung *) + ELSE 1 (* aktiviert *) + FI + FI + ELIF start cmd pending + THEN 0 (* wird aktiviert *) + ELIF is valid fetch entry + THEN IF was define station + THEN -3 (* deaktiviert (define station) *) + ELSE -2 (* deaktiviert (server gelöcht) *) + FI + ELSE -1 (* deaktiviert *) + FI + +END PROC spool status; + +TASK PROC server task : server END PROC server task; + + +PROC clear spool : + + disable stop; + IF NOT initialized (init que space) + THEN FOR que index FROM 1 UPTO que size + REP que space (que index) := nilspace PER; + FI; + que entries := ""; + free entries := ""; + fetch index := 0; + stop server; + FOR que index FROM 1 UPTO que size + REP forget (que space (que index)); + free entries CAT code (que index); + PER; + +END PROC clear spool; + + +PROC list spool : + + disable stop; + DATASPACE VAR list ds := nilspace; + FILE VAR list file := sequential file (output, list ds); + list spool (list file); + show (list file); + forget (list ds); + +END PROC list spool; + + +PROC list spool (FILE VAR f) : + + enable stop; + output (f); + max line length (f, 1000); + headline (f, station text + name (myself) + """"); + put spool duty; + put current job; + put spool que; + + . station text : + IF station(myself) = 0 + THEN "/""" + ELSE text (station(myself)) + "/""" + FI + + . put spool duty : + IF spool duty <> "" + THEN write (f, "Aufgabe: "); + write (f, spool duty ); + line (f, 2); + FI; + + . put current job : + IF is valid fetch entry + THEN write (f, "In Bearbeitung seit "); + write (f, start time); + write (f, ":"); + line (f, 2); + putline (f, fetch entry. entry line); + IF NOT exists (server) + THEN IF was define station + THEN putline (f, "Spool ist deaktiviert, da Stationsnummer geaendert wurde") + ELSE putline (f, "Spool ist deaktiviert, da der Server gelöscht wurde") + FI; + ELIF stop cmd pending + THEN IF start cmd pending + THEN putline (f, "Spool wird nach diesem Auftrag neu aktiviert"); + ELSE putline (f, "Spool wird nach diesem Auftrag deaktiviert"); + FI; + FI; + line (f); + ELSE write (f, "kein Auftrag in Bearbeitung"); + IF NOT exists (server) + THEN write (f, ", da Spool deaktiviert"); + IF start cmd pending + THEN line (f); + write (f, "Spool wird nach Verlassen der Task aktiviert"); + FI; + IF deactive message <> "" + THEN line (f); + write (f, deactive message); + FI; + ELIF que is empty + THEN write (f, ", da Warteschlange leer"); + LEAVE list spool; + FI; + line (f, 2); + FI; + + . put spool que : + IF que is empty + THEN putline (f, "Warteschlange ist leer"); + ELSE write (f, "Warteschlange ("); + write (f, text (number entries)); + IF number entries = 1 + THEN write (f, " Auftrag):"); + ELSE write (f, " Auftraege):"); + FI; + line (f, 2); + FOR que index FROM 1 UPTO number entries + REP putline (f, list entry. entry line) PER; + FI; + +END PROC list spool; + + +ENDPACKET spool manager; + diff --git a/system/std.zusatz/1.8.7/src/std analysator b/system/std.zusatz/1.8.7/src/std analysator new file mode 100644 index 0000000..7e14722 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/std analysator @@ -0,0 +1,68 @@ +PACKET std analysator (* Autor : Rudolf Ruland *) + (* Stand : 06.11.86 *) + DEFINES std analysator : + + +LET text code = 1, + error code = 2, + token code = 3; + +INT VAR instruction begin; +TEXT VAR unknown instruction := ""; + +PROC std analysator (INT CONST op code, TEXT VAR string, + INT VAR par1, par2, par3, par4, par5, par6, par7) : + + SELECT op code OF + + CASE text code : analyse text + CASE error code : report errors + CASE token code : report tokens + + END SELECT ; + + . record : string + . record pos : par1 + . width : par4 + . height : par5 + . depth : par6 + + . analyse text : + instruction begin := record pos + 1; + record pos := pos (record, "#", instruction begin) + 1; + width := 0; + height := 0; + depth := 0; + unknown instruction := subtext (record, instruction begin, instruction end); + + . instruction end : record pos - 2 + + +. error msg : string +. error nr : par1 +. + report errors : + IF error nr = 0 + THEN error msg := "unbekannte Anweisung (ignoriert): "; + error msg CAT unknown instruction; + error nr := 1; + ELSE error msg := ""; + error nr := 0; + FI; + + +. token text : string +. token nr : par1 +. token font nr : par2 +. token modifications : par3 +. token width : par4 +. token x pos : par5 +. token y pos : par6 +. token type : par7 +. + report tokens : + +END PROC std analysator; + +END PACKET std analysator; + diff --git a/system/std.zusatz/1.8.7/src/vector b/system/std.zusatz/1.8.7/src/vector new file mode 100644 index 0000000..5c9e896 --- /dev/null +++ b/system/std.zusatz/1.8.7/src/vector @@ -0,0 +1,213 @@ +PACKET vector DEFINES VECTOR, :=, vector, (* Autor : H.Indenbirken *) + SUB, LENGTH, length, norm, (* Stand : 21.10.83 *) + nilvector, replace, =, <>, + +, -, *, /, + get, put : + + +TYPE VECTOR = STRUCT (INT lng, TEXT elem); +TYPE INITVECTOR = STRUCT (INT lng, REAL value); + +INT VAR i; +TEXT VAR t :: "12345678"; +VECTOR VAR v :: nilvector; + +(**************************************************************************** +PROC dump (VECTOR CONST v) : + put line (text (v.lng) + " Elemente :"); + FOR i FROM 1 UPTO v.lng + REP put line (text (i) + ": " + text (element i)) PER . + +element i : + v.elem RSUB i . + +END PROC dump; +****************************************************************************) + +OP := (VECTOR VAR l, VECTOR CONST r) : + l.lng := r.lng; + l.elem := r.elem + +END OP :=; + +OP := (VECTOR VAR l, INITVECTOR CONST r) : + l.lng := r.lng; + replace (t, 1, r.value); + l.elem := r.lng * t + +END OP :=; + +INITVECTOR PROC nilvector : + vector (1, 0.0) + +END PROC nilvector; + +INITVECTOR PROC vector (INT CONST lng, REAL CONST value) : + IF lng <= 0 + THEN errorstop ("PROC vector : lng <= 0") FI; + INITVECTOR : (lng, value) + +END PROC vector; + +INITVECTOR PROC vector (INT CONST lng) : + vector (lng, 0.0) + +END PROC vector; + +REAL OP SUB (VECTOR CONST v, INT CONST i) : + test ("REAL OP SUB : ", v, i); + v.elem RSUB i + +END OP SUB; + +INT OP LENGTH (VECTOR CONST v) : + v.lng + +END OP LENGTH; + +INT PROC length (VECTOR CONST v) : + v.lng + +END PROC length; + +REAL PROC norm (VECTOR CONST v) : + REAL VAR result :: 0.0; + FOR i FROM 1 UPTO v.lng + REP result INCR ((v.elem RSUB i)**2) PER; + sqrt (result) . + +END PROC norm; + +PROC replace (VECTOR VAR v, INT CONST i, REAL CONST r) : + test ("PROC replace : ", v, i); + replace (v.elem, i, r) + +END PROC replace; + +BOOL OP = (VECTOR CONST l, r) : + l.elem = r.elem +END OP =; + +BOOL OP <> (VECTOR CONST l, r) : + l.elem <> r.elem +END OP <>; + +VECTOR OP + (VECTOR CONST v) : + v +END OP +; + +VECTOR OP + (VECTOR CONST l, r) : + test ("VECTOR OP + : ", l, r); + v := l; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER; + v + +END OP +; + +VECTOR OP - (VECTOR CONST a) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, - (a.elem RSUB i)) PER; + v + +END OP -; + +VECTOR OP - (VECTOR CONST l, r) : + test ("VECTOR OP - : ", l, r); + v := l; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER; + v +END OP -; + +REAL OP * (VECTOR CONST l, r) : + test ("REAL OP * : ", l, r); + REAL VAR x :: 0.0; + FOR i FROM 1 UPTO l.lng + REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER; + x + +END OP *; + +VECTOR OP * (VECTOR CONST v, REAL CONST r) : + r*v + +END OP *; + +VECTOR OP * (REAL CONST r, VECTOR CONST a) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, r*(a.elem RSUB i)) PER; + v + +END OP *; + +VECTOR OP / (VECTOR CONST a, REAL CONST r) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (a.elem RSUB i)/r) PER; + v + +END OP /; + +TEXT VAR error :: ""; +PROC test (TEXT CONST proc, VECTOR CONST v, INT CONST i) : + IF i > v.lng + THEN error := proc; + error CAT "subscript overflow (LENGTH v="; + error CAT text (v.lng); + error CAT ", i="; + error CAT text (i); + error CAT ")"; + errorstop (error) + ELIF i < 1 + THEN error := proc; + error CAT "subscript underflow (i = "; + error CAT text (i); + error CAT ")"; + errorstop (error) + FI . + +END PROC test; + +PROC test (TEXT CONST proc, VECTOR CONST a, b) : + IF a.lng <> b.lng + THEN error := proc; + error CAT "LENGTH a ("; + IF a.lng <= 0 + THEN error CAT "undefined" + ELSE error CAT text (a.lng) FI; + error CAT ") <> LENGTH b ("; + error CAT text (b.lng); + error CAT ")"; + errorstop (error) + FI + +END PROC test; + +PROC get (VECTOR VAR v, INT CONST lng) : + v.lng := lng; + v.elem := lng * "12345678"; + REAL VAR x; + FOR i FROM 1 UPTO lng + REP get (x); + replace (v.elem, i, x) + PER . + +END PROC get; + +PROC put (VECTOR CONST v, INT CONST length, fracs) : + FOR i FROM 1 UPTO v.lng + REP put (text (v.elem RSUB i, length, fracs)) PER + +END PROC put; + +PROC put (VECTOR CONST v) : + FOR i FROM 1 UPTO v.lng + REP put (text (v.elem RSUB i)) PER + +END PROC put; + +END PACKET vector; + |