diff options
Diffstat (limited to 'system/base')
30 files changed, 12232 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 ; + |