diff options
Diffstat (limited to 'system/base')
46 files changed, 18943 insertions, 0 deletions
diff --git a/system/base/1.7.5/source-disk b/system/base/1.7.5/source-disk new file mode 100644 index 0000000..5708023 --- /dev/null +++ b/system/base/1.7.5/source-disk @@ -0,0 +1 @@ +175_src/source-code-1.7.5.img diff --git a/system/base/1.7.5/src/advertising b/system/base/1.7.5/src/advertising new file mode 100644 index 0000000..45f73ef --- /dev/null +++ b/system/base/1.7.5/src/advertising @@ -0,0 +1,35 @@ +(* ------------------- VERSION 1 06.03.86 ------------------- *) +PACKET advertising DEFINES (* Autor: J.Liedtke *) + + eumel must advertise : + + +LET myself id field = 9 ; + + +PROC eumel must advertise : + + IF online AND channel <= 15 + THEN out (""1""4"") ; + IF station is not zero + THEN out (""15"Station: ") ; + out (text (station number)) ; + out (" "14"") + FI ; + cursor (60,1) ; + out (""15"Terminal: ") ; + out (text (channel)) ; + out (" "14"") ; + cursor (22,5) ; + (* out ("E U M E L Pilot-Version /M"13""10""10""10"") *) + out ("E U M E L Version 1.7.5.10 /M+ "13""10""10""10"") + FI . + +station is not zero : pcb (myself id field) >= 256 . + +station number : pcb (myself id field) DIV 256 . + +ENDPROC eumel must advertise ; + +ENDPACKET advertising ; + diff --git a/system/base/1.7.5/src/basic transput b/system/base/1.7.5/src/basic transput new file mode 100644 index 0000000..5608bb1 --- /dev/null +++ b/system/base/1.7.5/src/basic transput @@ -0,0 +1,177 @@ + +PACKET basic transput DEFINES + out , + outsubtext , + outtext , + TIMESOUT , + cout , + display , + inchar , + incharety , + cat input , + pause , + cursor , + get cursor , + channel , + online , + control , + blockout , + blockin : + + + +LET channel field = 4 , + blank times 64 = + " " ; + +LET BLOCKIO = STRUCT (ALIGN page align, ROW 256 INT buffer) , + buffer page = 2 ; + +BOUND BLOCKIO VAR block io ; +DATASPACE VAR block io ds ; +INITFLAG VAR this packet := FALSE ; + + +PROC out (TEXT CONST text ) : + EXTERNAL 60 +ENDPROC out ; + +PROC outsubtext ( TEXT CONST source, INT CONST from ) : + EXTERNAL 62 +END PROC outsubtext; + +PROC outsubtext (TEXT CONST source, INT CONST from, to) : + EXTERNAL 63 +END PROC outsubtext; + +PROC outtext ( TEXT CONST source, INT CONST from, to ) : + out subtext (source, from, to) ; + INT VAR trailing ; + IF from <= LENGTH source + THEN trailing := to - LENGTH source + ELSE trailing := to + 1 - from + FI ; + IF trailing > 0 + THEN trailing TIMESOUT " " + FI +ENDPROC outtext ; + +OP TIMESOUT (INT CONST times, TEXT CONST text) : + + IF text = " " + THEN fast timesout blank + ELSE timesout + FI . + +fast timesout blank : + INT VAR i := 0 ; + WHILE i + 64 < times REP + out (blank times 64) ; + i INCR 64 + PER ; + outsubtext (blank times 64, 1, times - i) . + +timesout : + FOR i FROM 1 UPTO times REP + out(text) + ENDREP . + +ENDOP TIMESOUT ; + +PROC display (TEXT CONST text) : + IF online + THEN out (text) + FI +ENDPROC display ; + +PROC inchar (TEXT VAR character ) : + EXTERNAL 64 +ENDPROC inchar ; + +TEXT PROC incharety : + EXTERNAL 65 +END PROC incharety ; + +TEXT PROC incharety (INT CONST time limit) : + internal pause (time limit) ; + incharety +ENDPROC incharety ; + +PROC pause (INT CONST time limit) : + internal pause (time limit) ; + TEXT CONST dummy := incharety +ENDPROC pause ; + +PROC pause : + TEXT VAR dummy; inchar (dummy) +ENDPROC pause ; + +PROC internal pause (INT CONST time limit) : + EXTERNAL 66 +ENDPROC internal pause ; + +PROC cat input (TEXT VAR t, esc char) : + EXTERNAL 68 +ENDPROC cat input ; + + +PROC cursor (INT CONST x, y) : + out (""6"") ; + out (code(y-1)) ; + out (code(x-1)) ; +ENDPROC cursor ; + +PROC get cursor (INT VAR x, y) : + EXTERNAL 67 +ENDPROC get cursor ; + +PROC cout (INT CONST number) : + EXTERNAL 61 +ENDPROC cout ; + + +INT PROC channel : + pcb (channel field) +ENDPROC channel ; + +BOOL PROC online : + pcb (channel field) <> 0 +ENDPROC online ; + + +PROC control (INT CONST code1, code2, code3, INT VAR return code) : + EXTERNAL 84 +ENDPROC control ; + +PROC blockout (ROW 256 INT CONST block, INT CONST code1, code2, + INT VAR return code) : + + access block io ds ; + block io.buffer := block ; + blockout (block io ds, buffer page, code1, code2, return code) . + +access block io ds : + IF NOT initialized (this packet) + THEN block io ds := nilspace + FI ; + block io := block io ds . + +ENDPROC blockout ; + +PROC blockin (ROW 256 INT VAR block, INT CONST code1, code2, + INT VAR return code) : + + access block io ds ; + blockin (block io ds, buffer page, code1, code2, return code) ; + block := block io.buffer . + +access block io ds : + IF NOT initialized (this packet) + THEN block io ds := nilspace + FI ; + block io := block io ds . + +ENDPROC blockin ; + +ENDPACKET basic transput ; + diff --git a/system/base/1.7.5/src/bits b/system/base/1.7.5/src/bits new file mode 100644 index 0000000..e9e84e7 --- /dev/null +++ b/system/base/1.7.5/src/bits @@ -0,0 +1,78 @@ + +PACKET bits DEFINES + + AND , + OR , + XOR , + bit , + lowest reset , + lowest set , + reset bit , + rotate , + set bit : + +LET bits per int = 16 ; + +ROW bits per int INT VAR bit mask := ROW bits per int INT: + (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,-32767-1) ; + +PROC rotate (INT VAR bits, INT CONST number of bits) : + EXTERNAL 83 +ENDPROC rotate ; + +INT OP AND (INT CONST left, right) : + EXTERNAL 124 +ENDOP AND ; + +INT OP OR (INT CONST left, right) : + EXTERNAL 125 +ENDOP OR ; + +INT OP XOR (INT CONST left, right) : + EXTERNAL 121 +ENDOP XOR ; + +BOOL PROC bit (INT CONST bits, bit no) : + + (bits AND bit mask (bit no+1)) <> 0 + +ENDPROC bit ; + +PROC set bit (INT VAR bits, INT CONST bit no) : + + bits := bits OR bit mask (bit no+1) + +ENDPROC set bit ; + +PROC reset bit (INT VAR bits,INT CONST bit no) : + + bits := bits XOR (bits AND bit mask (bit no+1)) + +ENDPROC reset bit ; + +INT PROC lowest set (INT CONST bits) : + + INT VAR mask index ; + FOR mask index FROM 1 UPTO 16 REP + IF (bits AND bit mask (mask index)) <> 0 + THEN LEAVE lowest set WITH mask index - 1 + FI + PER ; + -1 + +ENDPROC lowest set ; + +INT PROC lowest reset (INT CONST bits) : + + INT VAR mask index ; + FOR mask index FROM 1 UPTO bits per int REP + IF (bits AND bit mask (mask index)) = 0 + THEN LEAVE lowest reset WITH mask index - 1 + FI + PER ; + -1 + +ENDPROC lowest reset ; + +ENDPACKET bits ; + diff --git a/system/base/1.7.5/src/bool b/system/base/1.7.5/src/bool new file mode 100644 index 0000000..5bf1e65 --- /dev/null +++ b/system/base/1.7.5/src/bool @@ -0,0 +1,16 @@ + +PACKET bool DEFINES XOR, true, false : + +BOOL CONST true := TRUE , + false:= FALSE ; + +BOOL OP XOR (BOOL CONST left, right) : + + IF left THEN NOT right + ELSE right + FI + +ENDOP XOR ; + +ENDPACKET bool ; + diff --git a/system/base/1.7.5/src/command dialogue b/system/base/1.7.5/src/command dialogue new file mode 100644 index 0000000..3011187 --- /dev/null +++ b/system/base/1.7.5/src/command dialogue @@ -0,0 +1,123 @@ + +PACKET command dialogue DEFINES (* Autor: J.Liedtke *) + (* Stand: 25.11.83 *) + command dialogue , + say , + yes , + no , + param position , + last param , + std , + QUIET , + quiet : + + +LET up = ""3"" , + right = ""2"" , + cr lf = ""13""10"" , + param pre = " (""" , + param post = """)"13""10"" ; + + +TEXT VAR std param := "" ; + +BOOL VAR dialogue flag := TRUE ; + +INT VAR param x := 0 ; + + +TYPE QUIET = INT ; + +QUIET PROC quiet : + QUIET:(0) +ENDPROC quiet ; + + +BOOL PROC command dialogue : + dialogue flag +ENDPROC command dialogue ; + +PROC command dialogue (BOOL CONST status) : + dialogue flag := status +ENDPROC command dialogue ; + + +BOOL PROC yes (TEXT CONST question) : + + IF dialogue flag + THEN ask question + ELSE TRUE + FI . + +ask question : + out (question) ; + skip previous input chars ; + out (" (j/n) ? ") ; + get answer ; + IF correct answer + THEN out (answer) ; + out (cr lf) ; + positive answer + ELSE out (""7"") ; + LENGTH question + 9 TIMESOUT ""8"" ; + yes (question) + FI . + +get answer : + TEXT VAR answer ; + inchar (answer) . + +correct answer : + pos ("jnyJNY", answer) > 0 . + +positive answer : + pos ("jyJY", answer) > 0 . + +skip previous input chars : + REP UNTIL incharety = "" PER . + +ENDPROC yes ; + +BOOL PROC no (TEXT CONST question) : + + NOT yes (question) + +ENDPROC no ; + +PROC say (TEXT CONST message) : + + IF dialogue flag + THEN out (message) + FI + +ENDPROC say ; + +PROC param position (INT CONST x) : + + param x := x + +ENDPROC param position ; + +TEXT PROC last param : + + IF param x > 0 AND online + THEN out (up) ; + param x TIMESOUT right ; + out (param pre) ; + out (std param) ; + out (param post) + FI ; + std param . + +ENDPROC last param ; + +PROC last param (TEXT CONST new) : + std param := new +ENDPROC last param ; + +TEXT PROC std : + std param +ENDPROC std ; + +ENDPACKET command dialogue ; + diff --git a/system/base/1.7.5/src/command handler b/system/base/1.7.5/src/command handler new file mode 100644 index 0000000..756382b --- /dev/null +++ b/system/base/1.7.5/src/command handler @@ -0,0 +1,290 @@ +(* ------------------- VERSION 2 05.05.86 ------------------- *) +PACKET command handler DEFINES (* Autor: J.Liedtke *) + + get command , + analyze command , + do command , + command error , + cover tracks : + + +LET cr lf = ""4""13""10"" , + esc k = ""27"k" , + command pre = ""4""13" " , + command post = ""13""10" " , + + max command length = 2010 , + + tag type = 1 , + texttype = 4 , + eof type = 7 ; + + +TEXT VAR command handlers own command line := "" , + previous command line := "" , + symbol , + procedure , + pattern , + error note := "" ; + +INT VAR symbol type ; + + +PROC get command (TEXT CONST command text) : + + get command (command text, command handlers own command line) + +ENDPROC get command ; + +PROC get command (TEXT CONST command text, TEXT VAR command line) : + + set line nr (0) ; + error protocoll ; + get command from console . + +error protocoll : + IF is error + THEN put error ; + clear error + ELSE command line := "" ; + FI . + +get command from console : + normalize cursor ; + REP + out (command pre) ; + out (command text) ; + out (command post) ; + editget command + UNTIL command line <> "" PER ; + param position (LENGTH command line) ; + out (command post) . + +editget command : + TEXT VAR exit char ; + REP + get cursor (x, y) ; + editget (command line, max command length, x size - x, + "", "k", exit char) ; + ignore halt errors during editget ; + break quiet if command line is too long ; + IF exit char = esc k + THEN cursor to begin of command input ; + command line := previous command line + ELIF LENGTH command line > 1 + THEN previous command line := command line ; + LEAVE editget command + ELSE LEAVE editget command + FI + PER . + +normalize cursor : + INT VAR x, y; + out (crlf) ; + get cursor (x, y) ; + cursor (x, y) . + +ignore halt errors during editget : + IF is error + THEN clear error + FI . + +break quiet if command line is too long : + IF command line is too long + THEN command line := "break (quiet)" + FI . + +command line is too long : + LENGTH command line = max command length . + +cursor to begin of command input : + out (command pre) . + +ENDPROC get command ; + + +PROC analyze command ( TEXT CONST command list, + INT CONST permitted type, + INT VAR command index, number of params, + TEXT VAR param 1, param 2) : + + analyze command (command list, command handlers own command line, + permitted type, command index, + number of params, param 1, param 2) + +ENDPROC analyze command ; + +PROC analyze command ( TEXT CONST command list, command line, + INT CONST permitted type, + INT VAR command index, number of params, + TEXT VAR param 1, param 2) : + + error note := "" ; + scan (command line) ; + next symbol ; + IF symbol type <> tag type AND symbol <> "?" + THEN error ("Name ungueltig") ; + impossible command + ELIF pos (command list, symbol) > 0 + THEN procedure name ; + parameter list pack option ; + nothing else in command line ; + decode command + ELSE impossible command + FI . + +procedure name : + procedure := symbol ; + next symbol . + +parameter list pack option : + number of params := 0 ; + param 1 := "" ; + param 2 := "" ; + IF symbol = "(" + THEN next symbol ; + parameter list ; + IF symbol <> ")" AND error note = "" + THEN error (") fehlt") + FI + ELIF symbol type <> eof type + THEN error ("( fehlt") + FI . + +parameter list : + parameter (param 1, number of params, permitted type) ; + IF symbol = "," + THEN next symbol ; + parameter (param 2, number of params, permitted type) ; + FI . + +nothing else in command line : + next symbol ; + IF symbol <> "" + THEN error ("Kommando zu schwierig") + FI . + +decode command : + command index := index (command list, procedure, number of params) . + +impossible command : + command index := 0 . + +ENDPROC analyze command ; + +PROC parameter (TEXT VAR param, INT VAR number of params, + INT CONST permitted type) : + + IF symbol type = text type OR symbol type = permitted type + THEN param := symbol ; + number of params INCR 1 ; + next symbol + ELSE error ("Parameter ist kein TEXT ("" fehlt)") + FI + +ENDPROC parameter ; + +INT PROC index (TEXT CONST list, procedure, INT CONST params) : + + pattern := procedure ; + pattern CAT ":" ; + IF procedure name found + THEN get colon pos ; + get dot pos ; + get end pos ; + get command index ; + get param index ; + IF param index >= 0 + THEN command index + param index + ELSE - command index + FI + ELSE 0 + FI . + +procedure name found : + INT VAR index pos := pos (list, pattern) ; + WHILE index pos > 0 REP + IF index pos = 1 COR (list SUB index pos - 1) <= "9" + THEN LEAVE procedure name found WITH TRUE + FI ; + index pos := pos (list, pattern, index pos + 1) + PER ; + FALSE . + +get param index : + INT CONST param index := + pos (list, text (params), dot pos, end pos) - dot pos - 1 . + +get command index : + INT CONST command index := + int ( subtext (list, colon pos + 1, dot pos - 1) ) . + +get colon pos : + INT CONST colon pos := pos (list, ":", index pos) . + +get dot pos : + INT CONST dot pos := pos (list, ".", index pos) . + +get end pos : + INT CONST end pos := dot pos + 4 . + +ENDPROC index ; + +PROC do command : + + do (command handlers own command line) + +ENDPROC do command ; + +PROC error (TEXT CONST message) : + + error note := message ; + scan ("") ; + procedure := "-" + +ENDPROC error ; + +PROC command error : + + disable stop ; + IF error note <> "" + THEN errorstop (error note) ; + error note := "" + FI ; + enable stop + +ENDPROC command error ; + + +PROC next symbol : + + next symbol (symbol, symbol type) + +ENDPROC next symbol ; + + +PROC cover tracks : + + cover tracks (command handlers own command line) ; + cover tracks (previous command line) ; + erase buffers of compiler and do packet . + +erase buffers of compiler and do packet : + do (command handlers own command line) . + +ENDPROC cover tracks ; + +PROC cover tracks (TEXT VAR secret) : + + INT VAR i ; + FOR i FROM 1 UPTO LENGTH secret REP + replace (secret, i, " ") + PER ; + WHILE LENGTH secret < 13 REP + secret CAT " " + PER + +ENDPROC cover tracks ; + +ENDPACKET command handler ; + diff --git a/system/base/1.7.5/src/dataspace b/system/base/1.7.5/src/dataspace new file mode 100644 index 0000000..3045a53 --- /dev/null +++ b/system/base/1.7.5/src/dataspace @@ -0,0 +1,74 @@ +(* ------------------- VERSION 3 22.04.86 ------------------- *) +PACKET dataspace DEFINES + + := , + nilspace , + forget , + type , + heap size , + storage , + ds pages , + next ds page , + blockout , + blockin , + ALIGN : + + +LET myself id field = 9 , + lowest ds number = 4 , + highest ds number = 255 ; + +TYPE ALIGN = ROW 252 INT ; + +OP := (DATASPACE VAR dest, DATASPACE CONST source ) : + EXTERNAL 70 +ENDOP := ; + +DATASPACE PROC nilspace : + EXTERNAL 69 +ENDPROC nilspace ; + +PROC forget (DATASPACE CONST dataspace ) : + EXTERNAL 71 +ENDPROC forget ; + +PROC type (DATASPACE CONST ds, INT CONST type) : + EXTERNAL 72 +ENDPROC type ; + +INT PROC type (DATASPACE CONST ds) : + EXTERNAL 73 +ENDPROC type ; + +INT PROC heap size (DATASPACE CONST ds) : + EXTERNAL 74 +ENDPROC heap size ; + +INT PROC storage (DATASPACE CONST ds) : + (ds pages (ds) + 1) DIV 2 +ENDPROC storage ; + +INT PROC ds pages (DATASPACE CONST ds) : + pages (ds, pcb (myself id field)) +ENDPROC ds pages ; + +INT PROC pages (DATASPACE CONST ds, INT CONST task nr) : + EXTERNAL 88 +ENDPROC pages ; + +INT PROC next ds page (DATASPACE CONST ds, INT CONST page nr) : + EXTERNAL 87 +ENDPROC next ds page ; + +PROC blockout (DATASPACE CONST ds, INT CONST page nr, code1, code2, + INT VAR return code) : + EXTERNAL 85 +ENDPROC blockout ; + +PROC blockin (DATASPACE VAR ds, INT CONST page nr, code1, code2, + INT VAR return code) : + EXTERNAL 86 +ENDPROC blockin ; + +ENDPACKET dataspace ; + diff --git a/system/base/1.7.5/src/date handling b/system/base/1.7.5/src/date handling new file mode 100644 index 0000000..66da110 --- /dev/null +++ b/system/base/1.7.5/src/date handling @@ -0,0 +1,303 @@ +PACKET date handling DEFINES date, time, (* Autor: H. Indenbirken *) + time of day, (* Stand: 02.06.1986 (wk)*) + month, day , year , + hour , + minute, + second : + +LET middle yearlength = 31557380.0, + weeklength = 604800.0, + daylength = 86400.0, + hours = 3600.0, + minutes = 60.0, + seconds = 1.0; + + +(* Tage bis zum Jahr 01.01.1900: 693970.25 5.995903e10 Sekunden *) +(* Dieser Tag ist ein Montag *) + +REAL VAR begin of today := 0.0 , end of today := 0.0 ; + +TEXT VAR today , result ; + + +ROW 12 REAL CONST previous days :: ROW 12 REAL : (0.0, 2678400.0, 5097600.0, + 7776000.0, 10368000.0, 13046400.0, + 15638400.0, 18316800.0, 20995200.0, + 23587200.0, 26265600.0, 28857600.0); + +REAL PROC day: day length END PROC day; +REAL PROC hour: hours END PROC hour; +REAL PROC minute: minutes END PROC minute; +REAL PROC second: seconds END PROC second; + +TEXT PROC date : + + IF clock (1) < begin of today OR end of today <= clock (1) + THEN begin of today := clock (1) ; + end of today := floor (begin of today/daylength)*daylength+daylength; + today := date (begin of today) + FI ; + today + +ENDPROC date ; + +TEXT PROC date (REAL CONST datum): + INT VAR year :: int (datum/middle yearlength), + day :: int (((datum - datum MOD daylength) MOD middle yearlength) / daylength) + 1; + +correct kalendary day; + + calculate month and correct day; + result := daytext; + result CAT monthtext; + result CAT yeartext; + change all (result, " ", "0") ; + result . + +correct kalendary day: + IF day >= 60 AND NOT leapyear + THEN day INCR 1 FI . + +leapyear: + IF year MOD 100 = 0 + THEN year MOD 400 = 0 + ELSE year MOD 4 = 0 + FI. + +calculate month and correct day: + INT VAR month; + IF day > 182 + THEN IF day > 274 + THEN IF day > 305 + THEN IF day > 335 + THEN month := 12; + day DECR 335 + ELSE month := 11; + day DECR 305 + FI + ELSE month := 10; + day DECR 274 + FI + ELSE IF day > 213 + THEN IF day > 244 + THEN month := 9; + day DECR 244 + ELSE month := 8; + day DECR 213 + FI + ELSE month := 7; + day DECR 182 + FI + FI + ELSE IF day > 91 + THEN IF day > 121 + THEN IF day > 152 + THEN month := 6; + day DECR 152 + ELSE month := 5; + day DECR 121 + FI + ELSE month := 4; + day DECR 91 + FI + ELSE IF day > 31 + THEN IF day > 60 + THEN month := 3; + day DECR 60 + ELSE month := 2; + day DECR 31 + FI + ELSE month := 1 FI + FI + FI . + +daytext : + text (day, 2) + "." . + +monthtext : + text (month,2) + "." . + +yeartext: + IF 1900 <= year AND year < 2000 + THEN text (year - 1900, 2) + ELSE text (year, 4) + FI . + +END PROC date; + +TEXT PROC day (REAL CONST datum): + SELECT int ((datum MOD weeklength)/daylength) OF + CASE 1: "Donnerstag" + CASE 2: "Freitag" + CASE 3: "Samstag" + CASE 4: "Sonntag" + CASE 5: "Montag" + CASE 6: "Dienstag" + OTHERWISE "Mittwoch" ENDSELECT . +END PROC day; + +TEXT PROC month (REAL CONST datum): + SELECT int (subtext (date (datum), 4, 5)) OF + CASE 1: "Januar" + CASE 2: "Februar" + CASE 3: "März" + CASE 4: "April" + CASE 5: "Mai" + CASE 6: "Juni" + CASE 7: "Juli" + CASE 8: "August" + CASE 9: "September" + CASE 10: "Oktober" + CASE 11: "November" + OTHERWISE "Dezember" ENDSELECT . + +END PROC month; + +TEXT PROC year (REAL CONST datum) : + + TEXT VAR buffer := subtext (date (datum), 7) ; + IF LENGTH buffer = 2 + THEN "19" + buffer + ELSE buffer + FI . + +ENDPROC year ; + +TEXT PROC time of day : + time of day (clock (1)) +ENDPROC time of day ; + +TEXT PROC time of day (REAL CONST value) : + subtext (time (value MOD daylength), 1, 5) +ENDPROC time of day ; + +TEXT PROC time (REAL CONST value) : + time (value,10) +ENDPROC time ; + +TEXT PROC time (REAL CONST value, INT CONST length) : + result := "" ; + IF length > 7 + THEN result CAT hour ; + result CAT ":" + FI ; + result CAT minute ; + result CAT ":" ; + result CAT rest ; + change all (result, " ", "0") ; + result . + +hour : + text (int (value/hours), length-8) . + +minute : + text (int (value/minutes MOD 60.0), 2) . + +rest : + text (value MOD minutes, 4, 1) . + +END PROC time ; + +REAL PROC date (TEXT CONST datum) : + split and check datum; + real (day no)*daylength + + previous days [month no] + calendary day + + floor (real (year no)*middleyearlength / daylength)*daylength . + +split and check datum: + INT CONST day no :: first no; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI; + + INT CONST month no :: second no; + IF NOT last conversion ok OR month no < 1 OR month no > 12 + THEN errorstop ("inkorrekte Datumsangabe (Monat) : " + datum) FI; + + INT CONST year no :: third no + century; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Jahr) : " + datum) FI; + + IF day no < 1 OR day no > size of month + THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI . + +century: + IF (length (datum) - second pos) <= 2 + THEN 1900 + ELSE 0 FI . + +size of month: + SELECT month no OF + CASE 1, 3, 5, 7, 8, 10, 12: 31 + CASE 4, 6, 9, 11: 30 + OTHERWISE february size ENDSELECT . + +february size: + IF leapyear + THEN 29 + ELSE 28 FI . + +calendary day: + IF month no > 2 AND leapyear + THEN daylength + ELSE 0.0 FI . + +leapyear: + year no MOD 4 = 0 AND year no MOD 400 <> 0 . + +first no: + INT CONST first pos :: pos (datum, "."); + int (subtext (datum, 1, first pos-1)) . + +second no: + INT CONST second pos :: pos (datum, ".", first pos+1); + int (subtext (datum, first pos + 1, second pos-1)) . + +third no: + int (subtext (datum, second pos + 1)) . + +END PROC date; + +REAL PROC time (TEXT CONST time) : + split and check time; + hour + min + sec . + +split and check time: + REAL CONST hour :: hour no * hours; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Stunde) : " + time) FI; + + REAL CONST min :: min no * minutes; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Minute) : " + time) FI; + + REAL CONST sec :: sec no; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Sekunde) : " + time) FI; + + set conversion (hour ok AND min ok AND sec ok) . + +hour no: + INT CONST hour pos :: pos (time, ":"); + real (subtext (time, 1, hour pos-1)) . + +min no: + INT VAR min pos :: pos (time, ":", hour pos+1); + IF min pos = 0 + THEN real (subtext (time, hour pos + 1, LENGTH time)) + ELSE real (subtext (time, hour pos + 1, min pos-1)) + FI . + +sec no: + IF min pos = 0 + THEN 0.0 + ELSE real (subtext (time, min pos + 1)) + FI . + +hour ok: 0.0 <= hour AND hour < daylength . +min ok: 0.0 <= min AND min < hours . +sec ok: 0.0 <= sec AND sec < minutes . +END PROC time; + +END PACKET datehandling + diff --git a/system/base/1.7.5/src/editor b/system/base/1.7.5/src/editor new file mode 100644 index 0000000..62af2db --- /dev/null +++ b/system/base/1.7.5/src/editor @@ -0,0 +1,2959 @@ +PACKET editor paket DEFINES (* EDITOR 121 *) + (**********) (* 19.07.85 -bk- *) + (* 10.09.85 -ws- *) + (* 25.04.86 -sh- *) + edit, editget, (* 06.06.86 -wk- *) + quit, quit last, (* 04.06.86 -jl- *) + push, type, + word wrap, margin, + write permission, + set busy indicator, + two bytes, + is kanji esc, + within kanji, + rubin mode, + is editget, + getchar, nichts neu, + getcharety, satznr neu, + is incharety, ueberschrift neu, + get window, zeile neu, + get editcursor, abschnitt neu, + get editline, bildabschnitt neu, + put editline, bild neu, + aktueller editor, alles neu, + groesster editor, satznr zeigen, + open editor, ueberschrift zeigen, + editfile, bild zeigen: + + +LET hop = ""1"", right = ""2"", + up char = ""3"", clear eop = ""4"", + clear eol = ""5"", cursor pos = ""6"", + piep = ""7"", left = ""8"", + down char = ""10"", rubin = ""11"", + rubout = ""12"", cr = ""13"", + mark key = ""16"", abscr = ""17"", + inscr = ""18"", dezimal = ""19"", + backcr = ""20"", esc = ""27"", + dach = ""94"", blank = " "; + + +LET no output = 0, out zeichen = 1, + out feldrest = 2, out feld = 3, + clear feldrest = 4; + +LET FELDSTATUS = STRUCT (INT stelle, alte stelle, rand, limit, + anfang, marke, laenge, verschoben, + BOOL einfuegen, fliesstext, write access, + TEXT tabulator); +FELDSTATUS VAR feldstatus; + +TEXT VAR begin mark := ""15"", + end mark := ""14""; + +TEXT VAR separator := "", kommando := "", audit := "", zeichen := "", + satzrest := "", merksatz := "", alter editsatz := ""; + +INT VAR kommando zeiger := 1, umbruchstelle, umbruch verschoben, + zeile, spalte, output mode := no output, postblanks := 0, + min schreibpos, max schreibpos, cpos, absatz ausgleich; + +BOOL VAR lernmodus := FALSE, separator eingestellt := FALSE, + invertierte darstellung := FALSE, absatzmarke steht, + cursor diff := FALSE, editget modus := FALSE, + two byte mode := FALSE, std fliesstext := TRUE;. + +schirmbreite : x size - 1 . +schirmhoehe : y size . +maxbreite : schirmbreite - 2 . +maxlaenge : schirmhoehe - 1 . +marklength : mark size .; + +initialisiere editor; + +.initialisiere editor : + anfang := 1; zeile := 0; verschoben := 0; tabulator := ""; + einfuegen := FALSE; fliesstext := TRUE; zeileneinfuegen := FALSE; + marke := 0; bildmarke := 0; feldmarke := 0.; + +(******************************** editget ********************************) + +PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge, + TEXT CONST sep, res, TEXT VAR exit char) : + IF editlaenge < 1 THEN errorstop ("Fenster zu klein") FI; + separator := ""13""; separator CAT sep; + separator eingestellt := TRUE; + TEXT VAR reservierte editget tasten := ""11""12"" ; + reservierte editget tasten CAT res ; + disable stop; + absatz ausgleich := 0; exit char := ""; get cursor; + FELDSTATUS CONST alter feldstatus := feldstatus; + feldstatus := FELDSTATUS : (1, 1, spalte - 1, editlimit, + 1, 0, editlaenge, 0, + FALSE, FALSE, TRUE, ""); + konstanten neu berechnen; + output mode := out feld; + feld editieren; + zeile verlassen; + feldstatus := alter feldstatus; + konstanten neu berechnen; + separator := ""; + separator eingestellt := FALSE . + +feld editieren : + REP + feldeditor (editsatz, reservierte editget tasten); + IF is error + THEN kommando zeiger := 1; kommando := ""; LEAVE feld editieren + FI ; + TEXT VAR t, zeichen; getchar (zeichen); + IF zeichen ist separator + THEN exit char := zeichen; LEAVE feld editieren + ELIF zeichen = hop + THEN feldout (editsatz, stelle); getchar (zeichen) + ELIF zeichen = mark key + THEN output mode := out feld + ELIF zeichen = abscr + THEN exit char := cr; LEAVE feld editieren + ELIF zeichen = esc + THEN getchar (zeichen); auf exit pruefen; + IF zeichen = rubout (*sh*) + THEN IF marke > 0 + THEN merksatz := subtext (editsatz, marke, stelle - 1); + change (editsatz, marke, stelle - 1, ""); + stelle := marke; marke := 0; konstanten neu berechnen + FI + ELIF zeichen = rubin + THEN t := subtext (editsatz, 1, stelle - 1); + t CAT merksatz; + satzrest := subtext (editsatz, stelle); + t CAT satzrest; + stelle INCR LENGTH merksatz; + merksatz := ""; editsatz := t + ELIF zeichen ist kein esc kommando (*wk*) + AND + kommando auf taste (zeichen) <> "" + THEN editget kommando ausfuehren + FI ; + output mode := out feld + FI + PER . + +zeichen ist kein esc kommando : (*wk*) + pos (hop + left + right, zeichen) = 0 . + +zeile verlassen : + IF marke > 0 OR verschoben <> 0 + THEN stelle DECR verschoben; verschoben := 0; feldout (editsatz, 0) + ELSE cursor (rand + 1 + min (LENGTH editsatz, editlaenge), zeile) + FI . + +zeichen ist separator : pos (separator, zeichen) > 0 . + +auf exit pruefen : + IF pos (res, zeichen) > 0 + THEN exit char := esc + zeichen; LEAVE feld editieren + FI . + +editget kommando ausfuehren : + editget zustaende sichern ; + do (kommando auf taste (zeichen)) ; + alte editget zustaende wieder herstellen ; + IF stelle < marke THEN stelle := marke FI; + konstanten neu berechnen . + +editget zustaende sichern : (*wk*) + BOOL VAR alter editget modus := editget modus; + FELDSTATUS VAR feldstatus vor do kommando := feldstatus ; + INT VAR zeile vor do kommando := zeile ; + TEXT VAR separator vor do kommando := separator ; + BOOL VAR separator eingestellt vor do kommando := separator eingestellt ; + editget modus := TRUE ; + alter editsatz := editsatz . + +alte editget zustaende wieder herstellen : + editget modus := alter editget modus ; + editsatz := alter editsatz; + feldstatus := feldstatus vor do kommando ; + zeile := zeile vor do kommando ; + separator := separator vor do kommando ; + separator eingestellt := separator eingestellt vor do kommando . + +END PROC editget; + +PROC editget (TEXT VAR editsatz, INT CONST editlimit, TEXT VAR exit char) : + editget (editsatz, editlimit, x size - x cursor, "", "", exit char) +END PROC editget; (* 05.07.84 -bk- *) + +PROC editget (TEXT VAR editsatz, TEXT CONST sep, res, TEXT VAR exit char) : + editget (editsatz, max text length, x size - x cursor, sep, res, exit char) +END PROC editget; (* 05.07.84 -bk- *) + +PROC editget (TEXT VAR editsatz) : + TEXT VAR exit char; (* 05.07.84 -bk- *) + editget (editsatz, max text length, x size - x cursor, "", "", exit char) +END PROC editget; + +PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge) : + TEXT VAR exit char; + editget (editsatz, editlimit, editlaenge, "", "", exit char) +ENDPROC editget; + +(******************************* feldeditor ******************************) + +TEXT VAR reservierte feldeditor tasten ; (*jl*) + +PROC feldeditor (TEXT VAR satz, TEXT CONST res) : + enable stop; + reservierte feldeditor tasten := ""1""2""8"" ; + reservierte feldeditor tasten CAT res; + absatzmarke steht := (satz SUB LENGTH satz) = blank; + alte stelle merken; + cursor diff bestimmen und ggf ausgleichen; + feld editieren; + absatzmarke updaten . + +alte stelle merken : alte stelle := stelle . + +cursor diff bestimmen und ggf ausgleichen : + IF cursor diff + THEN stelle INCR 1; cursor diff := FALSE + FI ; + IF stelle auf zweitem halbzeichen + THEN stelle DECR 1; cursor diff := TRUE + FI . + +feld editieren : + REP + feld optisch aufbereiten; + kommando annehmen und ausfuehren + PER . + +absatzmarke updaten : + IF absatzmarke soll stehen + THEN IF NOT absatzmarke steht THEN absatzmarke schreiben (TRUE) FI + ELSE IF absatzmarke steht THEN absatzmarke schreiben (FALSE) FI + FI . + +absatzmarke soll stehen : (satz SUB LENGTH satz) = blank . + +feld optisch aufbereiten : + stelle korrigieren; + verschieben wenn erforderlich; + randausgleich fuer doppelzeichen; + output mode behandeln; + ausgabe verhindern . + +randausgleich fuer doppelzeichen : + IF stelle = max schreibpos CAND stelle auf erstem halbzeichen + THEN verschiebe (1) + FI . + +stelle korrigieren : + IF stelle auf zweitem halbzeichen THEN stelle DECR 1 FI . + +stelle auf erstem halbzeichen : within kanji (satz, stelle + 1) . + +stelle auf zweitem halbzeichen : within kanji (satz, stelle) . + +output mode behandeln : + SELECT output mode OF + CASE no output : im markiermode markierung anpassen + CASE out zeichen : zeichen ausgeben; LEAVE output mode behandeln + CASE out feldrest : feldrest neu schreiben + CASE out feld : feldout (satz, stelle) + CASE clear feldrest : feldrest loeschen + END SELECT; + schreibmarke positionieren (stelle) . + +ausgabe verhindern : output mode := no output . + +im markiermode markierung anpassen : + IF markiert THEN markierung anpassen FI . + +markierung anpassen : + IF stelle > alte stelle + THEN markierung verlaengern + ELIF stelle < alte stelle + THEN markierung verkuerzen + FI . + +markierung verlaengern : + invers out (satz, alte stelle, stelle, "", end mark) . + +markierung verkuerzen : + invers out (satz, stelle, alte stelle, end mark, "") . + +zeichen ausgeben : + IF NOT markiert + THEN out (zeichen) + ELIF mark refresh line mode + THEN feldout (satz, stelle); schreibmarke positionieren (stelle) + ELSE out (begin mark); markleft; out (zeichen); out (end mark); markleft + FI . + +markleft : + marklength TIMESOUT left . + +feldrest neu schreiben : + IF NOT markiert + THEN feldrest unmarkiert neu schreiben + ELSE feldrest markiert neu schreiben + FI ; + WHILE postblanks > 0 CAND x cursor <= rand + laenge REP + out (blank); postblanks DECR 1 + PER ; postblanks := 0 . + +feldrest unmarkiert neu schreiben : + schreibmarke positionieren (alte stelle); + out subtext mit randbehandlung (satz, alte stelle, stelle am ende) . + +feldrest markiert neu schreiben : + markierung verlaengern; out subtext mit randbehandlung + (satz, stelle, stelle am ende - 2 * marklength) . + +kommando annehmen und ausfuehren : + kommando annehmen; kommando ausfuehren . + +kommando annehmen : + getchar (zeichen); kommando zurueckweisen falls noetig . + +kommando zurueckweisen falls noetig : + IF NOT write access CAND zeichen ist druckbar + THEN benutzer warnen; kommando ignorieren + FI . + +benutzer warnen : out (piep) . + +kommando ignorieren : + zeichen := ""; LEAVE kommando annehmen und ausfuehren . + +kommando ausfuehren : + neue satzlaenge bestimmen; + alte stelle merken; + IF zeichen ist separator + THEN feldeditor verlassen + ELIF zeichen ist druckbar + THEN fortschreiben + ELSE funktionstasten behandeln + FI . + +neue satzlaenge bestimmen : INT VAR satzlaenge := LENGTH satz . + +feldeditor verlassen : + IF NOT absatzmarke steht THEN blanks abschneiden FI; (*sh*) + push (zeichen); LEAVE feld editieren . + +blanks abschneiden : + INT VAR letzte non blank pos := satzlaenge; + WHILE letzte non blank pos > 0 CAND (satz SUB letzte non blank pos) = blank REP + letzte non blank pos DECR 1 + PER; satz := subtext (satz, 1, letzte non blank pos) . + +zeichen ist druckbar : zeichen >= blank . + +zeichen ist separator : + separator eingestellt CAND pos (separator, zeichen) > 0 . + +fortschreiben : + zeichen in satz eintragen; + IF is kanji esc (zeichen) THEN kanji zeichen schreiben FI; + bei erreichen von limit ueberlauf behandeln . + +zeichen in satz eintragen : + IF hinter dem satz + THEN satz mit leerzeichen auffuellen und zeichen anfuegen + ELIF einfuegen + THEN zeichen vor aktueller position einfuegen + ELSE altes zeichen ersetzen + FI . + +hinter dem satz : stelle > satzlaenge . + +satz mit leerzeichen auffuellen und zeichen anfuegen : + satz AUFFUELLENMIT blank; + zeichen anfuegen; + output mode := out zeichen . + +zeichen anfuegen : satz CAT zeichen; neue satzlaenge bestimmen . +zeichen ignorieren : benutzer warnen; LEAVE kommando ausfuehren . + +zeichen vor aktueller position einfuegen : + insert char (satz, zeichen, stelle); + neue satzlaenge bestimmen; + output mode := out feldrest . + +altes zeichen ersetzen : + replace (satz, stelle, zeichen); + IF stelle auf erstem halbzeichen + THEN output mode := out feldrest; replace (satz, stelle + 1, blank) + ELSE output mode := out zeichen + FI . + +kanji zeichen schreiben : + alte stelle merken; + stelle INCR 1; getchar (zeichen); + IF zeichen < ""64"" THEN zeichen := ""64"" FI; + IF hinter dem satz + THEN zeichen anfuegen + ELIF einfuegen + THEN zeichen vor aktueller position einfuegen + ELSE replace (satz, stelle, zeichen) + FI ; + output mode := out feldrest . + +bei erreichen von limit ueberlauf behandeln : (*sh*) + IF satzlaenge kritisch + THEN in naechste zeile falls moeglich + ELSE stelle INCR 1 + FI . + +satzlaenge kritisch : + IF stelle >= satzlaenge + THEN satzlaenge = limit + ELSE satzlaenge = limit + 1 + FI . + +in naechste zeile falls moeglich : + IF fliesstext AND umbruch moeglich OR NOT fliesstext AND stelle >= satzlaenge + THEN in naechste zeile + ELSE stelle INCR 1 + FI . + +umbruch moeglich : + INT CONST st := stelle; stelle := limit; + INT CONST ltzt wortanf := letzter wortanfang (satz); + stelle := st; einrueckposition (satz) < ltzt wortanf . + +in naechste zeile : + IF fliesstext + THEN ueberlauf und oder umbruch + ELSE ueberlauf ohne umbruch + FI . + +ueberlauf und oder umbruch : + INT VAR umbruchpos := 1; + umbruchposition bestimmen; + loeschposition bestimmen; + IF stelle = satzlaenge + THEN ueberlauf mit oder ohne umbruch + ELSE umbruch mit oder ohne ueberlauf + FI . + +umbruchposition bestimmen : + umbruchstelle := stelle; + stelle := satzlaenge; + umbruchpos := max (umbruchpos, letzter wortanfang (satz)); + stelle := umbruchstelle . + +loeschposition bestimmen : + INT VAR loeschpos := umbruchpos; + WHILE davor noch blank REP loeschpos DECR 1 PER . + +davor noch blank : + loeschpos > ganz links CAND (satz SUB (loeschpos - 1)) = blank . + +ganz links : max (1, marke) . + +ueberlauf mit oder ohne umbruch : + IF zeichen = blank OR loeschpos = ganz links + THEN stelle := 1; ueberlauf ohne umbruch + ELSE ueberlauf mit umbruch + FI . + +ueberlauf ohne umbruch : push (cr) . + +ueberlauf mit umbruch : + ausgabe verhindern; + umbruchkommando aufbereiten; + auf loeschposition positionieren . + +umbruchkommando aufbereiten : + zeichen := hop + rubout + inscr; + satzrest := subtext (satz, umbruchpos); + zeichen CAT satzrest; + IF stelle ist im umgebrochenen teil + THEN insert char (zeichen, backcr, max (stelle - umbruchpos + 1, 0) + 4); + zeichen CAT backcr + FI ; + push (zeichen) . + +stelle ist im umgebrochenen teil : stelle >= loeschpos . + +auf loeschposition positionieren : stelle := loeschpos . + +umbruch mit oder ohne ueberlauf : + umbruchposition anpassen; + IF stelle ist im umgebrochenen teil + THEN umbruch mit ueberlauf + ELSE umbruch ohne ueberlauf + FI . + +umbruchposition anpassen : + IF zeichen = blank + THEN umbruchpos := stelle + 1; + umbruchposition bestimmen; + neue loeschposition bestimmen + FI . + +neue loeschposition bestimmen : + loeschpos := umbruchpos; + WHILE davor noch blank AND stelle noch nicht erreicht REP loeschpos DECR 1 PER . + +stelle noch nicht erreicht : loeschpos > stelle + 1 . + +umbruch mit ueberlauf : ueberlauf mit umbruch . + +umbruch ohne ueberlauf : + zeichen := inscr; + satzrest := subtext (satz, umbruchpos); + zeichen CAT satzrest; + zeichen CAT up char + backcr; + umbruchstelle INCR 1; umbruch verschoben := verschoben; + satz := subtext (satz, 1, loeschpos - 1); + schreibmarke positionieren (loeschpos); feldrest loeschen; + output mode := out feldrest; + push (zeichen) . + +funktionstasten behandeln : + SELECT pos (kommandos, zeichen) OF + CASE c hop : hop kommandos behandeln + CASE c esc : esc kommandos behandeln + CASE c right : nach rechts oder ueberlauf + CASE c left : wenn moeglich ein schritt nach links + CASE c tab : zur naechsten tabulator position + CASE c dezimal : dezimalen schreiben + CASE c rubin : einfuegen umschalten + CASE c rubout : ein zeichen loeschen + CASE c abscr, c inscr, c down : feldeditor verlassen + CASE c up : eine zeile nach oben (*sh*) + CASE c cr : ggf absatz erzeugen + CASE c mark : markieren umschalten + CASE c backcr : zurueck zur umbruchstelle + OTHERWISE : sondertaste behandeln + END SELECT . + +kommandos : + LET c hop = 1, c right = 2, + c up = 3, c left = 4, + c tab = 5, c down = 6, + c rubin = 7, c rubout = 8, + c cr = 9, c mark = 10, + c abscr = 11, c inscr = 12, + c dezimal = 13, c esc = 14, + c backcr = 15; + + ""1""2""3""8""9""10""11""12""13""16""17""18""19""27""20"" . + +dezimalen schreiben : IF write access THEN dezimaleditor (satz) FI . + +zurueck zur umbruchstelle: + IF umbruch stelle > 0 THEN stelle := umbruch stelle FI; + IF verschoben <> umbruch verschoben + THEN verschoben := umbruch verschoben; output mode := out feld + FI . + +hop kommandos behandeln : + TEXT VAR zweites zeichen; getchar (zweites zeichen); + zeichen CAT zweites zeichen; + SELECT pos (hop kommandos, zweites zeichen) OF + CASE h hop : nach links oben + CASE h right : nach rechts blaettern + CASE h left : nach links blaettern + CASE h tab : tab position definieren oder loeschen + CASE h rubin : zeile splitten + CASE h rubout : loeschen oder rekombinieren + CASE h cr, h up, h down : feldeditor verlassen + OTHERWISE : zeichen ignorieren + END SELECT . + +hop kommandos : + LET h hop = 1, h right = 2, + h up = 3, h left = 4, + h tab = 5, h down = 6, + h rubin = 7, h rubout = 8, + h cr = 9; + + ""1""2""3""8""9""10""11""12""13"" . + +nach links oben : + stelle := max (marke, anfang) + verschoben; feldeditor verlassen . + +nach rechts blaettern : + INT CONST rechter rand := stelle am ende - markierausgleich; + IF stelle ist am rechten rand + THEN stelle INCR laenge - 2 * markierausgleich + ausgleich fuer doppelzeichen + ELSE stelle := rechter rand + FI ; + IF satzlaenge <= limit THEN stelle := min (stelle, limit) FI; + alte einrueckposition mitziehen . + +stelle ist am rechten rand : + stelle auf erstem halbzeichen CAND stelle = rechter rand - 1 + COR stelle = rechter rand . + +ausgleich fuer doppelzeichen : stelle - rechter rand . + +nach links blaettern : + INT CONST linker rand := stelle am anfang; + IF stelle = linker rand + THEN stelle DECR laenge - 2 * markierausgleich + ELSE stelle := linker rand + FI ; + stelle := max (ganz links, stelle); + alte einrueckposition mitziehen . + +tab position definieren oder loeschen : + IF stelle > LENGTH tabulator + THEN tabulator AUFFUELLENMIT right; tabulator CAT dach + ELSE replace (tabulator, stelle, neues tab zeichen) + FI ; + feldeditor verlassen . + +neues tab zeichen : + IF (tabulator SUB stelle) = right THEN dach ELSE right FI . + +zeile splitten : + IF write access THEN feldeditor verlassen ELSE zeichen ignorieren FI . + +loeschen oder rekombinieren : + IF NOT write access + THEN zeichen ignorieren + ELIF hinter dem satz + THEN zeilen rekombinieren + ELIF auf erstem zeichen + THEN ganze zeile loeschen + ELSE zeilenrest loeschen + FI . + +zeilen rekombinieren : feldeditor verlassen . +auf erstem zeichen : stelle = 1 . +ganze zeile loeschen : satz := ""; feldeditor verlassen . + +zeilenrest loeschen : + change (satz, stelle, satzlaenge, ""); + output mode := clear feldrest . + +esc kommandos behandeln : + getchar (zweites zeichen); + zeichen CAT zweites zeichen; + auf exit pruefen; + SELECT pos (esc kommandos, zweites zeichen) OF + CASE e hop : lernmodus umschalten + CASE e right : zum naechsten wort + CASE e left : zum vorigen wort + OTHERWISE : belegte taste ausfuehren + END SELECT . + +auf exit pruefen : + IF pos (res, zweites zeichen) > 0 THEN feldeditor verlassen FI . + +esc kommandos : + LET e hop = 1, + e right = 2, + e left = 3; + + ""1""2""8"" . + +lernmodus umschalten : + IF lernmodus THEN lernmodus ausschalten ELSE lernmodus einschalten FI; + feldeditor verlassen . + +lernmodus ausschalten : + lernmodus := FALSE; + belegbare taste erfragen; + audit := subtext (audit, 1, LENGTH audit - 2); + IF taste = hop + THEN (* lernsequenz nicht auf taste legen *) (* 16.08.85 -ws- *) + ELSE lernsequenz auf taste legen (taste, audit) + FI ; + audit := "" . + +belegbare taste erfragen : + TEXT VAR taste; getchar (taste); + WHILE taste ist reserviert REP + benutzer warnen; getchar (taste) + PER . + +taste ist reserviert : (* 16.08.85 -ws- *) + taste <> hop CAND pos (reservierte feldeditor tasten, taste) > 0 . + +lernmodus einschalten : audit := ""; lernmodus := TRUE . + +zum vorigen wort : + IF stelle > 1 + THEN stelle DECR 1; stelle := letzter wortanfang (satz); + alte einrueckposition mitziehen; + IF (satz SUB stelle) <> blank THEN LEAVE zum vorigen wort FI + FI ; + feldeditor verlassen . + +zum naechsten wort : + IF kein naechstes wort THEN feldeditor verlassen FI . + +kein naechstes wort : + BOOL VAR im alten wort := TRUE; + INT VAR i; + FOR i FROM stelle UPTO satzlaenge REP + IF im alten wort + THEN im alten wort := (satz SUB i) <> blank + ELIF (satz SUB i) <> blank + THEN stelle := i; LEAVE kein naechstes wort WITH FALSE + FI + PER; + TRUE . + +belegte taste ausfuehren : + IF ist kommando taste + THEN feldeditor verlassen + ELSE gelerntes ausfuehren + FI . + +ist kommando taste : taste enthaelt kommando (zweites zeichen) . + +gelerntes ausfuehren : + push (lernsequenz auf taste (zweites zeichen)) . (*sh*) + +nach rechts oder ueberlauf : + IF fliesstext COR stelle < limit OR satzlaenge > limit + THEN nach rechts + ELSE auf anfang der naechsten zeile + FI . + +nach rechts : + IF stelle auf erstem halbzeichen THEN stelle INCR 2 ELSE stelle INCR 1 FI; + alte einrueckposition mitziehen . + +auf anfang der naechsten zeile : push (abscr) . + +nach links : stelle DECR 1; alte einrueckposition mitziehen . + +alte einrueckposition mitziehen : + IF satz ist leerzeile + THEN alte einrueckposition := stelle + ELSE alte einrueckposition := min (stelle, einrueckposition (satz)) + FI . + +satz ist leerzeile : + satz = "" OR satz = blank . + +wenn moeglich ein schritt nach links : + IF stelle = ganz links + THEN zeichen ignorieren + ELSE nach links + FI . + +zur naechsten tabulator position : + bestimme naechste explizite tabulator position; + IF tabulator gefunden + THEN explizit tabulieren + ELIF stelle <= satzlaenge + THEN implizit tabulieren + ELSE auf anfang der naechsten zeile + FI . + +bestimme naechste explizite tabulator position : + INT VAR tab position := pos (tabulator, dach, stelle + 1); + IF tab position > limit AND satzlaenge <= limit + THEN tab position := 0 + FI . + +tabulator gefunden : tab position <> 0 . + +explizit tabulieren : stelle := tab position; push (dezimal) . + +implizit tabulieren : + tab position := einrueckposition (satz); + IF stelle < tab position + THEN stelle := tab position + ELSE stelle := satzlaenge + 1 + FI . + +einfuegen umschalten : + IF NOT write access THEN zeichen ignorieren FI; (*sh*) + einfuegen := NOT einfuegen; + IF einfuegen THEN einfuegen optisch anzeigen FI; + feldeditor verlassen . + +einfuegen optisch anzeigen : + IF markiert + THEN out (begin mark); markleft; out (dach left); warten; + out (end mark); markleft + ELSE out (dach left); warten; + IF stelle auf erstem halbzeichen + THEN out text (satz, stelle, stelle + 1) + ELSE out text (satz, stelle, stelle) + FI + FI . + +markiert : marke > 0 . +dach left : ""94""8"" . + +warten : + TEXT VAR t := incharety (2); + kommando CAT t; IF lernmodus THEN audit CAT t FI . + +ein zeichen loeschen : + IF NOT write access THEN zeichen ignorieren FI; (*sh*) + IF zeichen davor soll geloescht werden + THEN nach links oder ignorieren + FI ; + IF NOT hinter dem satz THEN aktuelles zeichen loeschen FI . + +zeichen davor soll geloescht werden : + hinter dem satz COR markiert . + +nach links oder ignorieren : + IF stelle > ganz links + THEN nach links (*sh*) + ELSE zeichen ignorieren + FI . + +aktuelles zeichen loeschen : + stelle korrigieren; alte stelle merken; + IF stelle auf erstem halbzeichen + THEN delete char (satz, stelle); + postblanks INCR 1 + FI ; + delete char (satz, stelle); + postblanks INCR 1; + neue satzlaenge bestimmen; + output mode := out feldrest . + +eine zeile nach oben : (*sh*) + IF NOT absatzmarke steht CAND NOT ist teil eines umbruchkommandos + THEN blanks abschneiden + FI ; + push (zeichen); LEAVE feld editieren . + +ist teil eines umbruchkommandos : (kommando SUB kommandozeiger) = backcr . + +ggf absatz erzeugen : (*sh*) + IF write access + THEN IF NOT absatzmarke steht THEN blanks abschneiden FI; + IF stelle > LENGTH satz AND fliesstext AND NOT absatzmarke steht + THEN satz CAT blank + FI + FI ; push (zeichen); LEAVE feld editieren . + +markieren umschalten : + IF markiert + THEN marke := 0; maxschreibpos INCR marklength; cpos DECR marklength + ELSE marke := stelle; maxschreibpos DECR marklength; cpos INCR marklength; + verschieben wenn erforderlich + FI ; + feldeditor verlassen . + +sondertaste behandeln : push (esc + zeichen) . +END PROC feldeditor; + +PROC dezimaleditor (TEXT VAR satz) : + INT VAR dezimalanfang := stelle; + zeichen einlesen; + IF dezimalstartzeichen CAND ueberschreibbar THEN dezimalen schreiben FI; + push (zeichen) . + +zeichen einlesen : TEXT VAR zeichen; getchar (zeichen) . +dezimalzeichen : pos (dezimalen, zeichen) > 0 AND nicht separator . +dezimalstartzeichen : pos (startdezimalen, zeichen) > 0 AND nicht separator . +dezimalen : "0123456789" . +startdezimalen : "+-0123456789" . +nicht separator : pos (separator, zeichen) = 0 . + +ueberschreibbar : + dezimalanfang > LENGTH satz OR + pos (ueberschreibbare zeichen, satz SUB dezimalanfang) > 0 . + +ueberschreibbare zeichen : " ,.+-0123456789" . + +dezimalen schreiben : + REP + dezimale in satz eintragen; + dezimalen zeigen; + zeichen einlesen; + dezimalanfang DECR 1 + UNTIL dezimaleditor beendet PER; + stelle INCR 1 . + +dezimale in satz eintragen : + IF dezimalanfang > LENGTH satz + THEN satz AUFFUELLENMIT blank; satz CAT zeichen + ELSE delete char (satz, dezimalanfang); insert char (satz, zeichen, stelle) + FI . + +dezimalen zeigen : + INT VAR min dezimalschreibpos := max (min schreibpos, dezimalanfang); + IF markiert THEN markiert zeigen ELSE unmarkiert zeigen FI; + schreibmarke positionieren (stelle) . + +markiert : marke > 0 . + +markiert zeigen : + invers out (satz, min dezimalschreibpos, stelle, "", end mark); + out (zeichen) . + +unmarkiert zeigen : + schreibmarke positionieren (min dezimalschreibpos); + out subtext (satz, min dezimalschreibpos, stelle) . + +dezimaleditor beendet : + NOT dezimalzeichen OR + dezimalanfang < max (min schreibpos, marke) OR + NOT ueberschreibbar . +END PROC dezimaleditor; + +BOOL PROC is editget : + editget modus +END PROC is editget ; + +PROC get editline (TEXT VAR editline, INT VAR editpos, editmarke) : + IF editget modus + THEN editline := alter editsatz; + editpos := stelle + FI ; + editmarke := marke +END PROC get editline; + +PROC put editline (TEXT CONST editline, INT CONST editpos, editmarke) : + IF editget modus + THEN alter editsatz := editline; + stelle := max (editpos, 1); + marke := max (editmarke, 0) + FI +END PROC put editline; + +BOOL PROC within kanji (TEXT CONST satz, INT CONST stelle) : + count directly prefixing kanji esc bytes; + number of kanji esc bytes is odd . + +count directly prefixing kanji esc bytes : + INT VAR pos := stelle - 1, kanji esc bytes := 0; + WHILE pos > 0 CAND is kanji esc (satz SUB pos) REP + kanji esc bytes INCR 1; pos DECR 1 + PER . + +number of kanji esc bytes is odd : + (kanji esc bytes AND 1) <> 0 . +END PROC within kanji; + +BOOL PROC is kanji esc (TEXT CONST char) : (*sh*) + two byte mode CAND + (char >= ""129"" AND char <= ""159"" OR char >= ""224"" AND char <= ""239"") +END PROC is kanji esc; + +BOOL PROC two bytes : two byte mode END PROC two bytes; + +PROC two bytes (BOOL CONST new mode) : + two byte mode := new mode +END PROC two bytes; + +PROC outtext (TEXT CONST source, INT CONST from, to) : + out subtext mit randbehandlung (source, from, to); + INT VAR trailing; + IF from <= LENGTH source + THEN trailing := to - LENGTH source + ELSE trailing := to - from + 1 + FI ; trailing TIMESOUT blank +END PROC outtext; + +PROC out subtext mit randbehandlung (TEXT CONST satz, INT CONST von, bis) : + IF von > bis + THEN + ELIF bis >= LENGTH satz COR NOT within kanji (satz, bis + 1) + THEN out subtext mit anfangsbehandlung (satz, von, bis) + ELSE out subtext mit anfangsbehandlung (satz, von, bis - 1); out (blank) + FI +END PROC out subtext mit randbehandlung; + +PROC out subtext mit anfangsbehandlung (TEXT CONST satz, INT CONST von, bis) : + IF von > bis + THEN + ELIF von = 1 COR NOT within kanji (satz, von) + THEN out subtext (satz, von, bis) + ELSE out (blank); out subtext (satz, von + 1, bis) + FI +END PROC out subtext mit anfangsbehandlung; + +PROC get cursor : get cursor (spalte, zeile) END PROC get cursor; + +INT PROC x cursor : get cursor; spalte END PROC x cursor; + +BOOL PROC write permission : write access END PROC write permission; + +PROC push (TEXT CONST ausfuehrkommando) : + IF ausfuehrkommando = "" (*sh*) + THEN + ELIF kommando = "" + THEN kommando := ausfuehrkommando + ELIF (kommando SUB kommando zeiger - 1) = ausfuehrkommando + THEN kommando zeiger DECR 1 + ELIF replace moeglich + THEN kommando zeiger DECR laenge des ausfuehrkommandos; + replace (kommando, kommando zeiger, ausfuehrkommando) + ELSE insert char (kommando, ausfuehrkommando, kommando zeiger) + FI . + +replace moeglich : + INT CONST laenge des ausfuehrkommandos := LENGTH ausfuehrkommando; + kommando zeiger > laenge des ausfuehrkommandos . +END PROC push; + +PROC type (TEXT CONST ausfuehrkommando) : + kommando CAT ausfuehrkommando +END PROC type; + +INT PROC stelle am anfang : anfang + verschoben END PROC stelle am anfang; + +INT PROC stelle am ende : stelle am anfang+laenge-1 END PROC stelle am ende; + +INT PROC markierausgleich : SIGN marke * marklength END PROC markierausgleich; + +PROC verschieben wenn erforderlich : + IF stelle > max schreibpos + THEN verschiebe (stelle - max schreibpos) + ELIF stelle < min schreibpos + THEN verschiebe (stelle - min schreibpos) + FI +END PROC verschieben wenn erforderlich; + +PROC verschiebe (INT CONST i) : + verschoben INCR i; + min schreibpos INCR i; + max schreibpos INCR i; + cpos DECR i; + output mode := out feld; + schreibmarke positionieren (stelle) (* 11.05.85 -ws- *) +END PROC verschiebe; + +PROC konstanten neu berechnen : + min schreibpos := anfang + verschoben; + IF min schreibpos < 0 (* 17.05.85 -ws- *) + THEN min schreibpos DECR verschoben; verschoben := 0 + FI ; + max schreibpos := min schreibpos + laenge - 1 - markierausgleich; + cpos := rand + laenge - max schreibpos +END PROC konstanten neu berechnen; + +PROC schreibmarke positionieren (INT CONST sstelle) : + cursor (cpos + sstelle, zeile) +END PROC schreibmarke positionieren; + +PROC simple feldout (TEXT CONST satz, INT CONST dummy) : + (* PRECONDITION : NOT markiert AND verschoben = 0 *) + (* AND feldrest schon geloescht *) + schreibmarke an feldanfang positionieren; + out subtext mit randbehandlung (satz, anfang, anfang + laenge - 1); + IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI . + +schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) . +END PROC simple feldout; + +PROC feldout (TEXT CONST satz, INT CONST sstelle) : + schreibmarke an feldanfang positionieren; + feld ausgeben; + feldrest loeschen; + IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI . + +schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) . + +feld ausgeben : + INT VAR von := anfang + verschoben, bis := von + laenge - 1; + IF nicht markiert + THEN unmarkiert ausgeben + ELIF markiertes nicht sichtbar + THEN unmarkiert ausgeben + ELSE markiert ausgeben + FI . + +nicht markiert : marke <= 0 . + +markiertes nicht sichtbar : + bis DECR marklength * (1 + SIGN sstelle); marke > bis + 1 . + +unmarkiert ausgeben : + out subtext mit randbehandlung (satz, von, bis) . + +markiert ausgeben : + INT VAR smarke := max (von, marke); + out text (satz, von, smarke - 1); out (begin mark); + verschiedene feldout modes behandeln . + +verschiedene feldout modes behandeln : + IF sstelle = 0 + THEN out subtext mit randbehandlung (satz, smarke, bis); out (end mark) + ELSE out text (satz, smarke, zeilenrand); out (end mark); (*sh*) + out subtext mit randbehandlung (satz, sstelle, bis) + FI . + +zeilenrand : min (bis, sstelle - 1) . +END PROC feldout; + +PROC absatzmarke schreiben (BOOL CONST schreiben) : + IF fliesstext AND nicht markiert + THEN cursor (rand + 1 + laenge, zeile); + out (absatzmarke) ; + absatzmarke steht := TRUE + FI . + +nicht markiert : marke <= 0 . + +absatzmarke : + IF NOT schreiben + THEN " " + ELIF marklength > 0 + THEN ""15""14"" + ELSE ""15" "14" " + FI . +END PROC absatzmarke schreiben; + +PROC invers out (TEXT CONST satz, INT CONST von, bis, TEXT CONST pre, post) : + IF mark refresh line mode + THEN feldout (satz, stelle) + ELSE schreibmarke positionieren (von); + out (begin mark); markleft; out (pre); + out text (satz, von, bis - 1); out (post) + FI . + +markleft : + marklength TIMESOUT left . + +END PROC invers out; + +PROC feldrest loeschen : + IF rand + laenge < maxbreite COR invertierte darstellung + THEN INT VAR x; get cursor (x, zeile); + (rand + laenge - x + 1 + absatz ausgleich) TIMESOUT blank; (*sh*) + cursor (x, zeile) + ELSE out (clear eol); absatzmarke steht := FALSE + FI +END PROC feldrest loeschen; + +OP AUFFUELLENMIT (TEXT VAR satz, TEXT CONST fuellzeichen) : + INT VAR i; + FOR i FROM stelle - LENGTH satz DOWNTO 2 REP + satz CAT fuellzeichen + PER +END OP AUFFUELLENMIT; + +INT PROC einrueckposition (TEXT CONST satz) : (*sh*) + IF fliesstext AND satz = blank + THEN anfang + ELSE max (pos (satz, ""33"", ""254"", 1), 1) + FI +END PROC einrueckposition; + +INT PROC letzter wortanfang (TEXT CONST satz) : (*sh*) + INT CONST ganz links := max (1, marke); + BOOL VAR noch nicht im neuen wort := TRUE; + INT VAR i; + FOR i FROM stelle DOWNTO ganz links REP + IF noch nicht im neuen wort + THEN noch nicht im neuen wort := char = blank + ELIF is kanji esc (char) + THEN LEAVE letzter wortanfang WITH i + ELIF nicht mehr im neuen wort + THEN LEAVE letzter wortanfang WITH i + 1 + FI + PER ; + ganz links . + +char : satz SUB i . + +nicht mehr im neuen wort : char = blank COR within kanji (satz, i) . +END PROC letzter wortanfang; + +PROC getchar (TEXT VAR zeichen) : + IF kommando = "" + THEN inchar (zeichen); IF lernmodus THEN audit CAT zeichen FI + ELSE zeichen := kommando SUB kommando zeiger; + kommando zeiger INCR 1; + IF kommando zeiger > LENGTH kommando + THEN kommando zeiger := 1; kommando := "" + FI ; + IF LENGTH kommando - kommando zeiger < 3 + THEN kommando CAT inchety + FI + FI . +END PROC getchar; + +TEXT PROC inchety : + IF lernmodus + THEN TEXT VAR t := incharety; audit CAT t; t + ELSE incharety + FI +END PROC inchety; + +BOOL PROC is incharety (TEXT CONST muster) : + IF kommando = "" + THEN TEXT CONST t := inchety; + IF t = muster THEN TRUE ELSE kommando := t; FALSE FI + ELIF (kommando SUB kommando zeiger) = muster + THEN kommando zeiger INCR 1; + IF kommando zeiger > LENGTH kommando + THEN kommando zeiger := 1; kommando := "" + FI ; + TRUE + ELSE FALSE + FI +END PROC is incharety; + +TEXT PROC getcharety : + IF kommando = "" + THEN inchety + ELSE TEXT CONST t := kommando SUB kommando zeiger; + kommando zeiger INCR 1; + IF kommando zeiger > LENGTH kommando + THEN kommando zeiger := 1; kommando := "" + FI ; t + FI +END PROC getcharety; + +PROC get editcursor (INT VAR x, y) : (*sh*) + IF actual editor > 0 THEN aktualisiere bildparameter FI; + x := rand - (anfang + verschoben - 1 - markierausgleich) + stelle; + y := zeile . + + aktualisiere bildparameter : + INT VAR old x, old y; get cursor (old x, old y); + dateizustand holen; bildausgabe steuern; satznr zeigen; + fenster zeigen; zeile := bildrand + zeilennr; cursor (old x, old y) . +END PROC get editcursor; + +(************************* Zugriff auf Feldstatus *************************). + +stelle : feldstatus.stelle . +alte stelle : feldstatus.alte stelle . +rand : feldstatus.rand . +limit : feldstatus.limit . +anfang : feldstatus.anfang . +marke : feldstatus.marke . +laenge : feldstatus.laenge . +verschoben : feldstatus.verschoben . +einfuegen : feldstatus.einfuegen . +fliesstext : feldstatus.fliesstext . +write access : feldstatus.write access . +tabulator : feldstatus.tabulator . + +(***************************************************************************) + +LET undefinierter bereich = 0, nix = 1, + bildzeile = 2, akt satznr = 2, + abschnitt = 3, ueberschrift = 3, + bild = 4, fehlermeldung = 4; + +LET BILDSTATUS = STRUCT (INT feldlaenge, kurze feldlaenge, + bildrand, bildlaenge, kurze bildlaenge, + ueberschriftbereich, bildbereich, + erster neusatz, letzter neusatz, + old zeilennr, old lineno, old mark lineno, + BOOL zeileneinfuegen, old line update, + TEXT satznr pre, ueberschrift pre, + ueberschrift text, ueberschrift post, old satz, + FRANGE old range, + FILE file), + EDITSTATUS = STRUCT (FELDSTATUS feldstatus, BILDSTATUS bildstatus), + max editor = 10, + EDITSTACK = ROW max editor EDITSTATUS; + +BILDSTATUS VAR bildstatus ; +EDITSTACK VAR editstack; + +ROW max editor INT VAR einrueckstack; + +BOOL VAR markiert; +TEXT VAR filename, tab, bildsatz, bildzeichen, fehlertext, + akt bildsatz ; +INT VAR zeilennr, satznr, bildanfang, bildmarke, feldmarke, + actual editor := 0, max used editor := 0, + letzer editor auf dieser datei, + alte einrueckposition := 1; + +INT PROC aktueller editor : actual editor END PROC aktueller editor; + +INT PROC groesster editor : max used editor END PROC groesster editor; + +(****************************** bildeditor *******************************) + +PROC bildeditor (TEXT CONST res, PROC (TEXT CONST) kommando interpreter) : + evtl fehler behandeln; + enable stop; + TEXT VAR reservierte tasten := ""11""12""27"bf" ; + reservierte tasten CAT res ; + INT CONST my highest editor := max used editor; + laenge := feldlaenge; + konstanten neu berechnen; + REP + markierung justieren; + altes feld nachbereiten; + feldlaenge einstellen; + ueberschrift zeigen; + fenster zeigen ; + zeile bereitstellen; + zeile editieren; + kommando ausfuehren + PER . + +evtl fehler behandeln : + IF is error + THEN fehlertext := errormessage; + IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI; + clear error + ELSE fehlertext := "" + FI . + +markierung justieren : + IF bildmarke > 0 + THEN IF satznr <= bildmarke + THEN bildmarke := satznr; + stelle := max (stelle, feldmarke); + marke := feldmarke + ELSE marke := 1 + FI + FI . + +zeile bereitstellen : IF hinter letztem satz THEN insert record (file) FI . +hinter letztem satz : lineno (file) > lines (file) . + +altes feld nachbereiten : + IF old line update AND lineno (file) <> old lineno + THEN IF verschoben <> 0 + THEN verschoben := 0; konstanten neu berechnen; + FI ; + INT CONST alte zeilennr := old lineno - bildanfang + 1; + IF alte zeilennr > 0 AND alte zeilennr <= aktuelle bildlaenge + THEN INT CONST m := marke; + IF lineno (file) < old lineno + THEN marke := 0 + ELIF old lineno = bildmarke + THEN marke := min (feldmarke, LENGTH old satz + 1) + ELSE marke := min (marke, LENGTH old satz + 1) + FI ; + zeile := bildrand + alte zeilennr; + feldout (old satz, 0); marke := m + FI + FI ; + old line update := FALSE; old satz := "" . + +feldlaenge einstellen : + INT CONST alte laenge := laenge; + IF zeilennr > kurze bildlaenge + THEN laenge := kurze feldlaenge + ELSE laenge := feldlaenge + FI ; + IF laenge <> alte laenge + THEN konstanten neu berechnen + FI . + +zeile editieren : + zeile := bildrand + zeilennr; + exec (PROC (TEXT VAR, TEXT CONST) feldeditor, file, reservierte tasten); + old lineno := satznr; + IF markiert oder verschoben + THEN old line update := TRUE; read record (file, old satz) + FI . + +markiert oder verschoben : markiert COR verschoben <> 0 . + +kommando ausfuehren : + getchar (bildzeichen); + SELECT pos (kommandos, bildzeichen) OF + CASE x hop : hop kommando verarbeiten + CASE x esc : esc kommando verarbeiten + CASE x up : zum vorigen satz + CASE x down : zum folgenden satz + CASE x rubin : zeicheneinfuegen umschalten + CASE x mark : markierung umschalten + CASE x cr : eingerueckt mit cr (* 08.06.85 -ws- *) + CASE x inscr : eingerueckt zum folgenden satz + CASE x abscr : zum anfang des folgenden satzes + END SELECT . + +kommandos : + LET x hop = 1, x up = 2, + x down = 3, x rubin = 4, + x cr = 5, x mark = 6, + x abscr = 7, x inscr = 8, + x esc = 9; + + ""1""3""10""11""13""16""17""18""27"" . + +zeicheneinfuegen umschalten : + rubin segment in ueberschrift eintragen; + neu (ueberschrift, nix) . + +rubin segment in ueberschrift eintragen : + replace (ueberschrift text, 9, rubin segment) . + +rubin segment : + IF einfuegen THEN "RUBIN" ELSE "....." FI . + +hop kommando verarbeiten : + getchar (bildzeichen); + read record (file, bildsatz); + SELECT pos (hop kommandos, bildzeichen) OF + CASE y hop : nach oben + CASE y cr : neue seite + CASE y up : zurueckblaettern + CASE y down : weiterblaettern + CASE y tab : put tabs (file, tabulator); neu (ueberschrift, nix) + CASE y rubout : zeile loeschen + CASE y rubin : zeileneinfuegen umschalten + END SELECT . + +hop kommandos : + LET y hop = 1, y up = 2, + y tab = 3, y down = 4, + y rubin = 5, y rubout = 6, + y cr = 7; + + ""1""3""9""10""11""12""13"" . + +zeileneinfuegen umschalten : + zeileneinfuegen := NOT zeileneinfuegen; + IF zeileneinfuegen + THEN zeile aufspalten; logisches eof setzen + ELSE leere zeile am ende loeschen; logisches eof loeschen + FI ; restbild zeigen . + +zeile aufspalten : + IF stelle <= LENGTH bildsatz OR stelle = 1 + THEN loesche ggf trennende blanks und spalte zeile + FI . + +loesche ggf trennende blanks und spalte zeile: (* 26.06.84 -bk- *) + INT VAR first non blank pos := stelle; + WHILE first non blank pos <= length (bildsatz) CAND + (bildsatz SUB first non blank pos) = blank REP + first non blank pos INCR 1 + PER ; + split line and indentation; (*sh*) + first non blank pos := stelle - 1; + WHILE first non blank pos >= 1 CAND + (bildsatz SUB first non blank pos) = blank REP + first non blank pos DECR 1 + PER; + bildsatz := subtext (bildsatz, 1, first non blank pos); + write record (file, bildsatz) . + +split line and indentation : + split line (file, first non blank pos, TRUE) . + +logisches eof setzen : + down (file); col (file, 1); + set range (file, 1, 1, old range); up (file) . + +leere zeile am ende loeschen : + to line (file, lines (file)); + IF len (file) = 0 THEN delete record (file) FI; + to line (file, satznr) . + +logisches eof loeschen : + col (file, stelle); set range (file, old range) . + +restbild zeigen : + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + rest segment in ueberschrift eintragen; + neu (ueberschrift, abschnitt) . + +rest segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 25, rest segment) . + +rest segment : + IF zeileneinfuegen THEN "REST" ELSE "...." FI . + +esc kommando verarbeiten : + getchar (bildzeichen); + eventuell zeichen zurueckweisen; (* 04.05.85 -ws- *) + IF taste ist reserviert + THEN belegte taste ausfuehren + ELSE fest vordefinierte esc funktion + FI ; ende nach quit . + +eventuell zeichen zurueckweisen : (* 04.05.85 -ws- *) + IF NOT write access CAND NOT erlaubte taste + THEN benutzer warnen; LEAVE kommando ausfuehren + FI . + +erlaubte taste : pos (zulaessige zeichen, bildzeichen) > 0 . +zulaessige zeichen : res + ""1""2""8""27"bfq" . +benutzer warnen : out (piep) . + +ende nach quit : + IF max used editor < my highest editor THEN LEAVE bildeditor FI . + +taste ist reserviert : pos (res, bildzeichen) > 0 . + +fest vordefinierte esc funktion : + read record (file, bildsatz); + SELECT pos (esc kommandos, bildzeichen) OF + CASE z hop : lernmodus umschalten + CASE z esc : kommandodialog versuchen + CASE z left : zum vorigen wort + CASE z right : zum naechsten wort + CASE z b : bild an aktuelle zeile angleichen + CASE z f : belegte taste ausfuehren + CASE z rubout : markiertes vorsichtig loeschen + CASE z rubin : vorsichtig geloeschtes einfuegen + OTHERWISE : belegte taste ausfuehren + END SELECT . + +esc kommandos : + LET z hop = 1, z right = 2, + z left = 3, z rubin = 4, + z rubout = 5, z esc = 6, + z b = 7, z f = 8; + + ""1""2""8""11""12""27"bf" . + +zum vorigen wort : + IF vorgaenger erlaubt + THEN vorgaenger; read record (file, bildsatz); + stelle := LENGTH bildsatz + 1; push (esc + left) + FI . + +vorgaenger erlaubt : + satznr > max (1, bildmarke) . + +zum naechsten wort : + IF nicht auf letztem satz THEN weitersuchen wenn nicht gefunden FI . + +nicht auf letztem satz : line no (file) < lines (file) . + +weitersuchen wenn nicht gefunden : + nachfolgenden satz holen; + IF (nachfolgender satz SUB anfang) = blank + THEN push (abscr + esc + right) + ELSE push (abscr) + FI . + +nachfolgenden satz holen : + down (file); read record (file, nachfolgender satz); up (file) . + +bild an aktuelle zeile angleichen : + anfang INCR verschoben; verschoben := 0; + margin segment in ueberschrift eintragen; + neu (ueberschrift, bild) . + +margin segment in ueberschrift eintragen : + replace (ueberschrift text, 2, margin segment) . + +margin segment : + IF anfang <= 1 + THEN "......" + ELSE TEXT VAR margin text := "M" + text (anfang); + (6 - LENGTH margin text) * "." + margin text + FI . + +belegte taste ausfuehren : + kommando analysieren (bildzeichen, PROC(TEXT CONST) kommando interpreter) . + +kommandodialog versuchen: + IF fenster ist zu schmal fuer dialog + THEN kommandodialog ablehnen + ELSE kommandodialog fuehren + FI . + +fenster ist zu schmal fuer dialog : laenge < 20 . + +kommandodialog ablehnen : + fehlertext := "zu schmal fuer ESC ESC"; neu (fehlermeldung, nix) . + +kommandodialog fuehren: + INT VAR x0, x1, x2, x3, y; + get cursor (x0, y); + cursor (rand + 1, bildrand + zeilennr); + get cursor (x1, y); + out (begin mark); out (monitor meldung); + get cursor (x2, y); + (laenge - LENGTH monitor meldung - marklength) TIMESOUT blank; + get cursor (x3, y); + out (end mark); out (blank); + kommandozeile editieren; + ueberschrift zeigen; + absatz ausgleich := 2; (*sh*) + IF kommandotext = "" THEN LEAVE kommandodialog fuehren FI; + kommando auf taste legen ("f", kommandotext); + kommando analysieren ("f", PROC(TEXT CONST) kommando interpreter); + IF fehlertext <> "" + THEN push (esc + esc + esc + "k") + ELIF markiert + THEN zeile neu + FI . + +kommandozeile editieren : + TEXT VAR kommandotext := ""; + cursor (x1, y); out (begin mark); + disable stop; + darstellung invertieren; + editget schleife; + darstellung invertieren; + enable stop; + cursor (x3, y); out (end mark); + exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle); + cursor (x0, y) . + +darstellung invertieren : + TEXT VAR dummy := begin mark; begin mark := end mark; end mark := dummy; + invertierte darstellung := NOT invertierte darstellung . + +editget schleife : + TEXT VAR exit char; + REP + cursor (x2, y); + editget (kommandotext, max textlength, rand + laenge - x cursor, + "", "k?!", exit char); + neu (ueberschrift, nix); + IF exit char = ""27"k" + THEN kommando text := kommando auf taste ("f") + ELIF exit char = ""27"?" + THEN TEXT VAR taste; getchar (taste); + kommando text := kommando auf taste (taste) + ELIF exit char = ""27"!" + THEN getchar (taste); + IF ist reservierte taste + THEN set busy indicator; (*sh*) + out ("FEHLER: """ + taste + """ ist reserviert"7"") + ELSE kommando auf taste legen (taste, kommandotext); + kommandotext := ""; LEAVE editget schleife + FI + ELSE LEAVE editget schleife + FI + PER . + +ist reservierte taste : pos (res, taste) > 0 . +monitor meldung : "gib kommando : " . + +neue seite : bildanfang := satznr; zeilennr := 1; neu (akt satznr, bild) . + +weiterblaettern : + INT CONST akt bildlaenge := aktuelle bildlaenge; + IF nicht auf letztem satz + THEN erster neusatz := satznr; + IF zeilennr >= akt bildlaenge + THEN bildanfang INCR akt bildlaenge; neu (akt satznr, bild) + FI ; + satznr := min (lines (file), bildanfang + akt bildlaenge - 1); + letzter neusatz := satznr; + toline (file, satznr); + stelle DECR verschoben; + neu (akt satznr, nix); + zeilennr := satznr - bildanfang + 1; + IF markiert THEN neu (nix, abschnitt) FI; + einrueckposition bestimmen + FI . + +zurueckblaettern : + IF vorgaenger erlaubt + THEN IF zeilennr <= 1 + THEN bildanfang := max (1, bildanfang - aktuelle bildlaenge); + neu (akt satznr, bild) + FI ; + nach oben; einrueckposition bestimmen + FI . + +zeile loeschen : + IF stelle = 1 + THEN delete record (file); + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + neu (nix, abschnitt) + ELSE zeilen rekombinieren + FI . + +zeilen rekombinieren : + IF nicht auf letztem satz + THEN aktuellen satz mit blanks auffuellen; + delete record (file); + nachfolgenden satz lesen; + bildsatz CAT nachfolgender satz ohne fuehrende blanks; + write record (file, bildsatz); + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + neu (nix, abschnitt) + FI . + +aktuellen satz mit blanks auffuellen : + bildsatz AUFFUELLENMIT blank . + +nachfolgenden satz lesen : + TEXT VAR nachfolgender satz; + read record (file, nachfolgender satz) . + +nachfolgender satz ohne fuehrende blanks : + satzrest := subtext (nachfolgender satz, + einrueckposition (nachfolgender satz)); satzrest . + +zeile aufsplitten : + nachfolgender satz := ""; + INT VAR i; + FOR i FROM 2 UPTO min (stelle, einrueckposition (bildsatz)) REP + nachfolgender satz CAT blank + PER; + satzrest := subtext (bildsatz, naechste non blank position); + nachfolgender satz CAT satzrest; + bildsatz := subtext (bildsatz, 1, stelle - 1); + write record (file, bildsatz); + down (file); insert record (file); + write record (file, nachfolgender satz); up (file) . + +naechste non blank position : + INT VAR non blank pos := stelle; + WHILE (bildsatz SUB non blank pos) = blank REP + non blank pos INCR 1 + PER; non blank pos . + +zum vorigen satz : + IF vorgaenger erlaubt THEN vorgaenger; einrueckposition bestimmen FI . + +zum folgenden satz : (* 12.09.85 -ws- *) + IF nachfolger erlaubt THEN nachfolger; einrueckposition bestimmen + ELSE col (file, len (file) + 1); neu (nix, nix) + FI . + +einrueckposition bestimmen : (* 27.08.85 -ws- *) + read record (file, akt bildsatz); + INT VAR neue einrueckposition := einrueckposition (akt bildsatz); + IF akt bildsatz ist leerzeile + THEN alte einrueckposition := max (stelle, neue einrueckposition) + ELSE alte einrueckposition := min (stelle, neue einrueckposition) + FI . + +akt bildsatz ist leerzeile : + akt bildsatz = "" OR akt bildsatz = blank . + +zum anfang des folgenden satzes : + IF nachfolger erlaubt THEN nachfolger; stelle := anfang FI . + +nachfolger erlaubt : + write access COR nicht auf letztem satz . + +eingerueckt mit cr : + IF NOT nachfolger erlaubt THEN LEAVE eingerueckt mit cr FI; (*sh*) + read record (file, bildsatz); + INT VAR epos := einrueckposition (bildsatz); + nachfolger; col (file, 1); + IF eof (file) + THEN IF LENGTH bildsatz <= epos + THEN stelle := alte einrueckposition + ELSE stelle := epos + FI + ELSE read record (file, bildsatz); + stelle := einrueckposition (bildsatz); + IF bildsatz ist leerzeile (* 29.08.85 -ws- *) + THEN stelle := alte einrueckposition; + aktuellen satz mit blanks auffuellen + FI + FI ; + alte einrueckposition := stelle . + +bildsatz ist leerzeile : + bildsatz = "" OR bildsatz = blank . + +eingerueckt zum folgenden satz : (*sh*) + IF NOT nachfolger erlaubt OR NOT write access + THEN LEAVE eingerueckt zum folgenden satz + FI; + alte einrueckposition merken; + naechsten satz holen; + neue einrueckposition bestimmen; + alte einrueckposition := stelle . + +alte einrueckposition merken : + read record (file, bildsatz); + epos := einrueckposition (bildsatz); + auf aufzaehlung pruefen; + IF epos > LENGTH bildsatz THEN epos := anfang FI. + +auf aufzaehlung pruefen : + BOOL CONST aufzaehlung gefunden := + ist aufzaehlung CAND vorher absatzzeile CAND wort folgt; + IF aufzaehlung gefunden THEN epos := anfang des naechsten wortes FI . + +ist aufzaehlung : + INT CONST wortende := pos (bildsatz, blank, epos, epos + 20) - 1; + SELECT pos ("-*).:" , bildsatz SUB wortende) OF + CASE 1,2 : wortende = epos + CASE 3,4 : wortende <= epos + 7 + CASE 5 : TRUE + OTHERWISE: FALSE + ENDSELECT . + +vorher absatzzeile : + IF satznr = 1 + THEN TRUE + ELSE up (file); + INT CONST vorige satzlaenge := len (file); + BOOL CONST vorher war absatzzeile := + subtext (file, vorige satzlaenge, vorige satzlaenge) = blank; + down (file); vorher war absatzzeile + FI . + +wort folgt : + INT CONST anfang des naechsten wortes := + pos (bildsatz, ""33"", ""254"", wortende + 1); + anfang des naechsten wortes > wortende . + +naechsten satz holen : + nachfolger; col (file, 1); + IF eof (file) + THEN bildsatz := "" + ELSE IF neue zeile einfuegen erforderlich + THEN insert record (file); bildsatz := ""; + letzter neusatz := bildanfang + bildlaenge - 1 + ELSE read record (file, bildsatz); + letzter neusatz := satznr; + ggf trennungen zurueckwandeln und umbruch indikator einfuegen + FI ; + erster neusatz := satznr; + neu (nix, abschnitt) + FI . + +neue zeile einfuegen erforderlich : + BOOL CONST war absatz := war absatzzeile; + war absatz COR neuer satz ist zu lang . + +war absatzzeile : + INT VAR wl := pos (kommando, up backcr, kommando zeiger); + wl = 0 COR (kommando SUB (wl - 1)) = blank . + +neuer satz ist zu lang : laenge des neuen satzes >= limit . + +laenge des neuen satzes : + IF len (file) > 0 + THEN len (file) + wl + ELSE wl + epos + FI . + +up backcr : ""3""20"" . + +ggf trennungen zurueckwandeln und umbruch indikator einfuegen : + LET trenn k = ""220"", + trenn strich = ""221""; + TEXT VAR umbruch indikator; + IF letztes zeichen ist trenn strich + THEN entferne trenn strich; + IF letztes zeichen = trenn k + THEN wandle trenn k um + FI ; + umbruch indikator := up backcr + ELIF letztes umgebrochenes zeichen ist kanji + THEN umbruch indikator := up backcr + ELSE umbruch indikator := blank + up backcr + FI ; + change (kommando, wl, wl+1, umbruch indikator) . + +letztes umgebrochenes zeichen ist kanji : within kanji (kommando, wl-1) . + +letztes zeichen ist trenn strich : + TEXT CONST last char := letztes zeichen; + last char = trenn strich COR + last char = "-" CAND wl > 2 CAND (kommando SUB (wl-2)) <> blank . + +letztes zeichen : kommando SUB (wl-1) . +entferne trenn strich : delete char (kommando, wl-1); wl DECR 1 . +wandle trenn k um : replace (kommando, wl-1, "c") . +loesche indikator : delete char (kommando, wl) . + +neue einrueckposition bestimmen : + IF aufzaehlung gefunden CAND bildsatz ist leerzeile + THEN stelle := epos + ELIF NOT bildsatz ist leerzeile + THEN stelle := einrueckposition (bildsatz) + ELIF war absatz COR auf letztem satz + THEN stelle := epos + ELSE down (file); read record (file, nachfolgender satz); + up (file); stelle := einrueckposition (nachfolgender satz) + FI ; + IF ist einfuegender aber nicht induzierter umbruch + THEN loesche indikator; + umbruchstelle := stelle + wl - kommando zeiger - anzahl der stz; + umbruchverschoben := 0 + FI . + +auf letztem satz : NOT nicht auf letztem satz . + +ist einfuegender aber nicht induzierter umbruch : + wl := pos (kommando, backcr, kommando zeiger); + wl > 0 CAND (kommando SUB (wl - 1)) <> up char . + +anzahl der stz : + TEXT CONST umgebrochener anfang := subtext (kommando, kommando zeiger, wl-1); + INT VAR anz := 0, anf := pos (umgebrochener anfang, ""1"", ""31"", 1); + WHILE anf > 0 REP + anz INCR 1; anf := pos (umgebrochener anfang, ""1"", ""31"", anf + 1) + PER; anz . + +markiertes vorsichtig loeschen : + IF write access CAND markiert + THEN clear removed (file); + IF nur im satz markiert + THEN behandle einen satz + ELSE behandle mehrere saetze + FI + FI . + +nur im satz markiert : line no (file) = bildmarke . + +behandle einen satz : + insert record (file); + satzrest := subtext (bildsatz, marke, stelle - 1); + write record (file, satzrest); + remove (file, 1); + change (bildsatz, marke, stelle - 1, ""); + stelle := marke; + marke := 0; bildmarke := 0; feldmarke := 0; + markiert := FALSE; mark (file, 0, 0); + konstanten neu berechnen; + IF bildsatz = "" + THEN delete record (file); + erster neusatz := satznr; + letzter neusatz := bildanfang + bildlaenge - 1; + neu (nix, abschnitt) + ELSE write record (file, bildsatz); + neu (nix, bildzeile) + FI . + +behandle mehrere saetze : + erster neusatz := bildmarke; + letzter neusatz := bildanfang + bildlaenge - 1; + zeile an aktueller stelle auftrennen; + ersten markierten satz an markieranfang aufspalten; + markierten bereich entfernen; + bild anpassen . + +zeile an aktueller stelle auftrennen : + INT VAR markierte saetze := line no (file) - bildmarke + 1; + IF nicht am ende der zeile + THEN IF nicht am anfang der zeile + THEN zeile aufsplitten + ELSE up (file); markierte saetze DECR 1 + FI + FI . + +nicht am anfang der zeile : stelle > 1 . +nicht am ende der zeile : stelle <= LENGTH bildsatz . + +ersten markierten satz an markieranfang aufspalten : + to line (file, line no (file) - (markierte saetze - 1)); + read record (file, bildsatz); + stelle := feldmarke; + IF nicht am anfang der zeile + THEN IF nicht am ende der zeile + THEN zeile aufsplitten + ELSE markierte saetze DECR 1 + FI ; + to line (file, line no (file) + markierte saetze) + ELSE to line (file, line no (file) + markierte saetze - 1) + FI ; + read record (file, bildsatz) . + +markierten bereich entfernen : + zeilen nr := line no (file) - markierte saetze - bildanfang + 2; + remove (file, markierte saetze); + marke := 0; bildmarke := 0; feldmarke := 0; + markiert := FALSE; mark (file, 0, 0); + konstanten neu berechnen; + stelle := 1 . + +bild anpassen : + satz nr := line no (file); + IF zeilen nr <= 1 + THEN bildanfang := line no (file); zeilen nr := 1; + neu (akt satznr, bild) + ELSE neu (akt satznr, abschnitt) + FI . + +vorsichtig geloeschtes einfuegen : + IF NOT write access OR removed lines (file) = 0 + THEN LEAVE vorsichtig geloeschtes einfuegen + FI ; + IF nur ein satz + THEN in aktuellen satz einfuegen + ELSE aktuellen satz aufbrechen und einfuegen + FI . + +nur ein satz : removed lines (file) = 1 . + +in aktuellen satz einfuegen : + reinsert (file); + read record (file, nachfolgender satz); + delete record (file); + TEXT VAR t := bildsatz; + bildsatz := subtext (t, 1, stelle - 1); + aktuellen satz mit blanks auffuellen; (*sh*) + bildsatz CAT nachfolgender satz; + satzrest := subtext (t, stelle); + bildsatz CAT satzrest; + write record (file, bildsatz); + stelle INCR LENGTH nachfolgender satz; + neu (nix, bildzeile) . + +aktuellen satz aufbrechen und einfuegen : + INT CONST alter bildanfang := bildanfang; + old lineno := satznr; + IF stelle = 1 + THEN reinsert (file); + read record (file, bildsatz) + ELIF stelle > LENGTH bildsatz + THEN down (file); + reinsert (file); + read record (file, bildsatz) + ELSE INT VAR von := stelle; + WHILE (bildsatz SUB von) = blank REP von INCR 1 PER; + satzrest := subtext (bildsatz, von, LENGTH bildsatz); + INT VAR bis := stelle - 1; + WHILE (bildsatz SUB bis) = blank REP bis DECR 1 PER; + bildsatz := subtext (bildsatz, 1, bis); + write record (file, bildsatz); + down (file); + reinsert (file); + read record (file, bildsatz); + nachfolgender satz := einrueckposition (bildsatz) * blank; + nachfolgender satz CAT satzrest; + down (file); insert record (file); + write record (file, nachfolgender satz); up (file) + FI ; + stelle := max (1, LENGTH bildsatz); (* 22.06.84 -bk- *) + satz nr := line no (file); + zeilennr INCR satznr - old lineno; + zeilennr := min (zeilennr, aktuelle bildlaenge); + bildanfang := satznr - zeilennr + 1; + IF bildanfang veraendert + THEN abschnitt neu (bildanfang, 9999) + ELSE abschnitt neu (old lineno, 9999) + FI ; + neu (akt satznr, nix). + +bildanfang veraendert : bildanfang <> alter bildanfang . + +lernmodus umschalten : + learn segment in ueberschrift eintragen; neu (ueberschrift, nix) . + +learn segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 19, learn segment) . + +learn segment : + IF lernmodus THEN "LEARN" ELSE "....." FI . + +markierung umschalten : + IF markiert THEN markierung ausschalten ELSE markierung einschalten FI . + +markierung einschalten : + bildmarke := satznr; feldmarke := marke; markiert := TRUE; + mark (file, bildmarke, feldmarke); + neu (nix, bildzeile) . + +markierung ausschalten : + erster neusatz := max (bildmarke, bildanfang); + letzter neusatz := satznr; + bildmarke := 0; feldmarke := 0; markiert := FALSE; + mark (file, 0, 0); + IF erster neusatz = letzter neusatz + THEN neu (nix, bildzeile) + ELSE neu (nix, abschnitt) + FI . +END PROC bildeditor; + +PROC neu (INT CONST ue bereich, b bereich) : + ueberschriftbereich := max (ueberschriftbereich, ue bereich); + bildbereich := max (bildbereich, b bereich) +END PROC neu; + + +PROC nach oben : + letzter neusatz := satznr; + satznr := max (bildanfang, bildmarke); + toline (file, satznr); + stelle DECR verschoben; + zeilennr := satznr - bildanfang + 1; + erster neusatz := satznr; + IF markiert + THEN neu (akt satznr, abschnitt) + ELSE neu (akt satznr, nix) + FI +END PROC nach oben; + +INT PROC aktuelle bildlaenge : + IF stelle - stelle am anfang < kurze feldlaenge + AND feldlaenge > 0 + THEN bildlaenge (*wk*) + ELSE kurze bildlaenge + FI +END PROC aktuelle bildlaenge; + +PROC vorgaenger : + up (file); satznr DECR 1; + marke := 0; stelle DECR verschoben; + IF zeilennr = 1 + THEN bildanfang DECR 1; neu (ueberschrift, bild) + ELSE zeilennr DECR 1; neu (akt satznr, nix); (*sh*) + IF markiert THEN neu (nix, bildzeile) FI + FI +END PROC vorgaenger; + +PROC nachfolger : + down (file); satznr INCR 1; + stelle DECR verschoben; + IF zeilennr = aktuelle bildlaenge + THEN bildanfang INCR 1; + IF rollup erlaubt + THEN rollup + ELSE neu (ueberschrift, bild) + FI + ELSE neu (akt satznr, nix); zeilennr INCR 1 (*sh*) + FI ; + IF markiert THEN neu (nix, bildzeile) FI . + +rollup erlaubt : + kurze bildlaenge = maxlaenge AND kurze feldlaenge = maxbreite . + +rollup : + out (down char); + IF bildzeichen = inscr + THEN neu (ueberschrift, nix) + ELIF is cr or down CAND (write access COR nicht auf letztem satz) (*sh*) + THEN neu (nix, bildzeile) + ELSE neu (ueberschrift, bildzeile) + FI . + +is cr or down : + IF kommando = "" THEN kommando := inchety FI; + kommando char = down char COR kommando char = cr . + +kommando char : kommando SUB kommando zeiger . + +nicht auf letztem satz : line no (file) < lines (file) . +END PROC nachfolger; + +BOOL PROC next incharety is (TEXT CONST muster) : + INT CONST klen := LENGTH kommando - kommando zeiger + 1, + mlen := LENGTH muster; + INT VAR i; FOR i FROM 1 UPTO mlen - klen REP kommando CAT inchety PER; + subtext (kommando, kommando zeiger, kommando zeiger + mlen - 1) = muster +END PROC next incharety is; + +PROC quit last: (* 22.06.84 -bk- *) + IF actual editor > 0 AND actual editor < max used editor + THEN verlasse alle groesseren editoren + FI . + +verlasse alle groesseren editoren : + open editor (actual editor + 1); quit . +END PROC quit last; + +PROC quit : + IF actual editor > 0 THEN verlasse aktuellen editor FI . + +verlasse aktuellen editor : + disable stop; + INT CONST aktueller editor := actual editor; + in innersten editor gehen; + REP + IF zeileneinfuegen THEN hop rubin simulieren FI; + ggf bildschirmdarstellung korrigieren; + innersten editor schliessen + UNTIL aktueller editor > max used editor PER; + actual editor := max used editor . + +in innersten editor gehen : open editor (max used editor) . + +hop rubin simulieren : + zeileneinfuegen := FALSE; + leere zeilen am dateiende loeschen; (*sh*) + ggf bildschirmdarstellung korrigieren; + logisches eof loeschen . + +innersten editor schliessen : + max used editor DECR 1; + IF max used editor > 0 + THEN open editor (max used editor); + bildeinschraenkung aufheben + FI . + +logisches eof loeschen : + col (file, stelle); set range (file, old range) . + +leere zeilen am dateiende loeschen : (* 15.08.85 -ws- *) + satz nr := line no (file) ; + to line (file, lines (file)) ; + WHILE lines (file) > 1 AND bildsatz ist leerzeile REP + delete record (file); + to line (file, lines (file)) + PER; + toline (file, satznr) . + +bildsatz ist leerzeile : + TEXT VAR bildsatz; + read record (file, bildsatz); + ist leerzeile . + +ist leerzeile : + bildsatz = "" OR bildsatz = blank . + +ggf bildschirmdarstellung korrigieren : + satz nr DECR 1; (* für Bildschirmkorrektur *) + IF satznr > lines (file) + THEN zeilen nr DECR satz nr - lines (file); + satz nr := lines (file); + dateizustand retten + FI . + +bildeinschraenkung aufheben : + laenge := feldlaenge; + kurze feldlaenge := feldlaenge; + kurze bildlaenge := bildlaenge; + neu (nix, bild) . +END PROC quit; + +PROC nichts neu : neu (nix, nix) END PROC nichts neu; + +PROC satznr neu : neu (akt satznr, nix) END PROC satznr neu; + +PROC ueberschrift neu : neu (ueberschrift, nix) END PROC ueberschrift neu; + +PROC zeile neu : + INT CONST zeile := line no (file); + abschnitt neu (zeile, zeile) +END PROC zeile neu; + +PROC abschnitt neu (INT CONST von satznr, bis satznr) : + IF von satznr <= bis satznr + THEN erster neusatz := min (erster neusatz, von satznr); + letzter neusatz := max (letzter neusatz, bis satznr); + neu (nix, abschnitt) + ELSE abschnitt neu (bis satznr, von satznr) + FI +END PROC abschnitt neu; + +PROC bildabschnitt neu (INT CONST von zeile, bis zeile) : (*sh*) + IF von zeile <= bis zeile + THEN erster neusatz := max (1, von zeile + bildanfang - 1); + letzter neusatz := min (bildlaenge, bis zeile + bildanfang - 1); + IF von zeile < 1 + THEN neu (ueberschrift, abschnitt) + ELSE neu (nix , abschnitt) + FI + ELSE bildabschnitt neu (bis zeile, von zeile) + FI +END PROC bildabschnitt neu; + +PROC bild neu : neu (nix, bild) END PROC bild neu; (*sh*) + +PROC bild neu (FILE VAR f) : + INT CONST editor no := abs (editinfo (f)) DIV 256; + IF editor no > 0 AND editor no <= max used editor + THEN IF editor no = actual editor + THEN bild neu + ELSE editstack (editor no).bildstatus.bildbereich := bild + FI + FI +END PROC bild neu; + +PROC alles neu : + neu (ueberschrift, bild); + INT VAR i; + FOR i FROM 1 UPTO max used editor REP + editstack (i).bildstatus.bildbereich := bild; + editstack (i).bildstatus.ueberschriftbereich := ueberschrift + PER +END PROC alles neu; + +PROC satznr zeigen : + out (satznr pre); out (text (text (lineno (file)), 4)) +END PROC satznr zeigen; + +PROC ueberschrift zeigen : + SELECT ueberschriftbereich OF + CASE akt satznr : satznr zeigen; + ueberschriftbereich := nix + CASE ueberschrift : ueberschrift schreiben; + ueberschriftbereich := nix + CASE fehlermeldung : fehlermeldung schreiben; + ueberschriftbereich := ueberschrift + END SELECT +END PROC ueberschrift zeigen; + +PROC fenster zeigen : + SELECT bildbereich OF + CASE bildzeile : + zeile := bildrand + zeilennr; + IF line no (file) > lines (file) + THEN feldout ("", stelle) + ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle) + FI + CASE abschnitt : + bild ausgeben + CASE bild : + erster neusatz := 1; + letzter neusatz := 9999; + bild ausgeben + OTHERWISE : + LEAVE fenster zeigen + END SELECT; + erster neusatz := 9999; + letzter neusatz := 0; + bildbereich := nix +END PROC fenster zeigen ; + +PROC bild ausgeben : + BOOL CONST schreiben ist ganz einfach := NOT markiert AND verschoben = 0; + INT CONST save marke := marke, + save verschoben := verschoben, + save laenge := laenge, + act lineno := lineno (file), + von := max (1, erster neusatz - bildanfang + 1); + INT VAR bis := min (letzter neusatz - bildanfang + 1, bildlaenge); + IF kurze feldlaenge <= 0 THEN bis := min (bis, kurze bildlaenge) FI; + IF von > bis THEN LEAVE bild ausgeben FI; + verschoben := 0; + IF markiert + THEN IF mark lineno (file) < bildanfang + von - 1 + THEN marke := anfang + ELSE marke := 0 + FI + FI ; + abschnitt loeschen und neuschreiben; + to line (file, act lineno); + laenge := save laenge; + verschoben := save verschoben; + marke := save marke . + +markiert : mark lineno (file) > 0 . + +abschnitt loeschen und neuschreiben : + abschnitt loeschen; + INT VAR line number := bildanfang + von - 1; + to line (file, line number); + abschnitt schreiben . + +abschnitt loeschen : + cursor (rand + 1, bildrand + von); + IF bildrest darf komplett geloescht werden + THEN out (clear eop) + ELSE zeilenweise loeschen + FI . + +bildrest darf komplett geloescht werden : + bis = maxlaenge AND kurze bildlaenge = maxlaenge + AND kurze feldlaenge = maxbreite . + +zeilenweise loeschen : + INT VAR i; + FOR i FROM von UPTO bis REP + check for interrupt; + feldlaenge einstellen; + feldrest loeschen; + IF i < bis THEN out (down char) FI + PER . + +feldlaenge einstellen : + IF ganze zeile sichtbar + THEN laenge := feldlaenge + ELSE laenge := kurze feldlaenge + FI . + +ganze zeile sichtbar : i <= kurze bildlaenge . + +abschnitt schreiben : + INT CONST last line := lines (file); + FOR i FROM von UPTO bis + WHILE line number <= last line REP + check for interrupt; + feldlaenge einstellen; + zeile schreiben; + down (file); + line number INCR 1 + PER . + +check for interrupt : + kommando CAT inchety; + IF kommando <> "" + THEN IF zeilen nr = 1 CAND up command CAND vorgaenger erlaubt + THEN LEAVE abschnitt loeschen und neuschreiben + ELIF zeilen nr = bildlaenge CAND down command CAND nicht letzter satz + THEN LEAVE abschnitt loeschen und neuschreiben + FI + FI . + +vorgaenger erlaubt : + satznr > max (1, bildmarke) . + +up command : next incharety is (""3"") COR next incharety is (""1""3"") . + +down command : + next incharety is (""10"") CAND bildlaenge < maxlaenge + COR next incharety is (""1""10"") . + +nicht letzter satz : act lineno < lines (file) . + +zeile schreiben : + zeile := bildrand + i; + IF schreiben ist ganz einfach + THEN exec (PROC (TEXT CONST, INT CONST) simple feldout, file, 0) + ELSE zeile kompliziert schreiben + FI ; + IF line number = old lineno THEN old line update := FALSE FI . + +zeile kompliziert schreiben : + IF line number = mark lineno (file) THEN marke := mark col (file) FI; + IF line number = act lineno + THEN verschoben := save verschoben; + exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle); + verschoben := 0; marke := 0 + ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, 0); + IF line number = mark lineno (file) THEN marke := anfang FI + FI . +END PROC bild ausgeben; + +PROC bild zeigen : (* wk *) + + dateizustand holen ; + ueberschrift zeigen ; + bildausgabe steuern ; + bild neu ; + fenster zeigen ; + oldline no := satznr ; + old line update := FALSE ; + old satz := "" ; + old zeilennr := satznr - bildanfang + 1 ; + dateizustand retten . + +ENDPROC bild zeigen ; + +PROC ueberschrift initialisieren : (*sh*) + satznr pre := + cursor pos + code (bildrand - 1) + code (rand + feldlaenge - 6); + ueberschrift pre := + cursor pos + code (bildrand - 1) + code (rand) + mark anf; + ueberschrift text := ""; INT VAR i; + FOR i FROM 16 UPTO feldlaenge REP ueberschrift text CAT "." PER; + ueberschrift post := blank + mark end + "Zeile " + mark anf; + ueberschrift post CAT blank + mark end + " "; + filename := headline (file); + filename := subtext (filename, 1, feldlaenge - 24); + insert char (filename, blank, 1); filename CAT blank; + replace (ueberschrift text, filenamepos, filename); + rubin segment in ueberschrift eintragen; + margin segment in ueberschrift eintragen; + rest segment in ueberschrift eintragen; + learn segment in ueberschrift eintragen . + +filenamepos : (LENGTH ueberschrift text - LENGTH filename + 3) DIV 2 . +mark anf : begin mark + mark ausgleich. +mark end : end mark + mark ausgleich. +mark ausgleich : (1 - sign (max (mark size, 0))) * blank . + +rubin segment in ueberschrift eintragen : + replace (ueberschrift text, 9, rubin segment) . + +rubin segment : + IF einfuegen THEN "RUBIN" ELSE "....." FI . + +margin segment in ueberschrift eintragen : + replace (ueberschrift text, 2, margin segment) . + +margin segment : + IF anfang <= 1 + THEN "......" + ELSE TEXT VAR margin text := "M" + text (anfang); + (6 - LENGTH margin text) * "." + margin text + FI . + +rest segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 25, rest segment) . + +rest segment : + IF zeileneinfuegen THEN "REST" ELSE "...." FI . + +learn segment in ueberschrift eintragen : + replace (ueberschrift text, feldlaenge - 19, learn segment) . + +learn segment : + IF lernmodus THEN "LEARN" ELSE "....." FI . + +END PROC ueberschrift initialisieren; + +PROC ueberschrift schreiben : + replace (ueberschrift post, satznr pos, text (text (lineno (file)), 4)); + out (ueberschrift pre); out (ueberschrift text); out (ueberschrift post); + get tabs (file, tab); + IF pos (tab, dach) > 0 + THEN out (ueberschrift pre); + out subtext (tab, anfang + 1, anfang + feldlaenge - 1); + cursor (rand + 1 + feldlaenge, bildrand); out (end mark) + FI . + + satznr pos : IF mark size > 0 THEN 9 ELSE 10 FI . (*sh*) +END PROC ueberschrift schreiben; + +PROC fehlermeldung schreiben : + ueberschrift schreiben; + out (ueberschrift pre); + out ("FEHLER: "); + out subtext (fehlertext, 1, feldlaenge - 21); + out (blank); + out (piep); + cursor (rand + 1 + feldlaenge, bildrand); out (end mark) +END PROC fehlermeldung schreiben; + +PROC set busy indicator : + cursor (rand + 2, bildrand) +END PROC set busy indicator; + +PROC kommando analysieren (TEXT CONST taste, + PROC (TEXT CONST) kommando interpreter) : + disable stop; + bildausgabe normieren; + zustand in datei sichern; + editfile modus setzen; + kommando interpreter (taste); + editfile modus zuruecksetzen; + IF actual editor <= 0 THEN LEAVE kommando analysieren FI; + absatz ausgleich := 2; (*sh*) + konstanten neu berechnen; + neues bild bei undefinierter benutzeraktion; + evtl fehler behandeln; + zustand aus datei holen; + bildausgabe steuern . + +editfile modus setzen : + BOOL VAR alter editget modus := editget modus ; + editget modus := FALSE . + +editfile modus zuruecksetzen : + editget modus := alter editget modus . + +evtl fehler behandeln : + IF is error + THEN fehlertext := errormessage; + IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI; + clear error + ELSE fehlertext := "" + FI . + +zustand in datei sichern : + old zeilennr := zeilennr; + old mark lineno := bildmarke; + dateizustand retten . + +zustand aus datei holen : + dateizustand holen; + IF letzer editor auf dieser datei <> actual editor + THEN zurueck auf alte position; neu (ueberschrift, bild) + FI . + +zurueck auf alte position : + to line (file, old lineno); + col (file, alte stelle); + IF fliesstext + THEN editinfo (file, old zeilennr) + ELSE editinfo (file, - old zeilennr) + FI ; dateizustand holen . + +bildausgabe normieren : + bildbereich := undefinierter bereich; + erster neusatz := 9999; + letzter neusatz := 0 . + +neues bild bei undefinierter benutzeraktion : + IF bildbereich = undefinierter bereich THEN alles neu FI . +END PROC kommando analysieren; + +PROC bildausgabe steuern : + IF markiert + THEN IF old mark lineno = 0 + THEN abschnitt neu (bildmarke, satznr); + konstanten neu berechnen + ELIF stelle veraendert (*sh*) + THEN zeile neu + FI + ELIF old mark lineno > 0 + THEN abschnitt neu (old mark lineno, (max (satznr, old lineno))); + konstanten neu berechnen + FI ; + IF satznr <> old lineno + THEN neu (akt satznr, nix); + neuen bildaufbau bestimmen + ELSE zeilennr := old zeilennr + FI ; + zeilennr := min (min (zeilennr, satznr), aktuelle bildlaenge); + bildanfang := satznr - zeilennr + 1 . + +stelle veraendert : stelle <> alte stelle . + +neuen bildaufbau bestimmen : + zeilennr := old zeilennr + satznr - old lineno; + IF 1 <= zeilennr AND zeilennr <= aktuelle bildlaenge + THEN im fenster springen + ELSE bild neu aufbauen + FI . + +im fenster springen : + IF markiert THEN abschnitt neu (old lineno, satznr) FI . + +bild neu aufbauen : + neu (nix, bild); zeilennr := max (1, aktuelle bildlaenge DIV 2) . +END PROC bildausgabe steuern; + +PROC word wrap (BOOL CONST b) : + IF actual editor = 0 + THEN std fliesstext := b + ELSE fliesstext in datei setzen + FI . + +fliesstext in datei setzen : + fliesstext := b; + IF fliesstext veraendert THEN editinfo (file, - editinfo (file)) FI; + neu (ueberschrift, bild) . + +fliesstext veraendert : + fliesstext AND editinfo (file) < 0 OR + NOT fliesstext AND editinfo (file) > 0 . +END PROC word wrap; + +BOOL PROC word wrap : (*sh*) + IF actual editor = 0 + THEN std fliesstext + ELSE fliesstext + FI +END PROC word wrap; + +INT PROC margin : anfang END PROC margin; + +PROC margin (INT CONST i) : (*sh*) + IF anfang <> i CAND i > 0 AND i < 16001 + THEN anfang := i; neu (ueberschrift, bild); + margin segment in ueberschrift eintragen + ELSE IF i >= 16001 OR i < 0 + THEN errorstop ("ungueltige Anfangsposition (1 - 16000)") + FI + FI . + +margin segment in ueberschrift eintragen : + replace (ueberschrift text, 2, margin segment) . + +margin segment : + IF anfang <= 1 + THEN "......" + ELSE TEXT VAR margin text := "M" + text (anfang); + (6 - LENGTH margin text) * "." + margin text + FI . + +END PROC margin; + +BOOL PROC rubin mode : rubin mode (actual editor) END PROC rubin mode; + +BOOL PROC rubin mode (INT CONST editor nr) : (*sh*) + IF editor nr < 1 OR editor nr > max used editor + THEN errorstop ("Editor nicht eroeffnet") + FI ; + IF editor nr = actual editor + THEN einfuegen + ELSE editstack (editor nr).feldstatus.einfuegen + FI +END PROC rubin mode; + +PROC edit (INT CONST i, TEXT CONST res, + PROC (TEXT CONST) kommando interpreter) : + edit (i, i, i, res, PROC (TEXT CONST) kommando interpreter) +END PROC edit; + +PROC edit (INT CONST von, bis, start, TEXT CONST res, + PROC (TEXT CONST) kommando interpreter) : + disable stop; + IF von < bis + THEN edit (von+1, bis, start, res, PROC (TEXT CONST) kommando interpreter); + IF max used editor < von THEN LEAVE edit FI; + open editor (von) + ELSE open editor (start) + FI ; + absatz ausgleich := 2; + bildeditor (res, PROC (TEXT CONST) kommando interpreter); + cursor (1, schirmhoehe); + IF is error + THEN kommando zeiger := 1; kommando := ""; quit + FI ; + IF lernmodus CAND actual editor = 0 THEN warnung ausgeben FI . (*sh*) + + warnung ausgeben : + out (clear eop); out ("WARNUNG: Lernmodus nicht ausgeschaltet"13""10"") . +END PROC edit; + +PROC dateizustand holen : + modify (file); + get tabs (file, tabulator); + zeilennr und fliesstext und letzter editor aus editinfo decodieren; + limit := max line length (file); + stelle := col (file); + markiert := mark (file); + IF markiert + THEN markierung holen + ELSE keine markierung + FI ; + satz nr := lineno (file); + IF zeilennr > aktuelle bildlaenge (*sh*) + THEN zeilennr := min (satznr, aktuelle bildlaenge); bild neu + ELIF zeilennr > satznr + THEN zeilennr := min (satznr, aktuelle bildlaenge) + FI ; zeilennr := max (zeilennr, 1); + bildanfang := satz nr - zeilennr + 1 . + +zeilennr und fliesstext und letzter editor aus editinfo decodieren : + zeilennr := edit info (file); + IF zeilennr = 0 + THEN zeilennr := 1; + fliesstext := std fliesstext + ELIF zeilennr > 0 + THEN fliesstext := TRUE + ELSE zeilennr := - zeilennr; + fliesstext := FALSE + FI ; + letzer editor auf dieser datei := zeilennr DIV 256; + zeilennr := zeilennr MOD 256 . + +markierung holen : + bildmarke := mark lineno (file); + feldmarke := mark col (file); + IF line no (file) <= bildmarke + THEN to line (file, bildmarke); + marke := feldmarke; + stelle := max (stelle, feldmarke) + ELSE marke := 1 + FI . + +keine markierung : + bildmarke := 0; + feldmarke := 0; + marke := 0 . +END PROC dateizustand holen; + +PROC dateizustand retten : + put tabs (file, tabulator); + IF fliesstext + THEN editinfo (file, zeilennr + actual editor * 256) + ELSE editinfo (file, - (zeilennr + actual editor * 256)) + FI ; + max line length (file, limit); + col (file, stelle); + IF markiert + THEN mark (file, bildmarke, feldmarke) + ELSE mark (file, 0, 0) + FI +END PROC dateizustand retten; + +PROC open editor (FILE CONST new file, BOOL CONST access) : + disable stop; quit last; + neue bildparameter bestimmen; + open editor (actual editor + 1, new file, access, x, y, x len, y len). + +neue bildparameter bestimmen : + INT VAR x, y, x len, y len; + IF actual editor > 0 + THEN teilbild des aktuellen editors + ELSE volles bild + FI . + +teilbild des aktuellen editors : + get editcursor (x, y); bildgroesse bestimmen; + IF fenster zu schmal (*sh*) + THEN enable stop; errorstop ("Fenster zu klein") + ELIF fenster zu kurz + THEN verkuerztes altes bild nehmen + FI . + +bildgroesse bestimmen : + x len := rand + feldlaenge - x + 3; + y len := bildrand + bildlaenge - y + 1 . + +fenster zu schmal : x > schirmbreite - 17 . +fenster zu kurz : y > schirmhoehe - 1 . + +verkuerztes altes bild nehmen : + x := rand + 1; y := bildrand + 1; + IF fenster zu kurz THEN enable stop; errorstop ("Fenster zu klein") FI; + x len := feldlaenge + 2; + y len := bildlaenge; + kurze feldlaenge := 0; + kurze bildlaenge := 1 . + +volles bild : + x := 1; y := 1; x len := schirmbreite; y len := schirmhoehe . +END PROC open editor; + +PROC open editor (INT CONST editor nr, + FILE CONST new file, BOOL CONST access, + INT CONST x start, y, x len start, y len) : + INT VAR x := x start, + x len := x len start; + IF editor nr > max editor + THEN errorstop ("zu viele Editor-Fenster") + ELIF editor nr > max used editor + 1 OR editor nr < 1 + THEN errorstop ("Editor nicht eroeffnet") + ELIF fenster ungueltig + THEN errorstop ("Fenster ungueltig") + ELSE neuen editor stacken + FI . + +fenster ungueltig : + x < 1 COR x > schirmbreite COR y < 1 COR y > schirmhoehe COR + x len - 2 <= 15 COR y len - 1 < 1 COR + x + x len - 1 > schirmbreite COR y + y len - 1 > schirmhoehe . + +neuen editor stacken : + disable stop; + IF actual editor > 0 AND ist einschraenkung des alten bildes + THEN dateizustand holen; + aktuelles editorbild einschraenken; + arbeitspunkt in das restbild positionieren; + abgrenzung beruecksichtigen + FI ; + aktuellen zustand retten; + neuen zustand setzen; + neues editorbild zeigen; + actual editor := editor nr; + IF actual editor > max used editor + THEN max used editor := actual editor + FI . + +ist einschraenkung des alten bildes : + x > rand CAND x + x len = rand + feldlaenge + 3 CAND + y > bildrand CAND y + y len = bildrand + bildlaenge + 1 . + +aktuelles editorbild einschraenken : + kurze feldlaenge := x - rand - 3; + kurze bildlaenge := y - bildrand - 1 . + +arbeitspunkt in das restbild positionieren : + IF stelle > 3 + THEN stelle DECR 3; alte stelle := stelle + ELSE WHILE zeilennr > 1 AND zeilennr > kurze bildlaenge REP + vorgaenger + PER; old lineno := satznr + FI . + +abgrenzung beruecksichtigen : + IF x - rand > 1 + THEN balken malen; + x INCR 2; + x len DECR 2 + FI . + +balken malen : + INT VAR i; + FOR i FROM 0 UPTO y len-1 REP + cursor (x, y+i); out (kloetzchen) (*sh*) + PER . + +kloetzchen : IF mark size > 0 THEN ""15""14"" ELSE ""15" "14" " FI . + +aktuellen zustand retten : + IF actual editor > 0 + THEN dateizustand retten; + editstack (actual editor).feldstatus := feldstatus; + editstack (actual editor).bildstatus := bildstatus; + einrueckstack (actual editor) := alte einrueckposition + FI . + +neuen zustand setzen : + FRANGE VAR frange; + feldstatus := FELDSTATUS : + (1, 1, x-1, 0, 1, 0, x len-2, 0, FALSE, TRUE, access, ""); + bildstatus := BILDSTATUS : + (x len-2, x len-2, y, y len-1, y len-1, ueberschrift, bild, + 0, 0, 1, 0, 0, FALSE, FALSE, "", "", "", "", "", frange, new file); + alte einrueckposition := 1; + dateizustand holen; + ueberschrift initialisieren . + +neues editorbild zeigen : + ueberschrift zeigen; fenster zeigen +END PROC open editor; + +PROC open editor (INT CONST i) : + IF i < 1 OR i > max used editor + THEN errorstop ("Editor nicht eroeffnet") + ELIF actual editor <> i + THEN switch editor + FI . + +switch editor : + aktuellen zustand retten; + actual editor := i; + neuen zustand setzen; + IF kein platz mehr fuer restfenster + THEN eingeschachtelte editoren vergessen; + bildeinschraenkung aufheben + ELSE neu (nix, nix) + FI . + +aktuellen zustand retten : + IF actual editor > 0 + THEN editstack (actual editor).feldstatus := feldstatus; + editstack (actual editor).bildstatus := bildstatus; + einrueckstack (actual editor) := alte einrueckposition; + dateizustand retten + FI . + +neuen zustand setzen : + feldstatus := editstack (i).feldstatus; + bildstatus := editstack (i).bildstatus; + alte einrueckposition := einrueckstack (i); + dateizustand holen . + +kein platz mehr fuer restfenster : + kurze feldlaenge < 1 AND kurze bildlaenge < 1 . + +eingeschachtelte editoren vergessen : + IF actual editor < max used editor + THEN open editor (actual editor + 1) ; + quit + FI ; + open editor (i) . + +bildeinschraenkung aufheben : + laenge := feldlaenge; + kurze feldlaenge := feldlaenge; + kurze bildlaenge := bildlaenge; + neu (ueberschrift, bild) . +END PROC open editor; + +FILE PROC editfile : + IF actual editor = 0 OR editget modus + THEN errorstop ("Editor nicht eroeffnet") + FI ; file +END PROC editfile; + +PROC get window (INT VAR x, y, x size, y size) : + x := rand + 1; + y := bildrand; + x size := feldlaenge + 2; + y size := bildlaenge + 1 +ENDPROC get window; + +(************************* Zugriff auf Bildstatus *************************). + +feldlaenge : bildstatus.feldlaenge . +kurze feldlaenge : bildstatus.kurze feldlaenge . +bildrand : bildstatus.bildrand . +bildlaenge : bildstatus.bildlaenge . +kurze bildlaenge : bildstatus.kurze bildlaenge . +ueberschriftbereich : bildstatus.ueberschriftbereich . +bildbereich : bildstatus.bildbereich . +erster neusatz : bildstatus.erster neusatz . +letzter neusatz : bildstatus.letzter neusatz . +old zeilennr : bildstatus.old zeilennr . +old lineno : bildstatus.old lineno . +old mark lineno : bildstatus.old mark lineno . +zeileneinfuegen : bildstatus.zeileneinfuegen . +old line update : bildstatus.old line update . +satznr pre : bildstatus.satznr pre . +ueberschrift pre : bildstatus.ueberschrift pre . +ueberschrift text : bildstatus.ueberschrift text . +ueberschrift post : bildstatus.ueberschrift post . +old satz : bildstatus.old satz . +old range : bildstatus.old range . +file : bildstatus.file . + +END PACKET editor paket; + diff --git a/system/base/1.7.5/src/elan do interface b/system/base/1.7.5/src/elan do interface new file mode 100644 index 0000000..72026a7 --- /dev/null +++ b/system/base/1.7.5/src/elan do interface @@ -0,0 +1,57 @@ + +PACKET elan do interface DEFINES (*Autor: J.Liedtke *) + (*Stand: 08.11.85 *) + do , + no do again : + + +LET no ins = FALSE , + no lst = FALSE , + no check = FALSE , + no sermon = FALSE , + compile line mode = 2 , + do again mode = 4 , + max command length = 2000 ; + + +INT VAR do again mod nr := 0 ; +TEXT VAR previous command := "" ; + +DATASPACE VAR ds ; + + +PROC do (TEXT CONST command) : + + enable stop ; + IF LENGTH command > max command length + THEN errorstop ("Kommando zu lang") + ELIF do again mod nr <> 0 AND command = previous command + THEN do again + ELSE previous command := command ; + compile and execute + FI . + +do again : + elan (do again mode, ds, "", do again mod nr, + no ins, no lst, no check, no sermon) . + +compile and execute : + elan (compile line mode, ds, command, do again mod nr, + no ins, no lst, no check, no sermon) . + +ENDPROC do ; + +PROC no do again : + + do again mod nr := 0 + +ENDPROC no do again ; + +PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line, + INT VAR start module number, + BOOL CONST ins, lst, rt check, ser) : + EXTERNAL 256 +ENDPROC elan ; + +ENDPACKET elan do interface ; + diff --git a/system/base/1.7.5/src/error handling b/system/base/1.7.5/src/error handling new file mode 100644 index 0000000..34db65d --- /dev/null +++ b/system/base/1.7.5/src/error handling @@ -0,0 +1,142 @@ + +PACKET error handling DEFINES + + enable stop , + disable stop , + is error , + clear error , + errormessage , + error code , + error line , + put error , + errorstop , + stop : + + +LET cr lf = ""13""10"" , + line nr field = 1 , + error line field = 2 , + error code field = 3 , + syntax error code= 100 , + + error pre = ""7""13""10""5"FEHLER : " ; + + +TEXT VAR errortext := "" ; + + +PROC enable stop : + EXTERNAL 75 +ENDPROC enable stop ; + +PROC disable stop : + EXTERNAL 76 +ENDPROC disable stop ; + +PROC set error stop (INT CONST code) : + EXTERNAL 77 +ENDPROC set error stop ; + +BOOL PROC is error : + EXTERNAL 78 +ENDPROC is error ; + +PROC clear error : + EXTERNAL 79 +ENDPROC clear error ; + +PROC select error message : + + SELECT error code OF + CASE 1 : error text := "'halt' vom Terminal" + CASE 2 : error text := "Stack-Ueberlauf" + CASE 3 : error text := "Heap-Ueberlauf" + CASE 4 : error text := "INT-Ueberlauf" + CASE 5 : error text := "DIV durch 0" + CASE 6 : error text := "REAL-Ueberlauf" + CASE 7 : error text := "TEXT-Ueberlauf" + CASE 8 : error text := "zu viele DATASPACEs" + CASE 9 : error text := "Ueberlauf bei Subskription" + CASE 10: error text := "Unterlauf bei Subskription" + CASE 11: error text := "falscher DATASPACE-Zugriff" + CASE 12: error text := "INT nicht initialisiert" + CASE 13: error text := "REAL nicht initialisiert" + CASE 14: error text := "TEXT nicht initialisiert" + CASE 15: error text := "nicht implementiert" + CASE 16: error text := "Block unlesbar" + CASE 17: error text := "Codefehler" + END SELECT + +ENDPROC select error message ; + +TEXT PROC error message : + + select error message ; + error text + +ENDPROC error message ; + +INT PROC error code : + + pcb (error code field) + +ENDPROC error code ; + +INT PROC error line : + + IF is error + THEN pcb (error line field) + ELSE 0 + FI + +ENDPROC error line ; + +PROC syntax error (TEXT CONST message) : + + INTERNAL 259 ; + errorstop (syntax error code, message) . + +ENDPROC syntax error ; + +PROC errorstop (TEXT CONST message) : + + errorstop (0, message) ; + +ENDPROC errorstop ; + +PROC errorstop (INT CONST code, TEXT CONST message) : + + IF NOT is error + THEN error text := message ; + set error stop (code) + FI + +ENDPROC errorstop ; + +PROC put error : + + IF is error + THEN select error message ; + IF error text <> "" + THEN put error message + FI + FI . + +put error message : + out (error pre) ; + out (error text) ; + IF error line > 0 + THEN out (" bei Zeile "); out (text (error line)) ; + FI ; + out (cr lf) . + +ENDPROC put error ; + +PROC stop : + + errorstop ("stop") + +ENDPROC stop ; + +ENDPACKET error handling ; + diff --git a/system/base/1.7.5/src/eumel coder part 1 b/system/base/1.7.5/src/eumel coder part 1 new file mode 100644 index 0000000..83974f7 --- /dev/null +++ b/system/base/1.7.5/src/eumel coder part 1 @@ -0,0 +1,866 @@ +PACKET eumel coder part 1 (* Autor: U. Bartling *) + DEFINES run, run again, + insert, + prot, prot off, + check, check on, check off, + warnings, warnings on, warnings off, + + help, bulletin, packets + : + +(**************************************************************************) +(* *) +(* E U M E L - C O D E R *) +(* *) +(* *) +(* Zur Beschreibung des Coders siehe *) +(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *) +(* *) +(* Stand der Dokumentation : 13.02.1986 *) +(* Stand der Implementation : 16.04.1986 *) +(* *) +(* *) +(**************************************************************************) + + + (***** Globale Variable *****) + +TEXT VAR object name; + +FILE VAR bulletin file; + +INT VAR hash table pointer, nt link, permanent pointer, param link, + index, mode, word; + +BOOL VAR found, end of params; + +#page# +(**************************************************************************) +(* *) +(* 1. Interface zum ELAN-Compiler 10.04.1986 *) +(* 1.7.5.4 *) +(* *) +(* Beschreibung der Tabellen (-groessen), *) +(* internen Vercodung von Typen *) +(* und Kennungen . *) +(* Initialisieren und Beenden des Compilers, *) +(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *) +(* *) +(**************************************************************************) + + +LET begin of hash table = 0 , + end of hash table = 1023 , + + begin of permanent table = 22784 , + before first pt entry = 22784 , + first permanent entry = 22785 , + end of permanent table = 32767 , + + wordlength = 1 , (* compile u n d run time *) + two word length = 2 , + three word length = 3 , + + permanent param const = 10000 , + permanent param var = 20000 , + permanent proc op = 30000 , + permanent type = 30000 , + permanent row = 10 , + permanent struct = 11 , + permanent param proc = 12 , +(* permanent param proc end marker = 0 , *) + permanent type field = 0 , + + ptt limit = 10000 , + begin of pt minus ptt limit = 12784 , + + void = 0 , + int = 1 , + real = 2 , + string = 3 , + bool = 5 , + bool result = 6 , + dataspace = 7 , + row = 10 , + struct = 11 , + + const = 1 , + var = 2 , +(* proc = 3 , *) +(* denoter = 5 , *) + bold = 2 , + + ins = TRUE , + no ins = FALSE , + no lst = FALSE , + sermon = TRUE , + no sermon = FALSE , + + run again mode = 0 , + compile file mode = 1 , + + warning message = 2 , + error message = 4 , + + point line = "..............." ; + +INT CONST permanent packet := -2 , + permanent end := -3 ; + + +INT VAR run again mod nr := 0 ; + + + (***** Start/Ende *****) + +PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line, + INT VAR start module number, BOOL CONST ins, lst, rtc, ser) : + EXTERNAL 256 +ENDPROC elan ; + + (***** Hash/Namenstabelle *****) +. +next hash entry : + hash table pointer INCR wordlength . + +end of hash table reached : + hash table pointer > end of hash table . + +yet another nt entry : + nt link := cdb int (nt link) ; + nt link <> 0 . ; + +PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) : + EXTERNAL 10031 +ENDPROC declare object ; + +PROC to object (TEXT CONST searched object) : + hash ; + search nt entry . + +hash : + hash code := 0 ; + FOR index FROM 1 UPTO LENGTH searched object REP + addmult cyclic + ENDREP . + +addmult cyclic : + hash code INCR hash code ; + IF hash code > end of hash table THEN wrap around FI ; + hash code := (hash code + code (searched object SUB index)) MOD 1024 . + +wrap around : + hash code DECR end of hash table . + +hash code : nt link . + +search nt entry : + found := FALSE ; + WHILE yet another nt entry REP + read current entry ; + IF object name = searched object + THEN found := TRUE ; + LEAVE to object + FI + PER . + +read current entry : + permanent pointer := cdb int (nt link + wordlength) ; + object name := cdb text (nt link + two word length) +ENDPROC to object ; + + + (***** Permanent Tabelle *****) +. +next procedure : + permanent pointer := cdb int (permanent pointer) . ; + +PROC next pt param : + mode := cdb int (param link) MOD ptt limit ; + param link INCR wordlength ; + IF mode = permanent row THEN skip over permanent row + ELIF mode = permanent struct THEN skip over permanent struct + FI ; + set end marker if end of list . + +skip over permanent row : + param link INCR wordlength ; + next pt param . + +skip over permanent struct : + REP + next pt param ; + mode := cdb int (param link) + UNTIL mode = permanent type field PER ; + param link INCR wordlength +ENDPROC next pt param ; + +PROC set end marker if end of list : + mode := cdb int (param link) ; + end of params := mode >= permanent proc op OR mode <= 0 +ENDPROC set end marker if end of list ; + +PROC get type and mode (INT VAR type) : + mode := cdb int (param link) ; + IF mode = permanent param proc THEN type of param proc + ELSE type of object + FI . + +type of param proc : + param link INCR wordlength ; + get type and mode (type) ; + mode := permanent param proc . + +type of object : + IF mode < 0 THEN type := 2769 + (32767 + mode) ; + mode := 0 + ELSE type := mode MOD ptt limit ; + mode DECR type ; + translate type if necessary ; + translate mode if necessary + FI . + +translate type if necessary : + IF permanent row or struct THEN translate type FI . + +translate type : + type := param link - begin of pt minus ptt limit . + +translate mode if necessary : + IF mode = permanent param const THEN mode := const + ELIF mode = permanent param var THEN mode := var + FI . + +permanent row or struct : + type = permanent row OR type = permanent struct +ENDPROC get type and mode ; + + + (***** Allgemeine Zugriffsprozeduren *****) + +INT PROC cdb int (INT CONST index) : + EXTERNAL 116 +ENDPROC cdb int ; + +TEXT PROC cdb text (INT CONST index) : + EXTERNAL 117 +ENDPROC cdb text ; + +#page# +(**************************************************************************) +(* *) +(* 10. Inspector 16.04.1986 *) +(* *) +(**************************************************************************) + + + +INT VAR line number, pattern length, packet link, + begin of packet, last packet entry, indentation; + +TEXT VAR bulletin name, type and mode, pattern, buffer; + +DATASPACE VAR bulletin ds :: nilspace ; + +.packet name : + cdb text (cdb int(packet link + wordlength) + two word length) . + +.within editor : + aktueller editor > 0 . ; + +PROC name of type (INT CONST type) : + SELECT type OF + CASE void : + CASE int : type and mode CAT "INT" + CASE real : type and mode CAT "REAL" + CASE string : type and mode CAT "TEXT" + CASE bool, bool result : type and mode CAT "BOOL" + CASE dataspace : type and mode CAT "DATASPACE" + CASE row : type and mode CAT "ROW " + CASE struct : type and mode CAT "STRUCT" + OTHERWISE : complex type + ENDSELECT . + +complex type : + IF type > ptt limit THEN perhaps permanent struct or row + ELSE get complex type + FI . + +perhaps permanent struct or row : + index := type + begin of pt minus ptt limit ; + mode := cdb int (index) MOD ptt limit ; + IF mode = permanent row THEN get permanent row + ELIF mode = permanent struct THEN get permanent struct + ELSE type and mode CAT "-" + FI . + +get complex type : + index := type + begin of permanent table ; + IF is complex type THEN get name + ELSE type and mode CAT "-" + FI . + +is complex type : + permanent type definition mode = permanent type . + +get name : + type and mode CAT cdb text (link to type name + two word length) . + +link to type name : + cdb int (index + three word length) . + +permanent type definition mode : + cdb int (index + wordlength) . + +get permanent row : + INT VAR t; + type and mode CAT "ROW " ; + type and mode CAT text (cdb int (index + wordlength)) ; + type and mode CAT " " ; + param link := index + two wordlength ; + get type and mode (t) ; + name of type (t) . + +get permanent struct : + type and mode CAT "STRUCT ( ... )" +ENDPROC name of type ; + +PROC help (TEXT CONST proc name) : + prep bulletin ; + prep help ; + scan (object name) ; + next symbol (pattern) ; + packet link := end of permanent table ; + IF function = 0 THEN standard help + ELSE asterisk help + FI . + +prep help : + object name := compress (proc name) ; + INT VAR function :: 0 ; + INT CONST l :: LENGTH object name ; + IF l > 1 AND object name <> "**" + THEN IF (object name SUB l) = "*" + THEN function INCR 2 ; + delete char (object name, l) + FI ; + IF (object name SUB 1) = "*" + THEN function INCR 1 ; + delete char (object name, 1) + FI ; + IF another asterisk THEN wrong function FI + FI. + +another asterisk : + pos (object name, "*") <> 0 . + +wrong function : + errorstop ("unzulaessige Sternfunktion") . + +standard help : + to object (pattern) ; + IF found THEN display + ELSE error stop ("unbekannt: " + proc name) + FI . + +display : + WHILE permanent pointer <> 0 REP + put name of packet if necessary ; + put specifications (pattern) ; + next procedure + ENDREP ; + show bulletin file . + +put name of packet if necessary : + IF new packet THEN packet link := permanent pointer ; + find begin of packet ; + writeline (2) ; + write packet name + FI . + +find begin of packet : + REP + packet link DECR wordlength + UNTIL begin of packet found PER . + +begin of packet found : + cdb int (packet link) = permanent packet . + +new packet : + permanent pointer < packet link . + +asterisk help : + hash table pointer := begin of hash table ; + pattern length := LENGTH pattern - 1 ; + REP + list all objects in current hash table chain ; + next hash entry + UNTIL end of hash table reached ENDREP ; + show bulletin file . + +list all objects in current hash table chain : + nt link := hash table pointer ; + WHILE yet another nt entry REP + permanent pointer := cdb int (nt link + wordlength) ; + object name := cdb text (nt link + two word length) ; + IF matching THEN into bulletin FI + PER . + +matching : + INT CONST p :: pos (object name, pattern) ; + SELECT function OF + CASE 1 : p <> 0 AND p = LENGTH object name - pattern length + CASE 2 : p = 1 + CASE 3 : p <> 0 + OTHERWISE FALSE + ENDSELECT . + +into bulletin : + object names into bulletin (BOOL PROC not end of chain) +ENDPROC help ; + +BOOL PROC not end of chain : + permanent pointer <> 0 +ENDPROC not end of chain ; + +PROC write packet name : + indentation := 0 ; + write line ; + write bulletin line ("PACKET ") ; + indentation := 7 ; + object name := packet name ; + write bulletin line (object name) ; + write bulletin line (":") ; + writeline (2) +ENDPROC write packet name ; + +PROC put specifications (TEXT CONST proc name) : + put obj name (proc name) ; + to first param ; + IF NOT end of params THEN put param list FI ; + put result ; + writeline . + +to first param : + param link := permanent pointer + word length ; + set end marker if end of list . + +put result : + INT VAR type; + get type and mode (type) ; + IF type <> void THEN type and mode := " --> " ; + name of type (type) ; + write bulletin line (type and mode) + FI +ENDPROC put specifications ; + +PROC put param list : + write bulletin line (" (") ; + REP + INT VAR type, param mode; + get type and mode (type) ; + param mode := mode ; + put type and mode ; + maybe param proc ; + next pt param ; + IF end of params THEN write bulletin line (")") ; + LEAVE put param list + FI ; + write bulletin line (", ") ; + PER . + +put type and mode : + type and mode := "" ; + name of type (type) ; + type and mode CAT name of mode ; + write bulletin line (type and mode) . + +name of mode : + IF param mode = const THEN " CONST" + ELIF param mode = var THEN " VAR" + ELSE " PROC" + FI . + +maybe param proc : + IF mode = permanent param proc THEN put virtual params FI . + +put virtual params : + skip over result type if complex type ; + IF NOT end of virtual params THEN put param list FI. + +skip over result type if complex type : + next pt param . + +end of virtual params : + end of params +ENDPROC put param list ; + +PROC next packet : + REP + packet link INCR wordlength ; + word := cdb int (packet link) ; + IF word = permanent packet THEN true return + ELIF end of permanents THEN false return + FI ; + ENDREP . + +true return : + found := TRUE ; + LEAVE next packet . + +false return : + found := FALSE ; + LEAVE next packet . + +end of permanents : + word = permanent end OR packet link > end of permanent table +ENDPROC next packet ; + +PROC prep bulletin : + forget (bulletin ds) ; + bulletin ds := nilspace ; + bulletin file := sequential file (output, bulletin ds) ; + line number := 0 ; + buffer := "" +ENDPROC prep bulletin ; + +PROC show bulletin file : + IF within editor THEN ueberschrift neu FI ; + DATASPACE VAR local ds :: bulletin ds ; + FILE VAR local file :: sequential file (modify, local ds) ; + show (local file) ; + forget (local ds) +ENDPROC show bulletin file ; + +PROC write bulletin line (TEXT CONST line) : + IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ; + buffer CAT line +ENDPROC write bulletin line ; + +PROC writeline : + write (bulletin file, buffer) ; + line (bulletin file) ; + line number INCR 1 ; + cout (line number) ; + buffer := indentation * " " +ENDPROC writeline ; + +PROC writeline (INT CONST times) : + IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ; + writeline + ELSE index := times + FI ; + line (bulletin file, index) ; + line number INCR index; + indentation := 0 ; + cout (line number) +ENDPROC writeline ; + +PROC bulletin (TEXT CONST packet name) : + prep bulletin ; + scan (packet name) ; + next symbol (pattern) ; + to packet ; + IF found THEN list packet ; + show bulletin file + ELSE error stop (packet name + " ist kein Paketname") + FI . + +to packet : + last packet entry := 0 ; + get nametab link of packet name ; + packet link := before first pt entry ; + REP + packet link INCR wordlength ; + word := cdb int (packet link) ; + IF word < 0 THEN IF word = permanent packet THEN packet found + ELIF word = permanent end THEN return + FI + FI + ENDREP . + +get nametab link of packet name : + to object (pattern) ; + IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ; + LEAVE to packet + FI . + +packet found : + IF cdb int (packet link + wordlength) = nt link + THEN last packet entry := packet link FI . + +return : + IF last packet entry <> 0 THEN found := TRUE ; + packet link := last packet entry + ELSE found := FALSE + FI ; + LEAVE to packet +ENDPROC bulletin ; + +PROC list packet : + begin of packet := packet link + word length ; + write packet name ; + find end of packet ; + run through nametab and list all packet objects . + +find end of packet : + last packet entry := begin of packet ; + REP + last packet entry INCR wordlength ; + word := cdb int (last packet entry) ; + UNTIL end of packet entries PER . + +end of packet entries : + word = permanent packet OR word = permanent end . + +run through nametab and list all packet objects : + hashtable pointer := begin of hashtable ; + REP + nt link := hashtable pointer ; + list objects of current packet in this chain ; + next hash entry + UNTIL end of hashtable reached ENDREP . + +list objects of current packet in this chain : + WHILE yet another nt entry REP + permanent pointer := cdb int (nt link + wordlength) ; + put objects of this name + PER . + +put objects of this name : + IF there is at least one object of this name in the current packet + THEN into bulletin FI . + +there is at least one object of this name in the current packet : + REP + IF permanent pointer >= begin of packet AND + permanent pointer < last packet entry + THEN LEAVE there is at least one object of this name + in the current packet WITH TRUE FI ; + next procedure + UNTIL permanent pointer = 0 PER ; + FALSE . + +into bulletin : + object name := cdb text (nt link + two word length) ; + object names into bulletin (BOOL PROC within packet) +ENDPROC list packet ; + +BOOL PROC within packet : + permanent pointer >= begin of packet AND + permanent pointer < last packet entry +ENDPROC within packet ; + +PROC object names into bulletin (BOOL PROC link ok) : + scan (object name) ; + next symbol (object name, mode) ; + IF type definition THEN put type definition + ELSE put object definitions + FI . + +type definition : + mode = bold AND no params . + +no params : + cdb int (permanent pointer + word length) >= permanent type . + +put type definition : + put obj name (object name) ; + write bulletin line ("TYPE ") ; + writeline (1) . + +put object definitions : + WHILE link ok REP + put specifications (object name) ; + next procedure + ENDREP +ENDPROC object names into bulletin ; + +PROC bulletin : + prep bulletin ; + packet link := first permanent entry ; + REP + list packet ; + write line (4) ; + next packet + UNTIL NOT found PER ; + show bulletin file +ENDPROC bulletin ; + +PROC put obj name (TEXT CONST name) : + buffer := " " ; + bulletin name := point line ; + change (bulletin name, 1, end of line or name, name) ; + buffer CAT bulletin name ; + indentation := LENGTH buffer + 1 . + +end of line or name : + min (LENGTH name, LENGTH bulletin name) +ENDPROC put obj name ; + +PROC packets : + prep bulletin ; + packet link := first permanent entry ; + REP + object name := packet name ; + put obj name (object name) ; + write line ; + next packet + UNTIL NOT found PER ; + show bulletin file +ENDPROC packets ; + +#page# +(**************************************************************************) +(* *) +(* 11. ELAN Run-Interface 09.01.1986 *) +(* *) +(* Uebersetzen von ELAN-Programmen *) +(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *) +(* *) +(**************************************************************************) + + + +BOOL VAR list option := FALSE , + check option := TRUE , + warning option := FALSE , + listing enabled := FALSE ; + +FILE VAR listing file ; + +TEXT VAR listing file name := "" ; + + +PROC run (TEXT CONST file name) : + enable stop ; + IF NOT exists (file name) + THEN errorstop ("""" + file name + """ gibt es nicht") + FI ; + last param (file name) ; + run elan (file name, no ins) +END PROC run; + +PROC run : + run (last param) +ENDPROC run ; + +PROC run again : + IF run again mod nr <> 0 + THEN elan (run again mode, bulletin file, "", run again mod nr, + no ins, no lst, check option, no sermon) + ELSE errorstop ("'run again' nicht moeglich") + FI +ENDPROC run again ; + +PROC insert (TEXT CONST file name) : + enable stop ; + IF NOT exists (file name) + THEN errorstop ("""" + file name + """ gibt es nicht") + FI ; + last param (file name) ; + run elan (file name, ins) +ENDPROC insert ; + +PROC insert : + insert (last param) +ENDPROC insert ; + +PROC run elan (TEXT CONST file name, BOOL CONST insert option) : + FILE VAR source := sequential file (modify, file name) ; + IF listing enabled + THEN open listing file + FI ; + + disable stop ; + no do again ; + elan (compile file mode, source, "" , run again mod nr, + insert option, list option, check option, sermon) ; + + IF anything noted AND command dialogue + THEN ignore halt during compiling ; + note edit (source) ; + last param (file name) ; + errorstop ("") + FI . + +ignore halt during compiling : + IF is error + THEN put error ; + clear error ; + pause (5) + FI . + +open listing file : + listing file := sequential file (output, listing file name) ; + max line length (listing file, 130) + +ENDPROC run elan ; + +PROC out text (TEXT CONST text, INT CONST out type) : + INTERNAL 257 ; + IF online + THEN out (text) + FI ; + IF out type = error message OR (warning option AND out type = warning message) + THEN note (text) ; + FI ; + IF listing enabled + THEN write (listing file, text) + FI +ENDPROC out text ; + +PROC out line (INT CONST out type) : + INTERNAL 258 ; + IF online + THEN out (""13""10"") + FI ; + IF out type = error message + OR (warning option AND out type = warning message) + THEN note line + ELIF listing enabled + THEN line (listing file) + FI +ENDPROC out line ; + +PROC prot (TEXT CONST file name) : + list option := TRUE ; + listing file name := file name ; + listing enabled := TRUE +ENDPROC prot ; + +PROC prot off : + list option := FALSE ; + listing enabled := FALSE +ENDPROC prot off ; + +BOOL PROC prot : + list option +ENDPROC prot ; + +PROC check on : + check option := TRUE +ENDPROC check on ; + +PROC check off : + check option := FALSE +ENDPROC check off ; + +BOOL PROC check : + check option +ENDPROC check ; + +PROC warnings on : + warning option := TRUE +ENDPROC warnings on ; + +PROC warnings off : + warning option := FALSE +ENDPROC warnings off ; + +BOOL PROC warnings : + warning option +ENDPROC warnings ; + +ENDPACKET eumel coder part 1 ; + diff --git a/system/base/1.7.5/src/file b/system/base/1.7.5/src/file new file mode 100644 index 0000000..530dcb3 --- /dev/null +++ b/system/base/1.7.5/src/file @@ -0,0 +1,2122 @@ +(* ------------------- VERSION 35 02.06.86 ------------------- *) +PACKET file handling DEFINES (* Autoren: J.Liedtke, D.Martinek *) + (***********) + + FILE, + :=, + sequential file, + reorganize, + input, + output, + modify, + close, + putline, + getline, + put, + get, + write , + line, + reset, + down, + up, + downety, + uppety, + pattern found, + to first record, + to line, + to eof, + insert record, + delete record, + read record, + write record, + is first record, + eof, + line no, + FRANGE, + set range, + reset range , + remove, + clear removed, + reinsert, + max line length, + edit info, + line type , + copy attributes , + headline, + put tabs, + get tabs, + col, + word, + at, + removed lines, + exec, + pos , + len , + subtext , + change , + lines , + segments , + mark , + mark line no , + mark col , + set marked range , + split line , + concatenate line , + prefix , + sort , + lexsort : + + +(**********************************************************************) +(* *) +(* Terminologie: *) +(* *) +(* *) +(* ATOMROW Menge aller Atome eines FILEs. *) +(* Die einzelnen Atome haben zwar eine Position *) +(* im Row, aber in dieser Betrachtung keine *) +(* logische Reihenfolge. *) +(* *) +(* ATOM Basiselement, kann eine Zeile der Datei und die *) +(* zugehoerige Verwaltungsinformation aufnehmen *) +(* *) +(* CHAIN Zyklisch geschlossene Kette von Segmenten. *) +(* *) +(* SEGMENT Teilbereich des Atomrows, enthaelt 1 oder mehr *) +(* zusammenhaengende Atoms. *) +(* Jedes Segment hat ein Vorgaenger- und ein *) +(* Nachfolgersegment. *) +(* Jedes Segment enthaelt einen logisch zumsammen- *) +(* haengenden Teile einer Sequence. *) +(* *) +(* SEQUENCE Logische Folge von Lines. *) +(* Jede Sequence ist Teil einer Chain oder besteht *) +(* vollstaendig daraus: *) +(* *) +(* SEG1--SEG2--SEG3--SEG4--SEG5 *) +(* :----sequence----: *) +(* *) +(* Die 'Reihenfolge' ebenso wie die 'Anzahl' der *) +(* Lines ist eine wesentliche Eigenschaft einer *) +(* Sequence. *) +(* *) +(* LINE Ein Atom als Element ein Sequence betrachtet. *) +(* *) +(* *) +(**********************************************************************) +(* *) +(* Eigenschaften: *) +(* *) +(* Folgende Mengen bilden eine Zerlegung (im math. Sinn) einer *) +(* gesamten Datei: *) +(* used segment chain *) +(* scratch segment chain *) +(* free segment chain *) +(* unused tail *) +(* *) +(* Fuer jedes X aus (used, scratch, free) gelten: *) +(* *) +(* 'X sequence' ist echte Teilmenge von 'X segment chain'. *) +(* *) +(* (Daraus folgt, es gibt keine leere 'chain'.) *) +(* *) +(* 'X segment chain' ist zyklisch gekettet. *) +(* *) +(* Alle Atome von 'X segment chain' haben definierten Inhalt. *) +(* *) +(**********************************************************************) + + +LET file size = 4075 , + nil = 0 , + + free root = 1 , + scratch root = 2 , + used root = 3 , + first unused = 4 ; + + +LET SEQUENCE = STRUCT (INT index, segment begin, segment end, + INT line no, lines), + SEGMENT = STRUCT (INT succ, pred, end), + ATOM = STRUCT (SEGMENT seg, INT type, TEXT line), + ATOMROW = ROW filesize ATOM, + + LIST = STRUCT (SEQUENCE used, INT prefix lines, postfix lines, + SEQUENCE scratch, free, INT unused tail, + INT mode, col, limit, edit info, mark line, mark col, + ATOMROW atoms); + +TYPE FILE = BOUND LIST ; + +TYPE FRANGE = STRUCT (INT pre, post, BOOL pre was split, post was split); + + +OP := (FRANGE VAR left, FRANGE CONST right): + CONCR (left) := CONCR (right) +ENDOP := ; + + +OP := (FILE VAR left, FILE CONST right): + EXTERNAL 260 +END OP :=; + + +PROC becomes (INT VAR a, b) : + INTERNAL 260 ; + a := b +END PROC becomes; + + +PROC initialize (FILE VAR f) : + + f.used := SEQUENCE : (used root, used root, used root, 1, 0); + f.prefix lines := 0; + f.postfix lines := 0; + f.free := SEQUENCE : (free root, free root, free root, 1, 0); + f.scratch := SEQUENCE : (scratch root, scratch root, scratch root, 1, 0); + f.unused tail := first unused; + + f.limit := 77; + f.edit info := 0; + f.col := 1 ; + f.mark line := 0 ; + f.mark col := 0 ; + + INT VAR i; + FOR i FROM 1 UPTO 3 REP + root (i).seg := SEGMENT : (i, i, i); + root (i).line := "" + PER; + put tabs (f, "") . + +root : f.atoms . + +END PROC initialize; + + +(**********************************************************************) +(* *) +(* Segment Handler (SEGMENTs & CHAINs) *) +(* *) +(**********************************************************************) + +INT PROC segs (SEQUENCE CONST s, ATOMROW CONST atom) : + + INT VAR number of segments := 0 , + actual segment := s.segment begin ; + REP + number of segments INCR 1 ; + actual segment := atom (actual segment).seg.succ + UNTIL actual segment = s.segment begin PER ; + number of segments . + +ENDPROC segs ; + + +PROC next segment (SEQUENCE VAR s, ATOMROW CONST atom) : + + disable stop; + s.line no INCR (s.segment end - s.index + 1); + INT CONST new segment index := actual segment.succ; + s.segment begin := new segment index; + s.segment end := new segment.end; + s.index := new segment index . + +actual segment : atom (s.segment begin).seg . +new segment : atom (new segment index).seg . + +END PROC next segment; + + +PROC previous segment (SEQUENCE VAR s, ATOMROW CONST atom) : + + disable stop; + s.line no DECR (s.index - s.segment begin + 1); + INT CONST new segment index := actual segment.pred; + s.segment begin := new segment index; + s.segment end := new segment.end; + s.index := s.segment end . + +actual segment : atom (s.segment begin).seg . +new segment : atom (new segment index).seg . + +END PROC previous segment; + + +PROC split segment (SEQUENCE VAR s, ATOMROW VAR atom) : + + disable stop; + IF not at segment top + THEN split segment at actual position + FI . + +split segment at actual position : + INT CONST pred index := s.segment begin, + actual index := s.index, + succ index := pred.succ; + + actual.pred := pred index; + actual.succ := succ index; + actual.end := s.segment end; + + pred.succ := actual index; + pred.end := actual index - 1; + + succ.pred := actual index; + + s.segment begin := actual index . + +not at segment top : s.index > s.segment begin . + +pred : atom (pred index).seg . + +actual : atom (actual index).seg . + +succ : atom (succ index).seg . + +END PROC split segment; + + +PROC join segments (ATOMROW VAR atom, + INT CONST first index, INT VAR second index) : + + disable stop; + IF first seg.end + 1 = second index + THEN attach second to first segment + ELSE link first to second segment + FI . + +attach second to first segment : + first seg.end := second seg.end; + INT VAR successor of second := second seg.succ; + IF successor of second = second index + THEN first seg.succ := first index + ELSE join segments (atom, first index, successor of second) + FI; + second index := first index . + +link first to second segment : + first seg.succ := second index; + second seg.pred := first index . + +first seg : atom (first index).seg . +second seg : atom (second index).seg . + +END PROC join segments; + + +PROC delete segments (SEQUENCE VAR from, ATOMROW VAR atom, + INT CONST first index, last index, lines) : + + determine surrounding segments and new atom index; + join surrounding segments; + update sequence descriptor . + +determine surrounding segments and new atom index : + INT VAR pred index := first seg.pred, + actual index := last seg.succ; + from.index := actual index . + +join surrounding segments : + join segments (atom, pred index, actual index) . + +update sequence descriptor : + from.segment begin := actual index; + from.segment end := actual seg.end; + from.lines DECR lines . + +actual seg : atom (actual index).seg . +first seg : atom (first index).seg . +last seg : atom (last index).seg . + +END PROC delete segments; + + +PROC insert segments (SEQUENCE VAR into, ATOMROW VAR atom, + INT CONST first index, last index, lines) : + + join into sequence and new segments; + update sequence descriptor . + +join into sequence and new segments : + INT VAR actual index := into.index, + pred index := actual seg.pred; + join segments (atom, last index, actual index); + actual index := first index; + join segments (atom, pred index, actual index) . + +update sequence descriptor : + into.index := first index; + into.segment begin := actual index; + into.segment end := actual seg.end; + into.lines INCR lines . + +actual seg : atom (actual index).seg . + +END PROC insert segments; + + +PROC next atom (SEQUENCE VAR s, ATOMROW CONST atom) : + + IF s.line no <= s.lines + THEN to next atom + ELSE errorstop ("'down' nach Dateiende") + FI . + +to next atom : + disable stop; + IF s.index = s.segment end + THEN next segment (s, atom) + ELSE s.index INCR 1; + s.line no INCR 1 + FI + +END PROC next atom; + + +PROC next atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) : + + INT CONST destination line := min (s.line no + times, s.lines + 1); + jump upto destination segment; + position within destination segment . + +jump upto destination segment : + WHILE s.line no + length of actual segments tail < destination line REP + next segment (s, atom); + PER . + +position within destination segment : + disable stop; + s.index INCR (destination line - s.line no); + s.line no := destination line . + +length of actual segments tail : s.segment end - s.index . + +END PROC next atoms; + + +PROC previous atom (SEQUENCE VAR s, ATOMROW CONST atom) : + + IF s.line no > 1 + THEN to previous atom + ELSE errorstop ("'up' am Dateianfang") + FI . + +to previous atom : + disable stop; + IF s.index = s.segment begin + THEN previous segment (s, atom) + ELSE s.index DECR 1; + s.line no DECR 1 + FI + +END PROC previous atom; + + +PROC previous atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) : + + INT CONST destination line := max (1, s.line no - times); + jump back to destination segment; + position within destination segment . + +jump back to destination segment : + WHILE s.line no - length of actual segments head > destination line REP + previous segment (s, atom); + PER . + +position within destination segment : + disable stop; + s.index DECR (s.line no - destination line); + s.line no := destination line . + +length of actual segments head : s.index - s.segment begin . + +END PROC previous atoms; + + +TEXT VAR pre, pat, pattern0; +INT VAR last search line ; + +PROC search down (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT CONST max lines, INT VAR column) : + + INT CONST start col := column , + start line := s.lineno ; + last search line := min (s.lines, s.lineno + max lines) ; + pre:= somefix (pattern) ; + pattern0 := pattern ** 0 ; + down in atoms (s, atom, pre, column); + IF NOT (last search succeeded CAND like pattern) + THEN try again + FI; + last search succeeded := TRUE ; + column := matchpos (0) . + +try again: + WHILE s.line no < last search line + REP next atom (s, atom) ; + column := 1 ; + down in atoms (s, atom, pre, column); + IF last search succeeded CAND like pattern + THEN LEAVE try again + FI + PER; + column := 1 + LENGTH record; + last search succeeded := FALSE ; + LEAVE search down. + +like pattern : + correct position ; + pat := any (column-1) ; + pat CAT any ; + pat CAT pattern0 ; + pat CAT any ; + record LIKE pat . + +correct position : + IF s.lineno = start line + THEN column := start col + ELSE column := 1 + FI . + +record : atom (s.index).line . + +ENDPROC search down ; + +PROC down in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT VAR column) : + + last search succeeded := FALSE ; + search forwards in actual line ; + IF NOT found AND s.line no < last search line + THEN search in following lines + FI ; + IF found + THEN last search succeeded := TRUE + ELSE set column behind last char + FI . + +set column behind last char : + column := LENGTH atom (s.index).line + 1 . + +search forwards in actual line : + IF pattern <> "" + THEN column := pos (atom (s.index).line, pattern, column) + ELIF column > LENGTH atom (s.index).line + THEN column := 0 + FI . + +search in following lines : + next atom (s, atom) ; + IF pattern = "" + THEN column := 1 ; + LEAVE search in following lines + FI ; + REP + search forwards through segment ; + update file position forwards ; + IF found OR s.line no = last search line + THEN LEAVE search in following lines + ELSE next segment (s, atom) + FI + PER . + +search forwards through segment : + INT VAR search index := s.index , + last index := min (s.segment end, s.index+(last search line-s.line no)); + REP + column := pos (atom (search index).line, pattern) ; + IF found OR search index = last index + THEN LEAVE search forwards through segment + FI ; + search index INCR 1 + PER . + +update file position forwards : + disable stop ; + s.line no INCR (search index - s.index) ; + s.index := search index ; + enable stop . + +found : column > 0 . + +ENDPROC down in atoms ; + +TEXT PROC prefix (TEXT CONST pattern) : + + INT VAR invalid char pos := pos (pattern, ""0"", ""31"", 1) ; + SELECT invalid char pos OF + CASE 0 : pattern + CASE 1 : "" + OTHERWISE : subtext (pattern, 1, invalid char pos - 1) + ENDSELECT . + +ENDPROC prefix ; + +PROC search up (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT CONST max lines, INT VAR column) : + + last search line := max (1, s.lineno - max lines) ; + pre:= prefix (pattern); + pattern0 := pattern ** 0; + remember start point ; + up in atoms (s, atom, pre, column); + IF NOT (last search succeeded CAND last pattern in line found) + THEN try again + FI; + last search succeeded := TRUE ; + column := matchpos (0) . + + try again: + WHILE s.lineno > last search line OR column > 1 + REP previous atom (s, atom); + column := LENGTH record ; + up in atoms (s, atom, pre, column); + IF last search succeeded CAND last pattern in line found + THEN LEAVE try again + FI + PER; + column := 1; + last search succeeded := FALSE ; + LEAVE search up. + + remember start point : + INT VAR c:= column, r:= s.lineno;. + + last pattern in line found : + column := 2 ; + WHILE like pattern CAND right of start REP + column := matchpos (0) +1 + PER ; + column DECR 1 ; + like pattern CAND right of start . + + like pattern : + pat := any (column-1) ; + pat CAT any ; + pat CAT pattern0 ; + pat CAT any ; + record LIKE pat . + + right of start : (r > s.lineno COR c >= matchpos(0)) . + record : atom (s.index).line . + +ENDPROC search up ; + +PROC up in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern, + INT VAR column) : + + last search succeeded := FALSE ; + search backwards in actual line ; + IF NOT found AND s.line no > last search line + THEN search in preceeding lines + FI ; + IF found + THEN last search succeeded := TRUE + ELSE column := 1 + FI . + +search backwards in actual line : + IF pattern = "" + THEN LEAVE search backwards in actual line + FI ; + INT VAR last pos , new pos := 0 ; + REP + last pos := new pos ; + new pos := pos (atom (s.index).line, pattern, last pos+1) ; + UNTIL new pos = 0 OR new pos > column PER ; + column := last pos . + +search in preceeding lines : + previous atom (s, atom) ; + IF pattern = "" + THEN column := LENGTH atom (s.index).line + 1 ; + last search succeeded := TRUE ; + LEAVE search in preceeding lines + FI ; + REP + search backwards through segment ; + update file position backwards ; + IF found OR s.line no = last search line + THEN LEAVE search in preceeding lines + ELSE previous segment (s, atom) + FI + PER . + +search backwards through segment : + INT VAR search index := s.index , + last index := max (s.segment begin, s.index-(s.line no-last search line)); + REP + new pos := 0 ; + REP + column := new pos ; + new pos := pos (atom (search index).line, pattern, column+1) ; + UNTIL new pos = 0 PER ; + IF found OR search index = last index + THEN LEAVE search backwards through segment + FI ; + search index DECR 1 + PER . + +update file position backwards : + disable stop ; + s.line no DECR (s.index - search index) ; + s.index := search index ; + enable stop . + +found : column > 0 . + +ENDPROC up in atoms ; + +BOOL VAR last search succeeded ; + +BOOL PROC pattern found : + last search succeeded +ENDPROC pattern found ; + + + +PROC delete atom (SEQUENCE VAR used, free, ATOMROW VAR atom) : + + disable stop; + IF used.line no <= used.lines + THEN delete actual atom + ELSE errorstop ("'delete' am Dateiende") + FI . + +delete actual atom : + position behind actual free segment; + split segment (used, atom); + INT VAR actual index := used.index; + cut off tail of actual used segment; + delete segments (used, atom, actual index, actual index, 1); + insert segments (free, atom, actual index, actual index, 1) . + +position behind actual free segment : + IF free.line no <= free.lines + THEN next segment (free, atom) + FI . + +cut off tail of actual used segment : + IF actual index <> used.segment end + THEN used.index INCR 1; + split segment (used, atom); + used.index DECR 1 + FI . + +END PROC delete atom; + + +PROC insert atom (SEQUENCE VAR used, free,INT VAR unused, ATOMROW VAR atom) : + + disable stop; + split segment (used, atom); + IF free.lines > 0 + THEN insert new atom from free sequence + ELIF unused <= file size + THEN insert new atom from unused tail + ELSE errorstop ("FILE-Ueberlauf") + FI . + +insert new atom from free sequence : + get a free segments head; + make this atom to actual segment; + transfer from free to used chain . + +get a free segments head : + IF actual free segment is root segment + THEN previous segment (free, atom) + FI; + position to actual segments head . + +position to actual segments head : + INT VAR actual index := free.segment begin; + free.line no DECR (free.index - actual index); + free.index := actual index . + +make this atom to actual segment : + IF free.segment end > actual index + THEN free.index INCR 1; + split segment (free, atom); + free.index DECR 1 + FI . + +transfer from free to used chain : + delete segments (free, atom, actual index, actual index, 1); + insert segments (used, atom, actual index, actual index, 1); + atom (actual index).line := "" . + +insert new atom from unused tail : + actual index := unused; + atom (actual index).seg := + SEGMENT:(actual index, actual index, actual index); + atom (actual index).line := ""; + insert segments (used, atom, actual index, actual index, 1); + unused INCR 1 . + +actual free segment is root segment : free.segment begin = free root . + +END PROC insert atom; + + +PROC insert next (SEQUENCE VAR used, free, INT VAR unused, ATOMROW VAR atom, + TEXT CONST record) : + + IF used.line no > used.lines + THEN insert atom (used, free, unused, atom) + ELIF actual position before unused nonempty atomrow part + THEN forward and insert atom by simple extension of used atomrow part + ELSE next atom (used, atom); + insert atom (used, free, unused, atom) + FI; + atom (used.index).line := record . + +forward and insert atom by simple extension of used atomrow part : + used.line no INCR 1; + used.lines INCR 1; + used.index INCR 1; + used.segment end INCR 1; + atom (used.segment begin).seg.end INCR 1; + unused INCR 1 . + +actual position before unused nonempty atomrow part : + used.index = unused - 1 AND unused part not empty . + +unused part not empty : unused <= file size . + +END PROC insert next; + + +PROC transfer subsequence (SEQUENCE VAR source, dest, + ATOMROW VAR atom, INT CONST size) : + + IF size > 0 + THEN INT VAR subsequence size := min (size, source.line no); + mark begin of source part; + mark end of source part; + split destination sequence; + transfer part + FI . + +mark begin of source part : + previous atoms (source, atom, subsequence size - 1); + split segment (source, atom); + INT CONST first := source.segment begin . + +mark end of source part : + next atoms (source, atom, subsequence size - 1); + INT CONST last := source.segment begin; + next atom (source, atom); + split segment (source, atom) . + +split destination sequence : + split segment (dest, atom) . + +transfer part : + disable stop; + delete segments (source, atom, first, last, subsequence size); + source.line no DECR subsequence size; + insert segments (dest, atom, first, last, subsequence size); + next atoms (dest, atom, subsequence size - 1) . + +END PROC transfer subsequence; + + + +(********************************************************************) +(***** *****) +(***** FILE handler *****) +(***** *****) +(********************************************************************) + + + +LET file type = 1003 , + file type 16 = 1002 , + + closed = 0, + inp = 1, + outp = 2, + mod = 3, + end = 4, + + max limit = 16000, + super limit = 16001; + + +TYPE TRANSPUTDIRECTION = INT; + + +TRANSPUTDIRECTION PROC input : + TRANSPUTDIRECTION : (inp) +END PROC input; + + +TRANSPUTDIRECTION PROC output : + TRANSPUTDIRECTION : (outp) +END PROC output; + + +TRANSPUTDIRECTION PROC modify : + TRANSPUTDIRECTION : (mod) +END PROC modify; + + +FILE VAR result file; + + +FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, + DATASPACE CONST ds) : + IF type (ds) = file type + THEN result := ds + ELIF type (ds) < 0 + THEN result := ds; type (ds, file type); initialize (result file) + ELSE enable stop; errorstop ("Datenraum hat falschen Typ") + FI; + reset (result file, mode); + result file . + +result : CONCR (result file) . + +END PROC sequential file; + + +FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, TEXT CONST name) : + + IF exists (name) + THEN get dataspace if file + ELIF CONCR (mode) <> inp + THEN get new file space + ELSE errorstop (""""+name+""" gibt es nicht") ; enable stop + FI; + update status if necessary; + reset (result file, mode); + result file . + +get dataspace if file : + IF type (old (name)) = file type 16 + THEN reorganize (name) + FI ; + result := old (name, file type) ; + IF is 170 file + THEN result.col := 1 ; + result.mark line := 0 ; + result.mark col := 0 + FI . + +is 170 file : result.mark col < 0 . + +get new file space : + result := new (name); + IF NOT is error + THEN type (old (name), file type); initialize (result file) + FI . + +update status if necessary : + IF CONCR (mode) <> inp + THEN status (name, ""); headline (result file, name) + FI . + +result : CONCR (result file) . + +END PROC sequential file; + + +PROC reset (FILE VAR f) : + + IF f.mode = end + THEN reset (f, input) + ELSE reset (f, TRANSPUTDIRECTION:(f.mode)) + FI . + +ENDPROC reset ; + +PROC reset (FILE VAR f, TRANSPUTDIRECTION CONST mode) : + + IF f.mode <> mod OR new mode <> mod + THEN f.mode := new mode ; + initialize file index + FI . + +initialize file index : + IF new mode = outp + THEN to line without check (f, f.used.lines); + col := super limit + ELSE to line without check (f, 1); + col := 1 ; + IF new mode = inp AND file is empty + THEN f.mode := end + FI + FI . + +file is empty : f.used.lines = 0 . + +new mode : CONCR (mode) . + +col : CONCR (CONCR (f)).col . + +END PROC reset; + + +PROC input (FILE VAR f) : + + reset (f, input) . + +END PROC input; + + +PROC output (FILE VAR f) : + + reset (f, output) + +END PROC output; + + +PROC modify (FILE VAR f) : + + reset (f, modify) + +END PROC modify; + + +PROC close (FILE VAR f) : + + f.mode := closed . + +END PROC close; + + +PROC check mode (FILE CONST f, INT CONST mode) : + + IF f.mode = mode + THEN LEAVE check mode + ELIF f.mode = closed + THEN errorstop ("Datei zu!") + ELIF f.mode = mod + THEN errorstop ("unzulaessiger Zugriff auf modify-FILE") + ELIF mode = mod + THEN errorstop ("Zugriff nur auf modify-FILE zulaessig") + ELIF f.mode = end + THEN errorstop ("Leseversuch nach Dateiende") + ELIF mode = inp + THEN errorstop ("Leseversuch auf output-FILE") + ELIF mode = outp + THEN errorstop ("Schreibversuch auf input-FILE") + FI . + +END PROC check mode; + + +PROC to line without check (FILE VAR f, INT CONST destination line) : + + INT CONST distance := destination line - f.used.line no; + IF distance > 0 + THEN next atoms (f.used, f.atoms, distance) + ELIF distance < 0 + THEN previous atoms (f.used, f.atoms, - distance) + FI . + +END PROC to line without check; + + +PROC to line (FILE VAR f, INT CONST destination line) : + + check mode (f, mod); + to line without check (f, destination line) + +END PROC to line; + + +PROC to first record (FILE VAR f) : + + to line (f, 1) + +END PROC to first record; + + +PROC to eof (FILE VAR f) : + + to line (f, f.used.lines + 1) . + +END PROC to eof; + + +PROC putline (FILE VAR f, TEXT CONST word) : + + write (f, word); + col := super limit . + +col : CONCR (CONCR (f)).col . + +END PROC putline; + + +PROC delete record (FILE VAR f) : + + check mode (f, mod); + delete atom (f.used, f.free, f.atoms) . + +END PROC delete record; + + +PROC insert record (FILE VAR f) : + + check mode (f, mod); + insert atom (f.used, f.free, f.unused tail, f.atoms) . + +END PROC insert record; + + +PROC down (FILE VAR f) : + + check mode (f, mod); + next atom (f.used, f.atoms) . + +END PROC down ; + +PROC up (FILE VAR f) : + + check mode (f, mod); + previous atom (f.used, f.atoms) . + +END PROC up ; + +PROC down (FILE VAR f, INT CONST n) : + + to line (f, lineno (f) + n) + +ENDPROC down ; + +PROC up (FILE VAR f, INT CONST n) : + + to line (f, lineno (f) - n) + +ENDPROC up ; + + +PROC write record (FILE VAR f, TEXT CONST record) : + + check mode (f, mod); + IF not at eof + THEN f.atoms (f.used.index).line := record + ELSE errorstop ("'write' nach Dateiende") + FI . + +not at eof : f.used.line no <= f.used.lines . + +END PROC write record; + + +PROC read record (FILE CONST f, TEXT VAR record) : + + check mode (f, mod); + record := f.atoms (f.used.index).line . + +END PROC read record; + + +PROC line (FILE VAR f) : + + IF mode = end + THEN errorstop ("Leseversuch nach Dateiende") + ELIF mode = inp + THEN next atom (f.used, f.atoms); col := 1; check eof + ELIF mode = outp + THEN IF col <= max limit + THEN col := super limit + ELSE append empty line + FI + FI . + +append empty line : + insert next (f.used, f.free, f.unused tail, f.atoms, "") . + +col : CONCR (CONCR (f)).col . + +mode : CONCR (CONCR (f)).mode . + +check eof : + IF eof (f) THEN mode := end FI . + +END PROC line; + + +PROC line (FILE VAR f, INT CONST lines) : + + INT VAR i; FOR i FROM 1 UPTO lines REP line (f) PER + +END PROC line; + + +PROC getline (FILE VAR f, TEXT VAR text) : + + check mode (f, inp); + text := subtext (record, f.col); + IF f.used.line no >= f.used.lines + THEN f.mode := end ; + set end of file + ELSE to next line ; + f.col := 1 + FI . + +to next line : + next atom (f.used, f.atoms) . + +set end of file : + f.col := LENGTH record + 1 . + +record : f.atoms (f.used.index).line . + +END PROC getline; + + +BOOL PROC is first record (FILE CONST f) : + + check mode (f, mod); + f.used.line no = 1 . + +END PROC is first record; + + +BOOL PROC eof (FILE CONST f) : + + IF line no < lines THEN FALSE + ELIF line no = lines THEN col > LENGTH record + ELSE TRUE + FI . + +line no : f.used.line no . +lines : f.used.lines . +col : f.col . +record : f.atoms (f.used.index).line . + +END PROC eof; + + +INT PROC line no (FILE CONST f) : + + f.used.line no . + +END PROC line no; + + +PROC line type (FILE VAR f, INT CONST t) : + + f.atoms (f.used.index).type := t . + +ENDPROC line type ; + +INT PROC line type (FILE CONST f) : + + f.atoms (f.used.index).type . + +ENDPROC line type ; + + +PROC put (FILE VAR f, TEXT CONST word) : + + check mode (f, outp); + IF col + LENGTH word > f.limit + THEN append new line + ELSE record CAT word + FI; + record CAT " "; + col := LENGTH record + 1 . + +append new line : + insert next (f.used, f.free, f.unused tail, f.atoms, word) . + +record : f.atoms (f.used.index).line . +col : f.col . + +END PROC put; + + +PROC put (FILE VAR f, INT CONST value) : + + put (f, text (value)) + +END PROC put; + + +PROC put (FILE VAR f, REAL CONST real) : + + put (f, text (real)) + +END PROC put; + + +PROC write (FILE VAR f, TEXT CONST word) : + + check mode (f, outp); + IF col + LENGTH word - 1 > f.limit + THEN append new line + ELSE record CAT word + FI; + col := LENGTH record + 1 . + +append new line : + insert next (f.used, f.free, f.unused tail, f.atoms, word) . + +record : f.atoms (f.used.index).line . +col : f.col . + +END PROC write; + + +PROC get (FILE VAR f, TEXT VAR word, TEXT CONST separator) : + + check mode (f, inp); + skip separators; + IF word found + THEN get word + ELSE try to find word in next line + FI . + +skip separators : + INT CONST separator length := LENGTH separator; + WHILE is separator REP col INCR separator length PER . + +is separator : + subtext (record, col, col + separator length - 1) = separator . + +word found : col <= LENGTH record . + +get word : + INT VAR end of word := pos (record, separator, col) - 1; + IF separator found + THEN get text upto separator + ELSE get rest of record + FI . + +separator found : end of word >= 0 . + +get text upto separator : + word := subtext (record, col, end of word); + col := end of word + separator length + 1; + IF col > LENGTH record THEN line (f) FI . + +get rest of record : + word := subtext (record, col); line (f) . + +record : f.atoms (f.used.index).line . +col : f.col . + +try to find word in next line : + line (f); IF eof (f) THEN word := "" ELSE get (f, word, separator) FI . + +END PROC get; + + +PROC get (FILE VAR f, TEXT VAR word, INT CONST max length) : + + check mode (f, inp); + IF word is only a part of record + THEN get text of certain length + ELSE get rest of record + FI . + +word is only a part of record : + col <= LENGTH record - max length . + +get text of certain length : + word := text (record, max length, col); + col INCR max length . + +get rest of record : + word := subtext (record, col); line (f) . + +record : f.atoms (f.used.index).line . +col : f.col . + +END PROC get; + + +PROC get (FILE VAR f, TEXT VAR word) : + + get (f, word, " ") + +END PROC get; + + +TEXT VAR number word; + + +PROC get (FILE VAR f, INT VAR number) : + + get (f, number word); + number := int (number word) + +END PROC get; + + +PROC get (FILE VAR f, REAL VAR number) : + + get (f, number word); + number := real (number word) + +END PROC get; + + +TEXT VAR split record ; +INT VAR indentation ; + +PROC split line (FILE VAR f, INT CONST split col) : + + split line (f, split col, TRUE) + +ENDPROC split line ; + +PROC split line (FILE VAR f, INT CONST split col, BOOL CONST note indentation ) : + + IF note indentation + THEN get indentation + ELSE indentation := 0 + FI ; + get split record ; + insert split record and indentation ; + cut off old record . + +get indentation : + indentation := pos (actual record,""33"",""254"",1) - 1 ; + IF indentation < 0 OR indentation >= split col + THEN indentation := split col - 1 + FI . + +get split record : + split record := subtext (actual record, split col, max limit) . + +insert split record and indentation : + down (f) ; + insert record (f) ; + INT VAR i ; + FOR i FROM 1 UPTO indentation REP + actual record CAT " " + PER ; + actual record CAT split record ; + up (f) . + +cut off old record : + actual record := subtext (actual record, 1, split col-1) . + +actual record : f.atoms (f.used.index).line . + +ENDPROC split line ; + +PROC concatenate line (FILE VAR f, BOOL CONST delete blanks) : + + down (f) ; + split record := actual record ; + IF delete blanks + THEN delete leading blanks + FI ; + delete record (f) ; + up (f) ; + actual record CAT split record . + +delete leading blanks : + INT CONST non blank col := pos (split record, ""33"", ""254"", 1) ; + IF non blank col > 0 + THEN split record := subtext (split record, non blank col) + FI . + +actual record : f.atoms (f.used.index).line . + +ENDPROC concatenate line ; + +PROC concatenate line (FILE VAR f) : + concatenate line (f, TRUE) +ENDPROC concatenate line ; + +PROC reorganize : + + reorganize (last param) + +END PROC reorganize; + + +TEXT VAR file record ; + +PROC reorganize (TEXT CONST file name) : + + enable stop ; + FILE VAR input file, output file; + DATASPACE VAR scratch space; + INT CONST type of dataspace := type (old (file name)) ; + INT VAR counter; + + last param (file name); + IF type of dataspace = file type + THEN reorganize new to new + ELIF type of dataspace = file type 16 + THEN reorganize old to new + ELSE errorstop ("Datenraum hat falschen Typ") + FI; + replace file space by scratch space . + +reorganize new to new : + input file := sequential file (input, file name); + disable stop ; + scratch space := nilspace ; + output file := sequential file (output, scratch space); + copy attributes (input file, output file) ; + + FOR counter FROM 1 UPTO 9999 + WHILE NOT eof (input file) REP + cout (counter); + getline (input file, file record); + putline (output file, file record); + check for interrupt + PER . + +reorganize old to new : + LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT record); + LET OLDFILE = BOUND ROW 4075 OLDRECORD; + LET dateianker = 2, freianker = 1; + INT VAR index := dateianker; + + OLDFILE VAR old file := old (file name); + disable stop; + scratch space := nilspace; + output file := sequential file (output, scratch space); + get old attributes ; + + say ("Datei wird in 1.7-Format gewandelt: ") ; + + FOR counter FROM 1 UPTO 9999 + WHILE NOT end of old file REP + cout (counter); + index := next record; + file record := record of old file ; + IF pos (file record, ""128"", ""250"", 1) > 0 + THEN change special chars + FI ; + putline (output file, file record); + check for interrupt + PER . + +get old attributes : + get old headline ; + get old limit and tabs . + +get old headline : + headline (output file, old file (dateianker).record) . + +get old limit and tabs : + file record := old file (freianker).record ; + max line length (output file, int (subtext (file record, 11, 15))) ; + put tabs (output file, subtext (file record, 16)) . + +change special chars : + change all (file record, ""193"", ""214"") (* Ae *) ; + change all (file record, ""207"", ""215"") (* Oe *) ; + change all (file record, ""213"", ""216"") (* Ue *) ; + change all (file record, ""225"", ""217"") (* ae *) ; + change all (file record, ""239"", ""218"") (* oe *) ; + change all (file record, ""245"", ""219"") (* ue *) ; + change all (file record, ""235"", ""220"") (* k *) ; + change all (file record, ""173"", ""221"") (* - *) ; + change all (file record, ""163"", ""222"") (* fis *) ; + change all (file record, ""160"", ""223"") (* blank *) ; + change all (file record, ""194"", ""251"") (* eszet *) . + +end of old file : next record = dateianker . + +next record : old file (index).succ . + +record of old file : old file (index).record . + +check for interrupt : + INT VAR size, used ; + storage (size, used) ; + IF used > size + THEN errorstop ("Speicherengpass") + FI ; + IF is error + THEN forget (scratch space) ; LEAVE reorganize + FI . + +replace file space by scratch space : + headline (output file, file name); + forget (file name, quiet) ; + type (scratch space, file type); + copy (scratch space, file name); + forget (scratch space) . + +END PROC reorganize; + + +PROC set range (FILE VAR f, INT CONST start line, start col, + FRANGE VAR old range) : + + check mode (f, mod); + IF valid restriction parameters + THEN prepare last line ; + prepare first line ; + save old range ; + set new range + ELSE errorstop ("FRANGE ungueltig") + FI . + +valid restriction parameters : + start line > 0 AND start col > 0 AND start before or at actual point . + +start before or at actual point : + start line < line no (f) OR + start line = line no (f) AND start col <= col (f) . + +prepare last line : + INT VAR last line ; + IF col (f) > 1 + THEN split line (f, col(f), FALSE) + FI . + +prepare first line : + IF start col > 1 + THEN split start line ; + FI . + +split start line : + INT VAR old line no := line no (f) ; + to line (f, start line) ; + split line (f, start col, FALSE) ; + to line (f, old line no + 1) . + +save old range : + old range.pre := f.prefix lines ; + old range.post:= f.postfix lines . + +set new range : + get pre lines ; + get post lines ; + disable stop ; + f.prefix lines INCR pre lines ; + f.postfix lines INCR post lines ; + f.used.lines DECR (post lines + pre lines) ; + f.used.line no DECR pre lines . + +get pre lines : + INT VAR pre lines ; + IF start col = 1 + THEN old range.pre was split := FALSE ; + pre lines := start line - 1 + ELSE old range.pre was split := TRUE ; + pre lines := start line + FI . + +get post lines : + INT VAR post lines ; + IF col (f) = 1 + THEN old range.post was split := FALSE ; + post lines := lines (f) - line no (f) + 1 + ELSE old range.post was split := TRUE ; + post lines := lines (f) - line no (f) + FI . + +END PROC set range; + + +PROC set range (FILE VAR f, FRANGE VAR new range) : + + check mode (f, mod); + INT CONST pre add := prefix - new range.pre, + post add := postfix - new range.post; + IF pre add < 0 OR post add < 0 + THEN errorstop ("FRANGE ungueltig") + ELSE set new range; + undo splitting if necessary ; + make range var invalid + FI . + +set new range : + disable stop; + prefix DECR pre add; + postfix DECR post add; + used.line no INCR pre add; + used.lines INCR (pre add + post add) . + +undo splitting if necessary : + IF new range.pre was split + THEN concatenate first line + FI ; + IF new range.post was split + THEN concatenate last line + FI . + +concatenate first line : + INT VAR old line := line no (f) ; + to line (f, pre add) ; + concatenate line (f, FALSE) ; + to line (f, old line - 1) . + +concatenate last line : + old line := line no (f) ; + to line (f, lines (f) - post add) ; + concatenate line (f, FALSE) ; + to line (f, old line) . + +make range var invalid : + new range.pre := maxint . + +used : f.used . +prefix : f.prefix lines . +postfix : f.postfix lines . + +END PROC set range; + +PROC reset range (FILE VAR f) : + + FRANGE VAR complete ; + complete.pre := 0 ; + complete.post:= 0 ; + complete.pre was split := FALSE ; + complete.post was split:= FALSE ; + set range (f, complete) + +ENDPROC reset range ; + +PROC remove (FILE VAR f, INT CONST size) : + + check mode (f, mod); + transfer subsequence (f.used, f.scratch, f.atoms, size) . + +END PROC remove; + + +PROC clear removed (FILE VAR f) : + + check mode (f, mod); + transfer subsequence (f.scratch, f.free, f.atoms, f.scratch.lines) . + +END PROC clear removed; + + +PROC reinsert (FILE VAR f) : + + check mode (f, mod); + transfer subsequence (f.scratch, f.used, f.atoms, f.scratch.lines) . + +END PROC reinsert; + + +PROC copy attributes (FILE CONST source file, FILE VAR dest file) : + + dest.limit := source.limit ; + dest.atoms (free root).line := source.atoms (free root).line ; + dest.atoms (scratch root).line := source.atoms (scratch root).line ; + dest.edit info := source.edit info . + +dest : CONCR (CONCR (dest file)) . +source : CONCR (CONCR (source file)) . + +ENDPROC copy attributes ; + + +INT PROC max line length (FILE CONST f) : + + f.limit . + +END PROC max line length; + + +PROC max line length (FILE VAR f, INT CONST new limit) : + + IF new limit > 0 AND new limit <= max limit + THEN f.limit := new limit + FI . + +END PROC max line length; + + +TEXT PROC headline (FILE CONST f) : + + f.atoms (free root).line . + +END PROC headline; + + +PROC headline (FILE VAR f, TEXT CONST head) : + + f.atoms (free root).line := head . + +END PROC headline; + + +PROC get tabs (FILE CONST f, TEXT VAR tabs) : + + tabs := f.atoms (scratch root).line . + +END PROC get tabs; + + +PROC put tabs (FILE VAR f, TEXT CONST tabs) : + + f.atoms (scratch root).line := tabs . + +END PROC put tabs; + + +INT PROC edit info (FILE CONST f) : + + f.edit info . + +END PROC edit info; + + +PROC edit info (FILE VAR f, INT CONST info) : + + f.edit info := info . + +END PROC edit info; + + +INT PROC lines (FILE CONST f) : + + f.used.lines . + +END PROC lines; + + +INT PROC removed lines (FILE CONST f) : + + f.scratch.lines . + +END PROC removed lines; + + +INT PROC segments (FILE CONST f) : + + segs(f.used,f.atoms) + segs(f.scratch,f.atoms) + segs(f.free,f.atoms) - 2 . + +ENDPROC segments ; + + +INT PROC col (FILE CONST f) : + + f.col + +ENDPROC col ; + +PROC col (FILE VAR f, INT CONST new column) : + + IF new column > 0 + THEN f.col := new column + FI + +ENDPROC col ; + +TEXT PROC word (FILE CONST f) : + + word (f, " ") + +ENDPROC word ; + +TEXT PROC word (FILE CONST f, TEXT CONST delimiter) : + + INT VAR del pos := pos (f, delimiter, col (f)) ; + IF del pos = 0 + THEN del pos := len (f) + 1 + FI ; + subtext (f, col (f), del pos - 1) + +ENDPROC word ; + +TEXT PROC word (FILE CONST f, INT CONST max length) : + + subtext (f, col (f), col (f) + max length - 1) + +ENDPROC word ; + +BOOL PROC at (FILE CONST f, TEXT CONST word) : + + pat := any (column-1) ; + pat CAT word ; + pat CAT any ; + record LIKE pat . + +column : f.col . +record : f.atoms (f.used.index).line . + +ENDPROC at ; + + +PROC exec (PROC (TEXT VAR, TEXT CONST) proc, FILE VAR f, TEXT CONST t) : + + proc (record, t) . + +record : f.atoms (f.used.index).line . + +END PROC exec; + + +PROC exec (PROC (TEXT VAR, INT CONST) proc, FILE VAR f, INT CONST i) : + + proc (record, i) . + +record : f.atoms (f.used.index).line . + +END PROC exec; + +INT PROC pos (FILE CONST f, TEXT CONST pattern, INT CONST i) : + + pos (record, pattern, i) . + +record : f.atoms (f.used.index).line . + +END PROC pos ; + +PROC down (FILE VAR f, TEXT CONST pattern) : + + down (f, pattern, file size) + +ENDPROC down ; + +PROC down (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col + 1 ; + search down (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC down ; + +PROC downety (FILE VAR f, TEXT CONST pattern) : + + downety (f, pattern, file size) + +ENDPROC downety ; + +PROC downety (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col ; + search down (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC downety ; + +PROC up (FILE VAR f, TEXT CONST pattern) : + + up (f, pattern, file size) + +ENDPROC up ; + +PROC up (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col - 1 ; + search up (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC up ; + +PROC uppety (FILE VAR f, TEXT CONST pattern) : + + uppety (f, pattern, file size) + +ENDPROC uppety ; + +PROC uppety (FILE VAR f, TEXT CONST pattern, INT CONST max line) : + + check mode (f,mod) ; + INT VAR pattern pos := f.col ; + search up (f.used, f.atoms, pattern, max line, pattern pos) ; + f.col := pattern pos + +ENDPROC uppety ; + + +INT PROC len (FILE CONST f) : + + length (record) . + +record : f.atoms (f.used.index).line . + +ENDPROC len ; + +TEXT PROC subtext (FILE CONST f, INT CONST from, to) : + + subtext (record, from, to) . + +record : f.atoms (f.used.index).line . + +ENDPROC subtext ; + +PROC change (FILE VAR f, INT CONST from, to, TEXT CONST new) : + + check mode (f, mod) ; + change (record, from, to, new) . + +record : f.atoms (f.used.index).line . + +ENDPROC change ; + + +BOOL PROC mark (FILE CONST f) : + + f.mark line > 0 + +ENDPROC mark ; + +PROC mark (FILE VAR f, INT CONST line no, col) : + + IF line no > 0 + THEN f.mark line := line no + f.prefix lines ; + f.mark col := col + ELSE f.mark line := 0 ; + f.mark col := 0 + FI + +ENDPROC mark ; + +INT PROC mark line no (FILE CONST f) : + + IF f.mark line = 0 + THEN 0 + ELSE max (1, f.mark line - f.prefix lines) + FI + +ENDPROC mark line no ; + +INT PROC mark col (FILE CONST f) : + + IF f.mark line = 0 + THEN 0 + ELIF f.mark line <= f.prefix lines + THEN 1 + ELSE f.mark col + FI + +ENDPROC mark col ; + +PROC set marked range (FILE VAR f, FRANGE VAR old range) : + + IF mark (f) + THEN set range (f, mark line no (f), mark col (f), old range) + ELSE old range := previous range of file + FI . + +previous range of file : + FRANGE : (f.prefix lines, f.postfix lines, FALSE, FALSE) . + +ENDPROC set marked range ; + + +(*****************************************************************) + + (* Autor: P.Heyderhoff *) + (* Stand: 11.10.83 *) + +BOUND LIST VAR datei; +INT VAR sortierstelle, sortanker; +BOOL VAR ascii sort; +TEXT VAR median, tausch , links, rechts; + +PROC sort (TEXT CONST dateiname) : + sort (dateiname, 1) +END PROC sort; + +PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) : + ascii sort := TRUE ; + sortierstelle := sortieranfang; sortiere (dateiname) +END PROC sort; + +PROC lex sort (TEXT CONST dateiname) : + lex sort (dateiname, 1) +ENDPROC lex sort ; + +PROC lex sort (TEXT CONST dateiname, INT CONST sortieranfang) : + ascii sort := FALSE ; + sortierstelle := sortieranfang; sortiere (dateiname) +ENDPROC lex sort ; + +PROC sortiere (TEXT CONST dateiname) : + + reorganize file if necessary ; + sort file . + +reorganize file if necessary : + FILE VAR f := sequential file (modify, dateiname) ; + IF segments (f) > 1 + THEN reorganize (dateiname) + FI . + +sort file : + f := sequential file (modify, dateiname) ; + INT CONST sortende := lines (f) + 3 ; + sortanker := 1 + 3 ; + datei := old (dateiname) ; + quicksort(sortanker, sortende) . + +END PROC sortiere; + +PROC quicksort ( INT CONST anfang, ende ) : + IF anfang < ende + THEN INT VAR p,q; + spalte (anfang, ende, p, q); + quicksort (anfang, q); + quicksort (p, ende) FI +END PROC quicksort; + +PROC spalte (INT CONST anfang, ende, INT VAR p, q): + fange an der seite an und waehle den median; + ruecke p und q so dicht wie moeglich zusammen; + hole ggf median in die mitte . + + fange an der seite an und waehle den median : + p := anfang; q := ende ; + INT CONST m :: (p + q) DIV 2 ; + median := subtext(datei m, sortierstelle) . + + ruecke p und q so dicht wie moeglich zusammen : + REP schiebe p und q so weit wie moeglich auf bzw ab; + IF p < q THEN vertausche die beiden FI + UNTIL p > q END REP . + + vertausche die beiden : + tausch := datei p; datei p := datei q; datei q := tausch; + p INCR 1; q DECR 1 . + + schiebe p und q so weit wie moeglich auf bzw ab : + WHILE p kann groesser werden REP p INCR 1 END REP; + WHILE q kann kleiner werden REP q DECR 1 END REP . + + p kann groesser werden : + IF p <= ende + THEN links := subtext (datei p, sortierstelle) ; + IF ascii sort + THEN median >= links + ELSE median LEXGREATEREQUAL links + FI + ELSE FALSE + FI . + + q kann kleiner werden : + IF q >= anfang + THEN rechts := subtext(datei q, sortierstelle) ; + IF ascii sort + THEN rechts >= median + ELSE rechts LEXGREATEREQUAL median + FI + ELSE FALSE + FI . + + hole ggf median in die mitte : + IF m < q THEN vertausche m und q + ELIF m > p THEN vertausche m und p FI . + + vertausche m und q : + tausch := datei m; datei m := datei q; datei q := tausch; q DECR 1 . + + vertausche m und p : + tausch := datei m; datei m := datei p; datei p := tausch; p INCR 1 . + + datei m : datei.atoms (m).line . + datei p : datei.atoms (p).line . + datei q : datei.atoms (q).line . + +END PROC spalte; + +END PACKET file handling; + diff --git a/system/base/1.7.5/src/functions b/system/base/1.7.5/src/functions new file mode 100644 index 0000000..9f338ff --- /dev/null +++ b/system/base/1.7.5/src/functions @@ -0,0 +1,760 @@ +PACKET editor functions DEFINES (* FUNCTIONS - 052 *) + (**************) (* 17.07.85 -bk- *) + (* 10.09.85 -ws- *) + edit, (* 25.04.86 -sh- *) + show, (* 27.05.86 -wk- *) + U, + D, + T, + up, + down, + downety, + uppety, + to line, + PUT, + GET, + P, + G, + limit, + len, + eof, + C, + change to, + CA, + change all, + lines, + line no, + col, + mark, + at, + word, + std kommando interpreter, + note, + note line, + note edit, + anything noted, + note file: + + +LET marker = "^", + ersatzmarker = "'", + schritt = 50, + file size = 4072, + write acc = TRUE, + read acc = FALSE; + +LET bold = 2, + integer = 3, + string = 4, + end of file = 7; + +LET std res = "eqvw19dpgn"9""; + +FILE VAR edfile; +BOOL VAR from scratchfile :: FALSE; +TEXT VAR kommandotext, tabulator, zeile; + + +PROC std kommando interpreter (TEXT CONST taste) : + enable stop ; + edfile := editfile; + set busy indicator; + SELECT pos (std res, taste) OF + CASE 1 (*e*) : edit + CASE 2 (*q*) : quit + CASE 3 (*v*) : quit last + CASE 4 (*w*) : open editor (next editor) + CASE 5 (*1*) : toline (1); col (1) + CASE 6 (*9*) : toline (lines); col (len+1) + CASE 7 (*d*) : d case + CASE 8 (*p*) : p case + CASE 9 (*g*) : g case + CASE 10(*n*) : note edit + CASE 11(*tab*): change tabs + OTHERWISE : echtes kommando analysieren + END SELECT . + +d case : + IF mark + THEN PUT ""; mark (FALSE); from scratchfile := TRUE + ELSE textzeile auf taste legen + FI . + +p case : + IF mark (*sh*) + THEN IF write permission + THEN PUT ""; push(""27""12""); from scratchfile := TRUE + ELSE out (""7"") + FI + ELSE textzeile auf taste legen + FI . + +g case : + IF write permission (*sh*) + THEN IF from scratchfile + THEN GET "" + ELSE IF is editget + THEN push (lernsequenz auf taste ("g")); nichts neu + FI + FI + ELSE out (""7"") + FI . + +textzeile auf taste legen : + read record (edfile, zeile); + zeile := subtext (zeile, col); + lernsequenz auf taste legen ("g", zeile); + from scratchfile := FALSE; zeile neu . + +next editor : + (aktueller editor MOD groesster editor) + 1 . + +change tabs : + get tabs (edfile, tabulator) ; + IF pos (tabulator, marker) <> 0 + THEN change all (tabulator, marker, ersatzmarker) + ELSE change all (tabulator, ersatzmarker, marker) + FI ; + put tabs (edfile, tabulator) ; + ueberschrift neu . + +echtes kommando analysieren : + kommandotext := kommando auf taste (taste); + IF kommandotext = "" + THEN nichts neu; LEAVE std kommando interpreter + FI ; + scan (kommandotext); + TEXT VAR s1; INT VAR t1; next symbol (s1, t1); + TEXT VAR s2; INT VAR t2; next symbol (s2, t2); + IF t1 = integer AND t2 = end of file THEN toline (int (s1)) + ELIF t1 = string AND t2 = end of file THEN down (s1) + ELIF perhaps simple up or down THEN + ELIF perhaps simple changeto THEN + ELSE do (kommandotext) + FI . + +perhaps simple up or down : + IF t1 = bold + THEN TEXT VAR s3; INT VAR t3; next symbol (s3, t3); + IF t3 <> end of file THEN FALSE + ELIF s1 = "U" THEN perhaps simple up + ELIF s1 = "D" THEN perhaps simple down + ELSE FALSE + FI + ELSE FALSE + FI . + +perhaps simple up : + IF t2 = string THEN up (s2); TRUE + ELIF t2 = integer THEN up (int (s2)); TRUE + ELSE FALSE + FI . + +perhaps simple down : + IF t2 = string THEN down (s2); TRUE + ELIF t2 = integer THEN down (int (s2)); TRUE + ELSE FALSE + FI . + +perhaps simple changeto : + IF t1 = string AND s2 = "C" AND t3 is string AND t4 is eof + THEN s1 C s3; TRUE + ELSE FALSE + FI . + +t3 is string : + next symbol (s3, t3); + t3 = string . + +t4 is eof : + TEXT VAR s4; INT VAR t4; + next symbol (s4, t4); + t4 = end of file . +END PROC std kommando interpreter; + + +PROC edit (FILE VAR f) : + enable stop; + IF aktueller editor > 0 (*wk*) + THEN ueberschrift neu + FI ; + open editor (f, write acc); + edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter) +END PROC edit; + + +PROC edit (FILE VAR f, INT CONST x, y, x size, y size) : + enable stop; + open editor (groesster editor + 1, f, write acc, x, y, x size, y size); + edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter) +END PROC edit; + + +PROC edit (FILE VAR f, TEXT CONST res, PROC (TEXT CONST) kdo interpreter) : + enable stop; + open editor (f, write acc); + edit (groesster editor, res, PROC(TEXT CONST) kdo interpreter) +END PROC edit; + + +PROC edit : + IF aktueller editor > 0 + THEN dateiname einlesen; + edit (dateiname) + ELSE edit (last param) + FI . + +dateiname einlesen : + INT VAR x, y; get editcursor (x, y); + IF x < x size - 17 (*sh*) + THEN cursor (x, y); + out (""15"Dateiname:"14""); + (x size-14-x) TIMESOUT " "; + (x size-14-x) TIMESOUT ""8""; + TEXT VAR dateiname := std; + editget (dateiname); + trailing blanks entfernen; + quotes entfernen + ELSE errorstop ("Fenster zu klein") + FI . + +trailing blanks entfernen: + INT VAR i := LENGTH dateiname; + WHILE (dateiname SUB i) = " " REP i DECR 1 PER; + dateiname := subtext (dateiname, 1, i) . + +quotes entfernen : + IF (dateiname SUB 1) = """" AND (dateiname SUB LENGTH dateiname) = """" + THEN dateiname := subtext (dateiname, 2, LENGTH dateiname - 1) + FI . +END PROC edit; + + +PROC edit (TEXT CONST filename) : + IF filename <> "" + THEN edit named file + ELSE errorstop ("Name ungueltig") + FI . + +edit named file : + last param (filename); + IF exists (filename) COR yes ("""" + filename + """ neu einrichten") + THEN IF aktueller editor > 0 THEN ueberschrift neu FI; (*sh*) + FILE VAR f := sequential file (modify, filename); + headline (f, filename); edit (f); last param (filename) + ELSE errorstop ("") + FI . +END PROC edit; + + +PROC edit (TEXT CONST filename, INT CONST x, y, x size, y size) : + last param (filename); + IF exists (filename) COR yes ("""" + filename + """ neu einrichten") + THEN FILE VAR f := sequential file (modify, filename); + headline (f, filename); edit (f, x, y, x size, y size); + last param (filename) + ELSE errorstop ("") + FI +END PROC edit; + + +PROC edit (INT CONST i) : + edit (i, std res, PROC (TEXT CONST) std kommando interpreter) +END PROC edit; + + +PROC show (FILE VAR f) : + enable stop; + open editor (f, read acc); + edit(groesster editor, std res, PROC(TEXT CONST) std kommando interpreter); +END PROC show; + + +PROC show (TEXT CONST filename) : (*sh*) + last param (filename); + IF exists (filename) + THEN FILE VAR f := sequential file (modify, filename); + show (f); last param (filename) + ELSE errorstop ("""" + filename + """ gibt es nicht") + FI +END PROC show; + + +PROC show : + show (last param) +END PROC show; + + +DATASPACE VAR local space; +INT VAR zeilenoffset; +TEXT VAR kopierzeile; + + +OP PUT (TEXT CONST filename) : + nichts neu; + IF mark + THEN markierten bereich in datei schreiben + FI . + +markierten bereich in datei schreiben : + disable stop; + zieldatei vorbereiten; + quelldatei oeffnen; + IF noch genuegend platz in der zieldatei (*sh*) + THEN zeilenweise kopieren + ELSE errorstop ("FILE-Ueberlauf") + FI ; + quelldatei schliessen; + zieldatei schliessen; + set busy indicator . + +zieldatei vorbereiten : + FRANGE VAR ganze zieldatei; + IF exists (filename) THEN forget (filename); ueberschrift neu FI; + FILE VAR destination; + IF filename = "" + THEN forget (local space); local space := nilspace; + destination := sequential file (output, local space) + ELSE destination := sequential file (modify, filename) ; + INT CONST groesse der zieldatei := lines (destination); (*sh*) + set marked range (destination, ganze zieldatei) ; + output (destination) + FI . + +quelldatei oeffnen : + zeilenoffset := mark line no (edfile) - 1; + INT CONST old line := line no, old col := col; + FRANGE VAR ganze datei; + set range (edfile, mark lineno (edfile), mark col (edfile), ganze datei); + input (edfile) . + +noch genuegend platz in der zieldatei : + lines + groesse der zieldatei < file size . + +zeilenweise kopieren : + enable stop; + satznr neu; + INT VAR zeile; + FOR zeile FROM 1 UPTO lines (edfile) REP + getline (edfile, kopierzeile); + putline (destination, kopierzeile); + satznr zeigen + PER . + +quelldatei schliessen : + modify (edfile); + set range (edfile, ganze datei); + to line (old line); + col (old col) . + +zieldatei schliessen : + IF filename <> "" + THEN INT CONST last line written := line no (destination) ; + modify (destination) ; + to line (destination, last line written) ; + col (destination, len (destination) + 1) ; + bild neu (destination) ; + set range (destination, ganze zieldatei) + FI . +END OP PUT; + + +OP P (TEXT CONST filename) : + PUT filename +END OP P ; + + +OP GET (TEXT CONST filename) : (*sh*) + IF NOT write permission + THEN errorstop ("Schreibversuch auf 'show'-Datei") + FI ; + quelldatei oeffnen; + IF nicht mehr genuegend platz im editfile + THEN quelldatei schliessen; errorstop ("FILE-Ueberlauf") + FI ; + disable stop; + zieldatei oeffnen; + zeilenweise kopieren ; + zieldatei schliessen; + quelldatei schliessen; + set busy indicator . + +quelldatei oeffnen : + FILE VAR source; + FRANGE VAR ganze quelldatei; + IF filename = "" + THEN source := sequential file (input, local space) + ELSE IF NOT exists (filename) + THEN errorstop ("""" + filename + """ gibt es nicht") + FI ; + source := sequential file (modify, filename); + INT CONST old line := line no (source), + old col := col (source); + set marked range (source, ganze quelldatei); + input (source) + FI . + +nicht mehr genuegend platz im editfile : + lines (source) + lines >= file size . + +zeilenweise kopieren : + enable stop; + satznr neu; + INT VAR zeile; + FOR zeile FROM 1 UPTO lines (source) REP + getline (source, kopierzeile); + putline (edfile, kopierzeile); + satznr zeigen + PER . + +zieldatei oeffnen : + zeilenoffset := line no - 1; + leere datei in editfile einschachteln; + output (edfile) . + +leere datei in editfile einschachteln : + INT CONST range start col := col; + FRANGE VAR ganze datei; + set range (edfile, line no, col, ganze datei); + IF lines = 1 THEN delete record (edfile) FI . + +quelldatei schliessen : + IF filename <> "" + THEN modify (source); + set range (source, ganze quelldatei); + to line (source, old line); + col (source, old col) + FI . + +zieldatei schliessen : + modify (edfile); + to line (lines); + col (range start col); + set range (edfile, ganze datei); + abschnitt neu (zeilenoffset + 1, lines) . +END OP GET; + + +OP G (TEXT CONST filename) : + GET filename +END OP G; + + +INT PROC len : + len (edfile) +END PROC len; + + +PROC col (INT CONST stelle) : + nichts neu; col (edfile, stelle) +END PROC col; + + +INT PROC col : + col (edfile) +END PROC col; + + +PROC limit (INT CONST limit) : + nichts neu; max line length (edfile, limit) +END PROC limit; + + +INT PROC limit : + max line length (edfile) +END PROC limit; + + +INT PROC lines : + lines (edfile) +END PROC lines; + + +INT PROC line no : + line no (edfile) +END PROC line no; + + +PROC to line (INT CONST satz nr) : + satznr neu; + edfile := editfile; + IF satz nr > lines + THEN toline (edfile, lines); col (len + 1) + ELSE to line (edfile, satz nr) + FI +END PROC to line; + + +OP T (INT CONST satz nr) : + to line (satz nr) +END OP T; + + +PROC down (INT CONST anz) : + nichts neu; down (edfile, anz) +END PROC down; + + +OP D (INT CONST anz) : + down (anz) +END OP D; + + +PROC up (INT CONST anz) : + nichts neu; up (edfile, anz) +END PROC up; + + +OP U (INT CONST anz) : + up (anz) +END OP U; + + +PROC down (TEXT CONST muster) : + nichts neu; + REP + down (muster, schritt - line no MOD schritt); + IF pattern found + THEN LEAVE down + ELSE satznr zeigen + FI + UNTIL eof PER +END PROC down; + + +OP D (TEXT CONST muster) : + down (muster) +END OP D; + + +PROC down (TEXT CONST muster, INT CONST anz) : + nichts neu; down (edfile, muster, anz) +END PROC down; + + +PROC up (TEXT CONST muster) : + nichts neu; + REP + up (muster, (line no - 1) MOD schritt + 1); + IF pattern found + THEN LEAVE up + ELSE satznr zeigen + FI + UNTIL line no = 1 PER +END PROC up; + + +OP U (TEXT CONST muster) : + up (muster) +END OP U; + + +PROC up (TEXT CONST muster, INT CONST anz) : + nichts neu; up (edfile, muster, anz) +END PROC up; + + +PROC downety (TEXT CONST muster) : + nichts neu; + IF NOT at (muster) + THEN down (muster) + FI +END PROC downety; + + +PROC downety (TEXT CONST muster, INT CONST anz) : + nichts neu; downety (edfile, muster, anz) +END PROC downety; + + +PROC uppety (TEXT CONST muster) : + nichts neu; + IF NOT at (muster) + THEN up (muster) + FI +END PROC uppety; + + +PROC uppety (TEXT CONST muster, INT CONST anz) : + nichts neu; uppety (edfile, muster, anz) +END PROC uppety; + + +OP C (TEXT CONST old, new) : + change to (old, new) +END OP C; + +OP C (TEXT CONST replacement) : + IF NOT write permission (*sh*) + THEN errorstop ("Schreibversuch auf 'show'-Datei") + FI ; + IF at (edfile, match(0)) + THEN zeile neu; change (edfile, matchpos(0), matchend(0), replacement) + FI +END OP C; + +PROC change to (TEXT CONST old, new) : + IF NOT write permission (*sh*) + THEN errorstop ("Schreibversuch auf 'show'-Datei") + FI ; + nichts neu; + REP + downety (old, schritt - line no MOD schritt); + IF pattern found + THEN change (edfile, matchpos(0), matchend(0), new); + col (col + LENGTH new); zeile neu; + LEAVE changeto + ELSE satznr zeigen + FI + UNTIL eof PER +END PROC change to; + + +OP CA (TEXT CONST old, new) : + change all (old, new) +END OP CA; + + +PROC change all (TEXT CONST old, new) : + WHILE NOT eof REP old C new PER +END PROC change all; + + +BOOL PROC eof : + eof (edfile) +END PROC eof; + + +BOOL PROC mark : + mark (edfile) +END PROC mark; + + +PROC mark (BOOL CONST mark on) : + nichts neu; + IF mark on + THEN mark (edfile, line no, col) + ELSE mark (edfile, 0, 0) + FI +END PROC mark; + + +BOOL PROC at (TEXT CONST pattern) : + at (edfile, pattern) +END PROC at; + +TEXT PROC word : + word (edfile) +END PROC word; + + +TEXT PROC word (TEXT CONST sep) : + word (edfile, sep) +END PROC word; + + +TEXT PROC word (INT CONST len) : + word (edfile, len) +END PROC word; + + +LET no access = 0, + edit access = 1, + output access = 2; + +INT VAR last note file mode; +FILE VAR notebook; +INITFLAG VAR this packet := FALSE; +DATASPACE VAR note ds; + + +PROC note (TEXT CONST text) : + access note file (output access); + write (notebook, text) +END PROC note; + + +PROC note (INT CONST number) : + access note file (output access); + put (notebook, number) +END PROC note; + + +PROC note line : + access note file (output access); + line (notebook) +END PROC note line; + + +BOOL PROC anything noted : + access note file (no access); + last note file mode = output access +END PROC anything noted; + + +FILE PROC note file : + access note file (output access); + notebook +END PROC note file; + + +PROC note edit (FILE VAR context) : (*sh*) + access note file (edit access); + make notebook erasable; + IF aktueller editor = 0 + THEN open editor (1, context, write acc, 1, 1, x size - 1, y size) + FI ; + get window size; + IF window large enough + THEN include note editor; + edit (aktueller editor-1, aktueller editor, aktueller editor-1, + std res, PROC (TEXT CONST) std kommando interpreter) + FI . + +get window size : + INT VAR x, y, windows x size, windows y size; + get window (x, y, windows x size, windows y size) . + +window large enough : + windows y size > 4 . + +include note editor : + open editor (aktueller editor + 1, notebook, write acc, + x, y + (windows y size + 1) DIV 2, + windows x size, windows y size DIV 2) . + +make notebook erasable : + last note file mode := edit access . +END PROC note edit; + + +PROC note edit : + access note file (edit access); + make notebook erasable; + edit (notebook) . + +make notebook erasable : + last note file mode := edit access . +END PROC note edit; + + +PROC access note file (INT CONST new mode) : + disable stop; + initialize note ds if necessary; + IF last note file mode < new mode + THEN forget (note ds); + note ds := nilspace; + notebook := sequential file (output, note ds); + headline (notebook, "notebook"); + last note file mode := new mode + FI . + +initialize note ds if necessary : + IF NOT initialized (this packet) + THEN note ds := nilspace; + last note file mode := no access + FI . +END PROC access note file; + +END PACKET editor functions; + diff --git a/system/base/1.7.5/src/init b/system/base/1.7.5/src/init new file mode 100644 index 0000000..471a717 --- /dev/null +++ b/system/base/1.7.5/src/init @@ -0,0 +1,251 @@ + "run again impossible" + "recursive run" + " " + " Compiler Error : " +" " +" |" +" Fehler entdeckt " +"Keine Fehler gefunden, " +" " +" ******* ENDE DER UEBERSETZUNG *******" +"FEHLER bei >> " +" << " +"weiter bei " +"TEXTende (Anfuehrungszeichen) fehlt irgendwo" +"Kommentarende fehlt irgendwo" +"nach dem Hauptprogramm darf kein Paket folgen" +"ungueltiger Name fuer ein DEFINES-Objekt" +"':' fehlt" +"nach ENDPACKET folgt nicht der Paketname" +"ENDPACKET fehlt" +"CONST oder VAR fehlt" +"ungueltiger Name" +" ',' in Deklarationsliste fehlt" +"ist nicht der PROC Name" +"fehlerhaftes Ende des Hauptprogramms" +"ENDPROC fehlt" +"PROC/OP Schachtelung unzulaessig" +"OP darf kein Parameter sein" +"steht mehrfach im PACKET Interface" +" ist mehrfach deklariert" +"ist schon als Datenobjekt deklariert" +"ist schon als PROC/OP deklariert" +"')' nach Parameterliste erwartet" +"Standard-Schluesselwort kann nicht redefiniert werden" +"ungueltig als BOLD" +"'(' fehlt" +"CONST bzw VAR nicht bei Strukturfeldern" +"'=' fehlt" +"Schluesselwort wird im Paket schon andersartig verwandt" +"Datentyp fehlt" +"ungueltiger OP Name" +"OP muss monadisch oder dyadisch sein" +"ist nicht der OP Name" +"ENDOP fehlt" +"Name nach ENDPROC fehlt" +"Name nach ENDOP fehlt" +"';' fehlt" +"END END ist Unsinn" +"Dieses END... kenne ich nicht" +"ROW Groesse ist kein INT" +"ROW Groesse ist kein Denoter" +"Ein ROW muss mindestens ein Element haben" +"ROW Groesse fehlt" +"Parameter kann man nicht initialisieren" +"Konstanten muessen initialisiert werden" +"'::' verwenden" +"')' fehlt" +"Exponent fehlt" +"Undefinierter Typ" +"Rekursiv definierter Typ" +"Mehrfach definierter Selektor" +"Variable bzw. Abkuerzung in der Paket-Schnittstelle" +"undefinierte ROW Groesse" +"Typ Deklarationen nur im Paketrumpf" +"CONST bzw. VAR ohne Zusammenhang" +"ist nicht deklariert, steht aber in der Paket-Schnittstelle" +"ist nicht deklariert" +"unbekanntes Kommando" +"THIS IS NO CORRECT EXTERNAL NUMBER." +"Schluesselwort unzulaessig" +"Name erwartet" +"Denoter erwartet" +"ENDPROC ohne Zusammenhang" +"ENDOP ohne Zusammenhang" +"Refinement ohne Zusammenhang" +"Delimiter zwischen Paket-Refinement und Deklaration fehlt" +"unzulaessiges Selektor-Symbol (kein Name)" +"BOUND Schachtelungen unzulaessig" +"BOUND-Objekte unzulaessig als Parameter" +"Textende fehlt" +"TEXT-Denoter zu lang" + +"Denoter-Wert wird fuer diese Maschine zu gross" +"Compiler-Fehler, wenden Sie sich an Ihren Systemberater!" +"ist ein zusammenhangloses Schluesselwort" +"'::' nur fuer Initialisierungen, sonst ':='" +"welches Objekt soll verlassen werden?" +"du bist gar nicht innerhalb dieses Refinements" +"nur die eigene PROC / OP kann verlassen werden" +"THEN fehlt" +"FI fehlt" +"BOOL-Ausdruck erwartet" +"ELSE-Teil ist notwendig, da ein Wert geliefert wird" +"INT-Ausdruck erwartet" +"OF fehlt" +"Keine Typanpassung moeglich" +"CASE-Label fehlt" +"mindestens eine CASE-Anweisung geben" +"CASE-Label ist zu gross (skipped)" +"mehrfach definiertes CASE-Label" +"ungueltiges Zeichen nach CASE-Label" +"OTHERWISE-Teil fehlt" +"END SELECT fehlt" +"rekursiver Aufruf eines Refinements" +" wird nicht benutzt" +"';' oder Operator ('+','-',...) fehlt" +"undefinierter monadischer Operator" +"undefinierter dyadischer Operator" +"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen" +"fuer diesen Typ nicht definierter Selektor" +"INT,REAL,BOOL,TEXT koennen nicht selektiert werden" +"bei ROWs nur Subscription" +"nicht selektierbar" +"unzulaessiger Index fuer Subscription" +"'[' ohne Zusammenhang" +"']' ohne Zusammenhang" +"']' nach Subscription fehlt" +"ungueltig zwischen Anweisungen" +"nur die letzte Anweisung eines Abschnitts darf einen Wert liefern" +"Der Paketrumpf kann keinen Wert liefern" +"anstelle des letzten Symbols wurde ein Operand erwartet" +"Der Schleifenrumpf darf keinen Wert liefern" +"die Laufvariable muss eine INT VAR sein" +"wird schon in einer aeusseren Schleife als Laufvariable benutzt" +"FROM erwartet" +"UPTO bzw DOWNTO fehlt" +"REPEAT fehlt" +"END REP fehlt" +"die Konstante darf nicht veraendert werden" +"in einer FOR-Schleife darf die Laufvariable nicht veraendert werden" +"falscher Typ des Resultats" +"ist CONST, es wird aber ein VAR Parameter verlangt" +"unbekannte Prozedur" +"Parameter-Prozedur liefert falsches Resultat" +"Anzahl bzw. Typen der Parameter sind falsch" +"unbekannte Parameter-Prozedur" +"aktuelle Parameter-Prozedur hat CONST-, formale hat VAR-Parameter" +"Kein Konstruktor moeglich, da die Feinstruktur hier unbekannt ist" +"zu wenig Felder angegeben" +"zu viele Felder angegeben" +"unzulaessiger Trenner zwischen Feldern" +"Feld hat falschen Typ" +"falsche Element-Anzahl im ROW-Konstruktor" +"Dieser Typ kann nicht noch mehr konkretisiert werden" +"BOUND-Objekt zu gross" + +"Warnung in Zeile " +" Zeile " +"in Zeile " +" <----+---> " +" TYPE undefiniert " +" MODE undefiniert " +"Parameter spezifiziert: " +"Parameter Typ(en) sind: " +" B Code, " +" B Paketdaten generiert" +"Operand: " +"Operanden: " +", " +"erwartet " +"gefunden " +" " + +(* 001 *) END +(* 002 *) ENDPACKET +(* 003 *) ENDOP +(* 004 *) ENDOPERATOR +(* 005 *) ENDPROC +(* 006 *) ENDPROCEDURE +(* 007 *) PACKET +(* 008 *) OP +(* 009 *) OPERATOR +(* 010 *) PROC +(* 011 *) PROCEDURE +(* 012 *) FI +(* 013 *) ENDIF +(* 014 *) ENDREP +(* 015 *) ENDREPEAT +(* 016 *) PER +(* 017 *) ELIF +(* 018 *) ELSE +(* 019 *) UNTIL +(* 020 *) CASE +(* 021 *) OTHERWISE +(* 022 *) ENDSELECT +(* 023 *) INTERNAL +(* 024 *) DEFINES +(* 025 *) LET +(* 026 *) TYPE +(* 027 *) INT +(* 028 *) REAL +(* 029 *) DATASPACE +(* 030 *) TEXT +(* 031 *) BOOL +(* 032 *) BOUND +(* 033 *) ROW +(* 034 *) STRUCT +(* 035 *) CONST +(* 036 *) VAR +(* 037 INIT CONTROL *) INTERNAL +(* 038 *) CONCR +(* 039 *) REP +(* 040 *) REPEAT +(* 041 *) SELECT +(* 042 *) EXTERNAL +(* 043 *) IF +(* 044 *) THEN +(* 045 *) OF +(* 046 *) FOR +(* 047 *) FROM +(* 048 *) UPTO +(* 049 *) DOWNTO +(* 050 *) WHILE +(* 051 *) LEAVE +(* 052 *) WITH +(* 053 *) TRUE +(* 054 *) FALSE +(* 055 *) :: SBL := INCR DECR +(* 056 *) + - * / DIV MOD + ** + AND + CAND + OR + COR + NOT + = <> > >= < <= +(*040 *) MAIN +(*043*) ENDOFFILE + +PACKET a : + +PROC out (TEXT CONST t) : + EXTERNAL 60 +ENDPROC out ; + +PROC out text (TEXT CONST t, INT CONST typ) : + INTERNAL 257 ; + IF typ = typ + THEN out (t) + FI +ENDPROC out text ; + +PROC out line (INT CONST typ) : + INTERNAL 258 ; + IF typ = typ + THEN out (""13""10"") + FI +ENDPROC out line ; + +ENDPACKET a ; + diff --git a/system/base/1.7.5/src/integer b/system/base/1.7.5/src/integer new file mode 100644 index 0000000..aefb77f --- /dev/null +++ b/system/base/1.7.5/src/integer @@ -0,0 +1,265 @@ +(* ------------------- STAND : 23.10.85 --------------------*) +PACKET integer DEFINES text, int, MOD, + sign, SIGN, abs, ABS, **, min, max, minint, maxint, + random, initialize random , + last conversion ok, set conversion : + +INT PROC minint : -32767 - 1 ENDPROC minint ; + +INT PROC maxint : 32767 ENDPROC maxint ; + + +TEXT PROC text (INT CONST number) : + + IF number = minint THEN "-32768" + ELIF number < 0 THEN "-" + text(-number) + ELIF number <= 9 THEN code (number + 48) + ELSE text (number DIV 10) + digit + FI . + +digit : + code ( number MOD 10 + 48 ) . + +ENDPROC text ; + +TEXT PROC text (INT CONST number, length) : + + TEXT VAR result := text (number) ; + INT CONST number length := LENGTH result ; + IF number length < length + THEN (length - number length) * " " + result + ELIF number length > length + THEN length * "*" + ELSE result + FI + +ENDPROC text ; + +INT PROC int (TEXT CONST number) : + + skip blanks and sign ; + get value ; + result . + +skip blanks and sign : + BOOL VAR number is positive ; + INT VAR pos := 1 ; + skip blanks ; + IF (number SUB pos) = "-" + THEN number is positive := FALSE ; + pos INCR 1 + ELIF (number SUB pos) = "+" + THEN number is positive := TRUE ; + pos INCR 1 + ELSE number is positive := TRUE + FI . + +get value : + INT VAR value ; + get first digit ; + WHILE is digit REP + value := value * 10 + digit ; + pos INCR 1 + PER ; + set conversion ok result . + +get first digit : + IF is digit + THEN value := digit ; + pos INCR 1 + ELSE set conversion (FALSE) ; + LEAVE int WITH 0 + FI . + +is digit : 0 <= digit AND digit <= 9 . + +digit : code (number SUB pos) - 48 . + +result : + IF number is positive + THEN value + ELSE - value + FI . + +set conversion ok result : + skip blanks ; + conversion ok := (pos > LENGTH number) . + +skip blanks : + WHILE (number SUB pos) = " " REP + pos INCR 1 + PER . + +ENDPROC int ; + +INT OP MOD (INT CONST left, right) : + + EXTERNAL 43 + +ENDOP MOD ; + +INT PROC sign (INT CONST argument) : + + IF argument < 0 THEN -1 + ELIF argument > 0 THEN 1 + ELSE 0 + FI + +ENDPROC sign ; + +INT OP SIGN (INT CONST argument) : + sign (argument) +ENDOP SIGN ; + +INT PROC abs (INT CONST argument) : + + IF argument > 0 THEN argument + ELSE - argument + FI + +ENDPROC abs ; + +INT OP ABS (INT CONST argument) : + abs (argument) +ENDOP ABS ; + +INT OP ** (INT CONST arg, exp) : + + INT VAR x := arg , z := 1 , + counter := exp ; + + IF exp = 0 + THEN LEAVE ** WITH 1 + ELIF exp < 0 + THEN LEAVE ** WITH 1 DIV arg + FI ; + + WHILE counter >= 2 REP + calculate new x and z ; + counter := counter DIV 2 ; + ENDREP ; + z * x . + +calculate new x and z : + IF counter is not even + THEN z := z * x + FI ; + x := x * x . + +counter is not even : + counter MOD 2 = 1 . + +ENDOP ** ; + +INT PROC min (INT CONST first, second) : + + IF first < second THEN first ELSE second FI + +ENDPROC min ; + +INT PROC max (INT CONST first, second) : + + IF first > second THEN first ELSE second FI + +ENDPROC max ; + + + +BOOL VAR conversion ok := TRUE ; + +BOOL PROC last conversion ok : + conversion ok +ENDPROC last conversion ok ; + +PROC set conversion (BOOL CONST success) : + conversion ok := success +ENDPROC set conversion ; + + + +(*******************************************************************) +(* *) +(* Autor: A. Flammenkamp *) +(* RANDOM GENERATOR *) +(* *) +(* x := 4095 * x MOD (4095*4096+4093) *) +(* n+1 n *) +(* *) +(* Periode: 2**24-4 > 16.0e6 *) +(* *) +(* Beachte: x = 4096 * x1 + x0, 0 <= x0,x1 < 4096 *) +(* *) +(*******************************************************************) + + +INT VAR high := 1, low := 0 ; + +PROC initialize random (INT CONST start) : + + low := start MOD 4096 ; + IF start < 0 + THEN high := 256 + 16 + start DIV 4096 ; + IF low <> 0 THEN high DECR 1 FI + ELSE high := 256 + start DIV 4096 + FI + +ENDPROC initialize random ; + +INT PROC random (INT CONST lower bound, upper bound) : + + compute new random value ; + normalize high ; + normalize low ; + map into interval . + +compute new random value : + (* (high,low) := (low-high , 3*high-low) *) + high := low - high ; + low INCR low - 3 * high . + +normalize high : + IF high < 0 + THEN high INCR 4096 ; low DECR 3 + FI . + +normalize low : + (* high INCR low DIV 4096 ; + low := low MOD 4096 + *) + IF low >= 4096 THEN low overflow + ELIF low < 0 THEN low underflow + FI . + +low overflow : + IF low >= 8192 + THEN low DECR 8192 ; high INCR 2 + ELSE low DECR 4096 ; high INCR 1 ; post normalization + FI . + +post normalization : + (* IF (high,low) >= (4095,4093) + THEN (high,low) DECR (4095,4093) + FI + *) + IF high >= 4095 + THEN IF low >= 4093 THEN high DECR 4095 ; low DECR 4093 + ELIF high = 4096 THEN high := 0 ; low INCR 3 + FI + FI . + +low underflow : + low INCR 4096 ; high DECR 1 . + +map into interval : + INT VAR number := high MOD 16 - 8 ; + number INCR 4095 * number + low ; + IF lower bound <= upper bound + THEN lower bound + number MOD (upper bound - lower bound + 1) + ELSE upper bound + number MOD (lower bound - upper bound + 1) + FI . + +ENDPROC random ; + + +ENDPACKET integer ; + diff --git a/system/base/1.7.5/src/local manager b/system/base/1.7.5/src/local manager new file mode 100644 index 0000000..48d024b --- /dev/null +++ b/system/base/1.7.5/src/local manager @@ -0,0 +1,373 @@ +(* ------------------- VERSION 2 24.02.86 ------------------- *) +PACKET local manager (* Autor: J.Liedtke *) + + DEFINES + create, (* neue lokale Datei einrichten *) + new, (* 'create' und Datei liefern *) + old, (* bestehende Datei liefern *) + forget, (* lokale Datei loeschen *) + exists, (* existiert Datei (lokal) ? *) + status, (* setzt und liefert Status *) + rename, (* Umbenennung *) + copy , (* Datenraum in Datei kopieren *) + enter password,(* Passwort einfuehren *) + write password , + read password , + write permission , + read permission , + begin list , + get list entry , + all : + + + +LET size = 200 , + nil = 0 ; + +INT VAR index ; + +TEXT VAR system write password := "" , + system read password := "" , + actual password ; + +INITFLAG VAR this packet := FALSE ; + +DATASPACE VAR password space ; + +BOUND ROW size STRUCT (TEXT write, read) VAR passwords ; + + +THESAURUS VAR dir := empty thesaurus ; + +ROW size STRUCT (DATASPACE ds, + BOOL protected, + TEXT status) VAR crowd ; + + +PROC initialize if necessary : + + IF NOT initialized (this packet) + THEN system write password := "" ; + system read password := "" ; + dir := empty thesaurus ; + password space := nilspace ; + passwords := password space + FI + +ENDPROC initialize if necessary ; + + + +PROC create (TEXT CONST name) : + +IF exists (name ) + THEN error (name, "existiert bereits") ; + index := nil + ELSE insert and initialize entry +FI . + +insert and initialize entry : + disable stop ; + insert (dir, name, index) ; + IF index <> nil + THEN crowd (index).ds := nilspace ; + IF is error + THEN delete (dir, name, index) ; + LEAVE create + FI ; + status (name, "") ; + crowd (index).protected := FALSE + ELIF NOT is error + THEN errorstop ("zu viele Dateien") + FI . + +ENDPROC create ; + +DATASPACE PROC new (TEXT CONST name) : + + create (name) ; + IF index <> nil + THEN crowd (index).ds + ELSE nilspace + FI + +ENDPROC new ; + +DATASPACE PROC old (TEXT CONST name) : + + initialize if necessary ; + index := link (dir, name) ; + IF index = 0 + THEN error (name, "gibt es nicht") ; + nilspace + ELSE space + FI . + +space : crowd (index).ds . + +ENDPROC old ; + +DATASPACE PROC old (TEXT CONST name, INT CONST expected type) : + + initialize if necessary ; + index := link (dir, name) ; + IF index = 0 + THEN error (name, "gibt es nicht") ; + nilspace + ELIF type (space) <> expected type + THEN errorstop ("Datenraum hat falschen Typ") ; + nilspace + ELSE space + FI . + +space : crowd (index).ds . + +ENDPROC old ; + +BOOL PROC exists (TEXT CONST name) : + + initialize if necessary ; + dir CONTAINS name + +ENDPROC exists ; + +PROC forget (TEXT CONST name ) : + + initialize if necessary ; + say ("""") ; + say (name) ; + IF NOT exists (name) THEN say (""" existiert nicht") + ELIF yes (""" loeschen") THEN forget (name, quiet) + FI . + +ENDPROC forget ; + +PROC forget (TEXT CONST name, QUIET CONST q) : + + initialize if necessary ; + disable stop ; + delete (dir, name, index) ; + IF index <> nil + THEN forget ( crowd (index).ds ) ; + crowd (index).status := "" + FI . + +ENDPROC forget ; + +PROC forget : + + BOOL VAR status := command dialogue ; + command dialogue (TRUE) ; + forget (last param) ; + command dialogue (status) + +ENDPROC forget ; + +PROC status (TEXT CONST name, status text) : + + initialize if necessary ; + INT VAR index := link (dir, name) ; + IF index > 0 + THEN crowd (index).status := date + " " + text (status text, 4) + FI + +ENDPROC status ; + +TEXT PROC status (TEXT CONST name) : + + initialize if necessary ; + INT VAR index := link (dir, name) ; + IF index > 0 + THEN crowd (index).status + ELSE "" + FI + +ENDPROC status ; + +PROC status (INT CONST pos, TEXT CONST status pattern) : + + initialize if necessary ; + INT VAR index := 0 ; + WHILE index < highest entry (dir) REP + index INCR 1 ; + replace (actual status, pos , status pattern) + PER . + +actual status : crowd (index).status . + +ENDPROC status ; + +PROC copy (DATASPACE CONST source, TEXT CONST dest name) : + + IF exists (dest name) + THEN error (dest name, "existiert bereits") + ELSE copy file + FI . + +copy file : + disable stop ; + create ( dest name ) ; + INT VAR index := link (dir, dest name) ; + IF index > nil + THEN forget (crowd (index).ds) ; + crowd (index).ds := source + FI + +ENDPROC copy ; + +PROC copy (TEXT CONST source name, dest name) : + + copy (old (source name), dest name) + +ENDPROC copy ; + +PROC rename (TEXT CONST old name, new name) : + + IF exists (new name) + THEN error (new name, "existiert bereits") + ELIF exists (old name) + THEN rename (dir, old name, new name) ; + last param (new name) + ELSE error (old name, "gibt es nicht") + FI . + +ENDPROC rename ; + + +PROC begin list : + + initialize if necessary ; + index := 0 + +ENDPROC begin list ; + +PROC get list entry (TEXT VAR entry, status text) : + + get (dir, entry, index) ; + IF found + THEN status text := crowd (index).status ; + ELSE status text := "" ; + FI . + +found : index > 0 . + +ENDPROC get list entry ; + + +TEXT PROC write password : + + system write password + +ENDPROC write password ; + +TEXT PROC read password : + + system read password + +ENDPROC read password ; + + +PROC enter password (TEXT CONST password) : + + initialize if necessary ; + say (""3""5"") ; + INT CONST slash pos := pos (password, "/") ; + IF slash pos = 0 + THEN system write password := password ; + system read password := password + ELSE system write password := subtext (password, 1, slash pos-1) ; + system read password := subtext (password, slash pos+1) + FI . + +ENDPROC enter password ; + +PROC enter password (TEXT CONST file name, write pass, read pass) : + + INT CONST index := link (dir, file name) ; + IF index > 0 + THEN set protect password + FI . + +set protect password : + IF write pass = "" AND read pass = "" + THEN crowd (index).protected := FALSE + ELSE crowd (index).protected := TRUE ; + passwords (index).write := write pass ; + passwords (index).read := read pass + FI . + +ENDPROC enter password ; + +INT PROC password index (TEXT CONST file name) : + + initialize if necessary ; + INT CONST index := link (dir, file name) ; + IF index > 0 CAND crowd (index).protected + THEN index + ELSE 0 + FI + +ENDPROC password index ; + +BOOL PROC read permission (TEXT CONST name, supply password) : + + (****************************************************************) + (* for reasons of data security the password check algorithm *) + (* must not copy parts of the file password into variables *) + (* located in the standard dataspace! *) + (****************************************************************) + + access file password ; + file has no password COR (supply password <> "-" AND read password match) . + +read password match : + file password.read = supply password OR file password.read = "" . + +access file password : + INT CONST pw index := password index (name) . + +file password : passwords (pw index) . + +file has no password : pw index = 0 . + +ENDPROC read permission ; + +BOOL PROC write permission (TEXT CONST name, supply password) : + + (****************************************************************) + (* for reasons of data security the password check algorithm *) + (* must not copy parts of the file password into variables *) + (* located in the standard dataspace! *) + (****************************************************************) + + access file password ; + file has no password COR (supply password <> "-" AND write password match). + +write password match : + file password.write = supply password OR file password.write = "" . + +access file password : + INT CONST pw index := password index (name) . + +file password : passwords (pw index) . + +file has no password : pw index = 0 . + +ENDPROC write permission ; + +THESAURUS PROC all : + + initialize if necessary ; + THESAURUS VAR result := dir ; (*ueberfluessig ab naechstem Compiler *) + result + +ENDPROC all ; + +PROC error (TEXT CONST file name, error text) : + + errorstop ("""" + file name + """ " + error text) + +ENDPROC error ; + +ENDPACKET local manager ; + diff --git a/system/base/1.7.5/src/local manager 2 b/system/base/1.7.5/src/local manager 2 new file mode 100644 index 0000000..8f70301 --- /dev/null +++ b/system/base/1.7.5/src/local manager 2 @@ -0,0 +1,41 @@ + +PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *) + (* Stand: 25.02.85 *) + list : + + +TEXT VAR file name, status text; + + +PROC list : + + disable stop ; + DATASPACE VAR ds := nilspace ; + FILE VAR list file := sequential file (output, ds) ; + headline (list file, "list") ; + list (list file) ; + show (list file) ; + forget (ds) . + +ENDPROC list ; + +PROC list (FILE VAR f) : + + enable stop ; + begin list ; + putline (f, "") ; + REP + get list entry (file name, status text) ; + IF file name = "" + THEN LEAVE list + FI ; + write (f, status text + " """ ) ; + write (f, file name) ; + write (f, """") ; + line (f) + PER . + +ENDPROC list ; + +ENDPACKET local manager part 2 ; + diff --git a/system/base/1.7.5/src/mathlib b/system/base/1.7.5/src/mathlib new file mode 100644 index 0000000..c726495 --- /dev/null +++ b/system/base/1.7.5/src/mathlib @@ -0,0 +1,268 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PACKET mathlib DEFINES sqrt, **, exp, ln, log2, log10, e, pi, + sin, cos, tan, sind, cosd, tand, + arctan, arctand, random, initializerandom : + +LET pii = 3.141592653589793238462, + pi2 = 1.570796326794896619231, + pi3 = 1.047197551196597746154, + pi6 = 0.523598775598298873077, + pi4 = 1.273239544735162686151, + ln2 = 0.693147180559945309417, + lg2 = 0.301029995663981195213, + ln10 = 2.302585092994045684018, + lge = 0.434294481903251827651, + ei = 2.718281828459045235360, + pi180 = 57.295779513082320876798, + sqrt3 = 1.732050807568877293527, + sqr3 = 0.577350269189625764509, + sqr3p2= 3.732050807568877293527, + sqr3m2= 0.267949192431122706473, + sqr2 = 0.707106781186547524400; + +REAL VAR rdg::0.4711; + +REAL PROC pi: pii END PROC pi; +REAL PROC e : ei END PROC e; + +REAL PROC ln ( REAL CONST x ): + log2(x) * ln2 +END PROC ln; + +REAL PROC log10( REAL CONST x ): + log2(x) * lg2 +END PROC log10; + +REAL PROC log2 ( REAL CONST z ): + REAL VAR t, summe::0.0, x::z; + IF x=1.0 THEN 0.0 + ELIF x>0.0 THEN normal + ELSE errorstop("log2: " + text (x,20)); 0.0 FI. + +normal: + IF x >= 0.5 THEN normalise downwards + ELSE normalise upwards FI; + IF x < sqr2 THEN summe := summe - 0.75; t := trans8 + ELSE summe := summe - 0.25; t := trans2 FI; + summe + reihenentwicklung. + + normalise downwards: + WHILE x >= 8.0 REP x := 0.0625 * x; summe:=summe+4.0 PER; + WHILE x >= 1.0 REP x := 0.5 * x; summe:=summe+1.0 PER. + + normalise upwards: + WHILE x<=0.0625 REP x := 16.0 * x; summe:=summe-4.0 PER; + WHILE x<= 0.5 REP x := 2.0 * x; summe:=summe-1.0 PER. + + trans8: (x - 0.5946035575013605)/(x + 0.5946035575013605). + trans2: (x - 0.8408964152537145)/(x + 0.8408964152537145). + + reihenentwicklung: x := t * t; t * 0.06405572387119384648 * + ((((((3.465*x+4.095)*x+5.005)*x+6.435)*x+9.009)*x+15.015)*x+45.045) +END PROC log2; + +REAL PROC sqrt ( REAL CONST z ): + REAL VAR y0, y1, x::z; + INT VAR p :: decimal exponent(x) DIV 2; + IF p <= -64 THEN 0.0 + ELIF x < 0.0 THEN errorstop("sqrt: " + text (x,20)); 0.0 + ELSE nontrivial FI. + + nontrivial: + set exp (decimal exponent (x) -p-p, x); + IF x<10.0 THEN x := 5.3176703 - 40.760905/( 8.408065 + x ) + ELSE x := 16.81595 - 1288.973 /( 84.08065 + x ) FI; + y0 := x; + set exp (decimal exponent (x) + p, y0); + y1 := 0.5 * ( y0 + z/y0 ); + y0 := 0.5 * ( y1 + z/y1 ); + y1 := 0.5 * ( y0 + z/y0 ); + 0.5 * ( y1 + z/y1 ) +END PROC sqrt; + +REAL PROC exp ( REAL CONST z ): + REAL VAR x::z, a::1.0; BOOL VAR negativ :: x<0.0; + IF negativ THEN x := -x FI; + IF x>292.42830676 + THEN IF NOT negativ THEN errorstop ("REAL-Ueberlauf") FI ; 0.0 + ELIF x<=0.0001 + THEN ( 0.5*z + 1.0 ) * z + 1.0 + ELSE approx + FI. + + approx: + IF x > ln10 + THEN x := lge*x; + a := 1.0; + set exp (int(x), a); + x := frac(x)*ln10 + FI; + IF x >= 2.0 THEN a := 7.389056098930650227230*a; x := x-2.0 FI; + IF x >= 1.0 THEN a := 2.718281828459045235360*a; x := x-1.0 FI; + IF x >= 0.5 THEN a := 1.648721270700128146848*a; x := x-0.5 FI; + IF x >= 0.25 THEN a := 1.284025416687741484073*a; x := x-0.25 FI; + IF x >= 0.125 THEN a := 1.133148453066826316829*a; x := x-0.125 FI; + IF x >= 0.0625THEN a := 1.064494458917859429563*a; x := x-0.0625FI; + a:=a/50.4*(((((((0.01*x+0.07)*x+0.42)*x+2.1)*x+8.4)*x+25.2)*x+50.4)*x+50.4); + IF negativ THEN 1.0/a ELSE a FI . + +ENDPROC exp ; + +REAL PROC tan (REAL CONST x): + IF x < 0.0 THEN - tg( -x * pi4) + ELSE tg( x * pi4) FI +END PROC tan; + +REAL PROC tand (REAL CONST x): + IF x < 0.0 THEN - tg( -x / 45.0) + ELSE tg( x / 45.0) FI +END PROC tand; + +REAL PROC tg (REAL CONST x ): + REAL VAR q::floor(x), s::x-q; INT VAR n; + q := q - floor(0.25*q) * 4.0 ; + IF q < 2.0 + THEN IF q < 1.0 + THEN n:=0; + ELSE n:=1; s := 1.0 - s FI + ELSE IF q < 3.0 + THEN n:=2; + ELSE n:=3; s := 1.0 - s FI + FI; + q := s * s; + q := (((((((((-5.116186989653120e-11*q-5.608325022830701e-10)*q- + 9.526170109403018e-9)*q-1.517906721393745e-7)*q-2.430939946375515e-6)*q- + 3.901461426385464e-5)*q-6.324811612385572e-4)*q-1.076606829172646e-2)*q- + 0.2617993877991508)*q+pi4); + + SELECT n OF + CASE 0 : s/q + CASE 1 : q/s + CASE 2 : -q/s + OTHERWISE : -s/q ENDSELECT . + +END PROC tg; + +REAL PROC sin ( REAL CONST x ): + REAL VAR y, r, q; + IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI; + y := y * pi4; + r := floor(y); + sincos( q+r , y-r ) +END PROC sin; + +REAL PROC sind ( REAL CONST x ): + REAL VAR y, r, q; + IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI; + y := y / 45.0; + r := floor(y); + sincos( q+r , y-r ) +END PROC sind; + +REAL PROC cos ( REAL CONST x ): + REAL VAR y, q; + IF x < 0.0 THEN y := -x ELSE y := x FI; + y := y * pi4; + q := floor(y); + sincos( q+2.0, y-q ) +END PROC cos; + +REAL PROC cosd ( REAL CONST x ): + REAL VAR y, q; + IF x < 0.0 THEN y := -x ELSE y := x FI; + y := y / 45.0; + q := floor(y); + sincos( q+2.0, y-q ) +END PROC cosd; + +REAL PROC sincos ( REAL CONST q, y ): + REAL VAR r :: q - floor( 0.125*q + 0.1 ) * 8.0; + IF r >= 4.0 THEN IF r >= 6.0 THEN IF r >= 7.0 THEN - sin approx(1.0-y) + ELSE - cos approx(y) FI + ELSE IF r >= 5.0 THEN - cos approx(1.0-y) + ELSE - sin approx(y) FI FI + ELSE IF r >= 2.0 THEN IF r >= 3.0 THEN sin approx(1.0-y) + ELSE cos approx(y) FI + ELSE IF r >= 1.0 THEN cos approx(1.0-y) + ELSE sin approx(y) FI FI FI +END PROC sincos; + +REAL PROC sin approx ( REAL CONST x ): + REAL VAR z::x*x; + x*((((((0.6877101540593035e-11*z-0.1757149296873372e-8)*z+0.3133616216672568 + e-6)*z-0.3657620415845891e-4)*z+0.2490394570188737e-2)*z-0.807455121882e-1)* + z+0.7853981633974483) +END PROC sin approx; + +REAL PROC cos approx ( REAL CONST x ): + REAL VAR z::x*x; + ((((((-0.3857761864560276e-12*z+0.115004970178141e-9)*z-0.246113638267419e-7 + )*z+0.3590860445885748e-5)*z-0.3259918869266875e-3)*z+0.1585434424381541e-1) + *z-0.3084251375340425)*z+1.0 +END PROC cos approx; + +REAL PROC arctan ( REAL CONST y ): + REAL VAR f, z, x; BOOL VAR neg :: y < 0.0; + IF neg THEN x := -y ELSE x := y FI; + IF x>1.0 THEN f := a ELSE f := -b; neg := NOT neg FI; + z := x * x; + x := x/(((((((0.0107090276046822*z-0.01647757182108040)*z + +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z + -0.0888888888888888)*z+0.3333333333333333)*z+1.0); + IF neg THEN x - f ELSE f - x FI. + + a:IF x>sqr3p2 THEN x := 1.0/x; pi2 ELSE x := 4.0/(sqrt3+x+x+x)-sqr3; pi3 FI. + b:IF x<sqr3m2 THEN 0.0 ELSE x := sqrt3 - 4.0/(sqrt3+x); pi6 FI +END PROC arctan; + +REAL PROC arctand ( REAL CONST x ): + arctan(x) * pi180 +END PROC arctand; + +REAL OP ** ( REAL CONST b, e ): + IF b=0.0 + THEN IF e=0.0 THEN 1.0 ELSE 0.0 FI + ELIF b < 0.0 + THEN errorstop("("+text(b,20)+") ** "+text(e)); (-b) ** e + ELSE exp( e * log2( b ) * ln2 ) + FI +END OP **; + +REAL OP ** ( REAL CONST a, INT CONST b ) : + + REAL VAR p := 1.0 , + r := a ; + INT VAR n := ABS b , + m ; + IF (a = 0.0 OR a = -0.0) + THEN IF b = 0 + THEN 1.0 + ELSE 0.0 + FI + ELSE WHILE n>0 REP + m := n DIV 2 ; + IF m + m = n + THEN n := m ; + r := r*r + ELSE n DECR 1 ; + p := p*r + FI + END REP ; + IF b>0 + THEN p + ELSE 1.0 / p + FI + FI . + +END OP ** ; + +REAL PROC random: + rdg:=rdg+pii;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg +END PROC random; + +PROC initializerandom ( REAL CONST z ): + rdg := frac(z) +END PROC initializerandom; + +END PACKET mathlib; + diff --git a/system/base/1.7.5/src/pattern match b/system/base/1.7.5/src/pattern match new file mode 100644 index 0000000..f6190d8 --- /dev/null +++ b/system/base/1.7.5/src/pattern match @@ -0,0 +1,768 @@ +PACKET pattern match DEFINES (* Author: P.Heyderhoff *) + (* Date: 09.06.1986 *) + -, + OR, + **, + any, + notion, + bound, + match, + matchpos, + matchend, + somefix, + UNLIKE, + LIKE : + +(*------- Operation codes of the internal intermeadiate language: --------*) + +LET + z = ""0"", + stopz = ""1""0"", + closez = ""2""0"", + closor = ""2""0""3""0"", + or = ""3"", + oralpha = ""3""5"", + open2 = ""4""0""4""0"", + alpha = ""5"", + alphaz = ""5""0"", + lenz = ""6""0"", + nilz = ""6""0""0""0""7""0"", (* = any (0) *) + starz = ""7""0"", + star = ""8""0""2""7""0""1""0"", (* = any ** 1 *) + powerz = ""8""0"", + powerz0 = ""8""0""1"", + notionz = ""9""0"", + fullz = ""10""0"", + boundz = ""11""0""; +(*------------------------------------------------------------------------*) + +LET undefined = 0, (* fixleft value *) + forcer = 0, (* vaHue parameter *) + delimiter = " !""#$%&'()*+,-./:;<=>?§^_`Â"; (* for 'PROC notion' *) + +TEXT OP - (TEXT CONST alphabet ): + p:= ""; + INT VAR j; + FOR j FROM 0 UPTO 255 + REP IF pos(alphabet,code(j)) = 0 + THEN p CAT code(j) + FI + PER; + p + ENDOP -; + +TEXT OP OR (TEXT CONST a, b): + open2 + notnil (a) + closor + notnil (b) + closez + ENDOP OR; + +TEXT OP ** (TEXT CONST p, INT CONST x): + powerz + code (1+x) + notnil (p) + stopz + ENDOP **; + +TEXT CONST any:= starz; + +TEXT PROC any (INT CONST n): + TEXT VAR t:= " "; + replace (t, 1, ABSn); + lenz + t + starz + ENDPROC any; + +TEXT PROC any (TEXT CONST a): alphaz + a + starz ENDPROC any; + +TEXT PROC any (INT CONST n, TEXT CONST a): + TEXT VAR t:= " "; + replace (t, 1, ABSn); + lenz + t + alphaz + a + starz + ENDPROC any; + +TEXT PROC notion (TEXT CONST t): notionz + notnil(t) + stopz ENDPROC notion; + +TEXT PROC notnil (TEXT CONST t): + IF t = "" + THEN nilz + ELSE t + FI + ENDPROC notnil; + +TEXT CONST bound := boundz; + +TEXT PROC full (TEXT CONST t): fullz + t + stopz ENDPROC full; + +TEXT PROC match (INT CONST x): + subtext (p, matchpos(x), matchend(x)) + ENDPROC match; + +INT PROC matchpos (INT CONST x): mapos (1 + x MOD 256) ENDPROC matchpos; + +INT PROC matchend (INT CONST x): maend (1 + x MOD 256) - 1 + ENDPROC matchend; + +(*----------------- GLOBAL VARIABLES: -----------------------------------*) + +ROW 256 INT VAR + (* Table of match registers. Each entry consists of two *) + (* pointers, which points to the TEXT object 't' *) + mapos, (* points to the beginning of the match *) + maend; (* points to the position after the end of match *) + +INT VAR ppos, tpos, (* workpositions in pattern 'p' and text 't' *) + floatpos, (* accumulation of all pending floatlengths *) + failpos, (* result of 'PROC in alpha' *) + plen, tlen, (* length of pattern 'p' and length of text 't' *) + skipcount, (* for track forward skipping *) + multi, vari; (* for handling of nonexclusive alternatives *) + +TEXT VAR p, (* the pattern to be find or some result *) + stack, (* stack of pending assignments *) + alphabet:=""; (* result of 'PROC find alpha', reset to nil *) + (* after its usage by 'find any' *) + +BOOL VAR fix, (* text position is fixed and not floating *) + no vari; (* not variing the order of alternatives *) + +TEXT PROC somefix (TEXT CONST pattern): + + (* delivers the first text occuring unconditionally in the pattern *) + + p:= pattern; + INT VAR j:= 1, n:= 0, k, len:= LENGTH p; + REP + SELECT text( subtext (p, j, j+1), 2) ISUB 1 OF + CASE 1,3,7,9,10,11: j INCR 2 + CASE 2: j INCR 2; n DECR 1 (* condition closed *) + CASE 4: j INCR 2; n INCR 1 (* condition opened *) + CASE 5: j := pos (p, starz, j+2) + 2 + CASE 6: j INCR 4 + CASE 8: j INCR 3 + OTHERWISE k:= pos(p, z, j+1) - 1; + IF k <= 0 THEN k:= 1+len FI; + IF star found + THEN change (p, starpos, starpos, star); + len:= LENGTH p; + k:= starpos + FI; + IF n = 0 CAND ( p SUB k ) <> or CAND k > j + THEN LEAVE somefix WITH subtext(p,j,k-1) + ELSE j:=k + FI + ENDSELECT + UNTIL j > len + PER; + "" . + + star found: + INT VAR starpos:= pos (p, "*", j); + starpos > 0 CAND starpos <= k . + + ENDPROC somefix; + +PROC skip (TEXT CONST p, BOOL CONST upto or): + + (* skips 'ppos' upto the end of the opened nest, n = nesting level *) + + INT VAR n:= 0; + REP + SELECT text (subtext (p, ppos, ppos+1), 2) ISUB 1 OF + CASE 1,2: IF n = 0 + THEN LEAVE skip + FI; + ppos INCR 2; + nDECR1 + CASE 3: IF n = 0 CAND upto or + THEN LEAVE skip + FI; + ppos INCR 2 + CASE 7: ppos INCR 2 + CASE 4,9,10,11: ppos INCR 2; + n INCR 1 + CASE 5: ppos:= pos (p, starz, ppos+2) + 2 + CASE 6: ppos INCR 4 + CASE 8: ppos INCR 3; + n INCR 1 + OTHERWISE ppos:= pos(p, z, ppos+1) - 1; + IF ppos < 0 + THEN ppos:= plen; + LEAVE skip + FI + ENDSELECT + PER + ENDPROC skip; + +BOOL OP UNLIKE (TEXT CONST t, p): NOT ( t LIKE p ) ENDOP UNLIKE; + +BOOL OP LIKE (TEXT CONST t, pattern): + init; + BOOL CONST found:= find (t,1,1, fixresult, floatresult); + save; + found. + + init: no vari:= TRUE; + vari:= 0; + tlen:= 1 + LENGTH t; + p:= full (pattern); + IF pos (p, bound) > 0 + THEN + IF subtext (p, 14, 15) = bound + THEN p:= subtext (p, 1, 8) + powerz0 + subtext (p, 16) + FI; + plen:= LENGTH p - 7; + IF subtext (p, plen, plen+1) = bound + THEN p:= subtext (p, 1, plen - 1) + stopz + stopz + FI; + FI; + plen:= LENGTH p + 1; + INT VAR fixresult, floatresult; + tpos:= 1; + floatpos:= 0; + stack:= ""; + alphabet:= ""; + fix:= TRUE; + skipcount:= 0; + multi:= 0. + + save: p:= t + + ENDOP LIKE; + +(*-------- Realisation of the pattern matching algorithms 'find' --------*) + +BOOL PROC find + (TEXT CONST t, INT CONST unit, from, INT VAR fixleft, floatlen): + + initialize; + BOOL CONST found:= pattern unit; + SELECT next command * unit OF + CASE 0,1,2: found + CASE 3: next; + find alternative + OTHERWISE find concatenation + ENDSELECT . + + find alternative: + IF found + THEN save left position; + backtrack; + IF find pattern CAND better + THEN note multiplicity + ELSE back to first one + FI + ELSE backtrack multi + FI. + + better: permutation XOR more left. + + permutation: vari MOD 2 = 1. + + save left position: j:= fixleft. + + more left: j > fixleft. + + backtrack multi: multi:= 2 * backmulti + 1; + vari:= backvari DIV 2; + find pattern. + + note multiplicity: multi:= 2 * multi + 1; + vari:= vari DIV 2; + TRUE. + + back to first one: backtrack; + IF find first subpattern + THEN skip (p, FALSE); + note multiplicity + ELSE errorstop ("pattern"); + FALSE + FI. + + find concatenation: + IF found + THEN IF ppos=plen COR find pattern COR track forward + COR ( multi > backmulti CAND vari = 0 CAND find variation ) + THEN TRUE + ELSE backtrack; FALSE + FI + ELSE skip (p, TRUE); FALSE + FI. + + track forward: (* must be performed before variation *) + j:=0; + last multi:= multi; + last vari:= vari; + WHILE skipcount = 0 + REP IF tlen = tpos + THEN LEAVE track forward WITH FALSE + FI; + backtrack; + j INCR 1; + skipcount:= j + UNTIL find first subpattern CAND find pattern + PER; + j:= skipcount; + skipcount:=0; + j=0. + + find variation: + multi:= last multi; + vari:= last vari; + FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1 + REP backtrack with variation; + IF find first subpattern CAND find pattern + THEN vari:=0; + LEAVE find variation WITH TRUE + FI + PER; + FALSE. + + backtrack with variation: + backtrack; + vari:= k. + + find pattern: + find (t, 1, ppos+forcer, fixresult, floatresult) CAND keep result. + + find first subpattern: + find (t, 0, from, fixresult, floatresult) CAND keep result . + + initialize: + INT VAR j, + k, + fixresult, + floatresult, + last multi, + last vari; + BOOL CONST backfix:= fix; + TEXT CONST backstack:= stack; + floatlen:= 0; + INT CONST back:= tpos, + backfloat:= floatpos, + backskip:= skipcount, + backmulti:= multi, + backvari:= vari; + fixleft:= fixleft0. + + fixleft0: IF fix THEN back ELSE undefined FI. + + backtrack: + fix:= backfix; + tpos:= back; + fixleft:= fixleft0; + floatlen:= 0; + floatpos:= backfloat; + stack:= backstack; + skipcount:= backskip; + multi:= backmulti; + vari:= backvari. + + keep result: + IF fixleft = undefined + THEN IF fixresult = undefined + THEN floatlen INCR floatresult + ELSE fixleft := fixresult - floatlen; + floatpos DECR floatlen; + floatlen:= 0 + FI + FI; + TRUE. + + pattern unit: + init ppos; + SELECT command OF + CASE 1,2: find end + CASE 3: find nil + CASE 4: find choice + CASE 5: find alphabet + CASE 6: find fixlength any + CASE 7: find varlength any + CASE 8: find and store match + CASE 9: find notion + CASE 10: find full + CASE 11: next; find nil + OTHERWISE find plain text END SELECT. + + init ppos: ppos:= from + 2. + + command: text (subtext (p, from, from+1), 2) ISUB 1. + + next command: text (subtext (p, ppos, ppos+1), 2) ISUB 1. + + next: ppos INCR 2. + + find end: ppos DECR 2; + fixleft:= tpos; + LEAVE find WITH TRUE; + TRUE. + + find nil: ppos DECR 2; + fixleft:= tpos; + TRUE. + + find choice: IF find pattern + THEN next; TRUE + ELSE next; FALSE + FI. + + find plain text: find text upto next command; + IF fix THEN allow fix position only + ELIF text found THEN allow variable position + ELSE allow backtrack + FI. + + find text upto next command: + ppos:= pos (p, z, from + 1); + IF ppos = 0 + THEN ppos:= plen + ELSE ppos DECR 1 + FI; + IF star found + THEN change (p, starpos, starpos, star); + plen:= 1 + LENGTH p; + ppos:= starpos + FI; + tpos:= pos (t, subtext (p, from, ppos - 1), tpos). + + star found: + INT VAR starpos:= pos (p, "*", from); + starpos > 0 CAND starpos <= ppos . + + text found: + WHILE skipcount > 0 CAND tpos > 0 + REP skipcount DECR 1; + tpos:= pos (t, subtext(p,from,ppos-1), tpos+1) + PER; + tpos > 0 . + + allow fix position only: + IF tpos = back + THEN tpos INCR (ppos-from); TRUE + ELSE tpos:= back; + from = ppos + FI. + + allow variable position: + IF alphabet = "" COR in alpha (t, back, tpos) + THEN fix it; + tpos INCR (ppos-from); + TRUE + ELSE tpos:= back; + FALSE + FI. + + allow backtrack: + tpos:= back; + IF from = ppos + THEN fix it; + TRUE + ELSE FALSE + FI . + + find alphabet: + j:= pos (p, starz, ppos); + alphabet:= subtext (p, ppos, j-1); + ppos := j; + TRUE. + + find fixlength any: + get length value; + find alpha attribut; + IF alphabet = "" + THEN find any with fix length + ELSE find any in alphabet with fix length + FI. + + get length value: + floatlen:= subtext(p, ppos, ppos+1) ISUB 1; + ppos INCR 4. + + find alpha attribut: + IF (p SUB (ppos-2)) = alpha CAND find alphabet + THEN next + FI. + + find any with fix length: + tpos INCR floatlen; + IF tpos > tlen + THEN tpos:= back; + floatlen:=0; + FALSE + ELSE IF fix THEN floatlen:= 0 + ELIF floatlen = 0 + THEN fix it (* unlike niltext 6.6. *) + ELSE floatpos INCR floatlen + FI; + TRUE + FI. + + find any in alphabet with fix length: + IF first character in alpha + THEN IF NOT fix THEN fix it FI; + set fix found + ELSE set fix not found + FI. + + first character in alpha: + (fix COR advance) CAND in alpha (t, tpos, tpos+floatlen). + + advance: + FOR tpos FROM back UPTO tlen + REP IF pos (alphabet, t SUB tpos) > 0 + THEN LEAVE advance WITH TRUE + FI + PER; + FALSE. + + fix it: + fixleft:= back-floatpos; + make fix (back); + fixleft:= tpos. + + set fix found: + tpos INCR floatlen; + floatlen:= 0; + alphabet:= ""; + TRUE. + + set fix not found: tpos:= back; + alphabet:= ""; + floatlen:= 0; + FALSE. + + find varlength any: IF alphabet = "" + THEN really any + ELSE find varlength any in alphabet + FI. + + really any: IF fix + THEN fix:= FALSE; + fixleft:= tpos + ELIF floatpos = 0 + THEN fixleft:= tpos (* 6.6. *) + FI; + TRUE . + + find varlength any in alphabet: + IF fix THEN fixleft := tpos FI; + IF fix CAND pos (alphabet, t SUB tpos) > 0 + COR NOT fix CAND advance + THEN IF NOT fix THEN fix it FI; + set var found + ELSE set var not found + FI. + + set var found: tpos:= end of varlength any; + alphabet:= ""; + TRUE. + set var not found: tpos:= back; + alphabet:= ""; + FALSE. + end of varlength any: IF NOT in alpha(t,tpos,tlen) + THEN failpos + ELSE tlen + FI. + + find and store match: get register name; + IF find pattern + THEN next; + store; + TRUE + ELSE next; + FALSE + FI. + + store: IF fix + THEN mapos (reg):= fixleft; + maend (reg):= tpos + ELSE stack CAT code(floatlen) + + code(floatpos) + code(fixleft) + c + FI. + + get register name: TEXT CONST c:= p SUB (ppos); + INT VAR reg:= code (c); + ppos INCR 1. + + find notion: float notion; + exhaust notion . + + float notion: j:= back; + REP IF find pattern + THEN IF is notion (t, fixleft) + THEN LEAVE find notion WITH TRUE + ELIF backfix + THEN LEAVE float notion + ELSE go ahead FI + ELIF j=back + THEN next; + LEAVE find notion WITH FALSE + ELSE LEAVE float notion + FI + PER. + + go ahead: j INCR 1; + IF simple THEN j:= max (tpos, j) FI; + notion backtrack. + + simple: k:= from; + REP k := pos (p, z, k+2); + IF k > ppos-3 + THEN LEAVE simple WITH TRUE + ELIF pos (oralpha, p SUB k-1) > 0 + THEN LEAVE simple WITH FALSE + FI + PER; + FALSE. + + notion backtrack: tpos:= j; + fix:= backfix; + fixleft:= fixleft0; + floatlen:= 0; + floatpos:= backfloat + tpos - back; + stack:= backstack; + ppos:= from + 2 . + + exhaust notion: IF notion expansion + COR multi > backmulti + CAND no vari + CAND notion variation + THEN TRUE + ELSE backtrack; FALSE + FI. + + notion expansion: j:= 0; + multi:= last multi; + vari:= last vari; + WHILE skipcount = 0 + REP skip and try PER; + j:= skipcount; + skipcount:= 0; + j = 0. + + skip and try: backtrack; + j INCR 1; + skipcount:=j; + ppos:= from + 2; + IF find pattern + THEN IF is notion (t, fixleft) + THEN LEAVE find notion WITH TRUE + FI + ELSE next; LEAVE find notion WITH FALSE + FI . + + notion variation: no vari:= FALSE; + last multi:= multi; + last vari:= vari; + FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1 + REP backtrack with variation; + IF find first subpattern + THEN no vari:= TRUE; + LEAVE find notion WITH TRUE + FI + PER; + no vari:= TRUE; + FALSE. + + find full: + find pattern CAND (end of line COR exhaust line). + + end of line: + next; + IF fix + THEN tpos = tlen + ELSE tpos:= tlen; + make fix (1); + TRUE + FI. + + exhaust line: + IF full expansion COR multi > 0 CAND no vari CAND full variation + THEN TRUE ELSE backtrack; + FALSE + FI. + + full expansion: + j:=0; + last multi:= multi; + last vari:= vari; + WHILE skipcount = 0 + REP IF tlen = tpos + THEN LEAVE full expansion WITH FALSE + FI; + backtrack; + j INCR 1; + skipcount:= j; + ppos:=from + 2 + UNTIL find pattern CAND tpos=tlen + PER; + j:= skipcount; + skipcount:=0; + j=0. + + full variation: + no vari:= FALSE; + multi:= last multi; + vari:= last vari; + FOR k FROM 1 UPTO multi + REP backtrack with variation; + IF find first subpattern + THEN no vari:= TRUE; + LEAVE find WITH TRUE + FI + PER; + no vari:= TRUE; + FALSE. + + ENDPROC find; + +BOOL PROC is notion (TEXT CONST t, INT CONST fixleft): + ppos INCR 2; + ( NOT fix + COR tpos = tlen + COR pos (delimiter, t SUB tpos) > 0 + COR pos (delimiter, t SUB tpos-1) > 0 + COR (t SUB tpos) <= "Z" + CAND (t SUB tpos-1) > "Z" ) + CAND ( fixleft <= 1 + COR pos (delimiter, t SUB fixleft-1) > 0 + COR pos (delimiter, t SUB fixleft) > 0 + COR (t SUB fixleft) > "Z" + CAND (t SUB fixleft-1) <= "Z" ) + + END PROC is notion; + +PROC make fix (INT CONST back): + WHILE stack not empty + REP INT VAR reg:= code (stack SUB top), + pos:= code (stack SUB top-1), + len:= code (stack SUB top-3), + dis:= code (stack SUB top-2) - floatpos; + maend(reg):= min (tpos + dis, tlen); (* 6.6. *) + mapos(reg):= pos or fix or float; + stack:= subtext (stack,1,top-4) + PER; + fix:= TRUE; + floatpos:= 0 . + + stack not empty: INT VAR top:= LENGTH stack; + top > 0. + + pos or fix or float: + IF pos = undefined + THEN IF len = 0 + THEN min (back + dis, tlen) + ELSE maend(reg) - len + FI + ELSE pos + FI. + + ENDPROC make fix; + +BOOL PROC in alpha (TEXT CONST t, INT CONST from, to): + FOR failpos FROM from UPTO to - 1 + REP IF pos (alphabet, t SUB failpos) = 0 + THEN LEAVE in alpha WITH FALSE + FI + PER; + TRUE + ENDPROC in alpha; + +TEXT PROC notion (TEXT CONST t, INT CONST r): notion (t) ** r ENDPROC notion; + +ENDPACKET pattern match; + diff --git a/system/base/1.7.5/src/pcb control b/system/base/1.7.5/src/pcb control new file mode 100644 index 0000000..9bf0e2d --- /dev/null +++ b/system/base/1.7.5/src/pcb control @@ -0,0 +1,79 @@ + +PACKET pcb and init control DEFINES (* Autor: J.Liedtke *) + (* Stand: 25.08.84 *) + session , + pcb , + set line nr , + clock , + INITFLAG , + := , + initialized , + storage , + id , + ke : + + +LET line number field = 1 , + myself id field = 9 ; + +TYPE INITFLAG = INT ; + + +INT PROC session : + EXTERNAL 126 +ENDPROC session ; + +INT PROC pcb (INT CONST field) : + EXTERNAL 80 +ENDPROC pcb ; + +PROC write pcb (INT CONST task nr, field, value) : + EXTERNAL 105 +ENDPROC write pcb ; + +PROC set line nr (INT CONST value) : + write pcb (pcb (myself id field), line number field, value) +ENDPROC set line nr ; + + +OP := (INITFLAG VAR flag, BOOL CONST flagtrue) : + + IF flagtrue + THEN CONCR (flag) := myself no + ELSE CONCR (flag) := 0 + FI . + +myself no : pcb (myself id field) AND 255 . + +ENDOP := ; + +BOOL PROC initialized (INITFLAG VAR flag) : + + IF CONCR (flag) = myself no + THEN TRUE + ELSE CONCR (flag) := myself no ; + FALSE + FI . + +myself no : pcb (myself id field) AND 255 . + +ENDPROC initialized ; + +REAL PROC clock (INT CONST nr) : + EXTERNAL 102 +ENDPROC clock ; + +PROC storage (INT VAR size, used) : + EXTERNAL 89 +ENDPROC storage ; + +INT PROC id (INT CONST no) : + EXTERNAL 129 +ENDPROC id ; + +PROC ke : + EXTERNAL 6 +ENDPROC ke ; + +ENDPACKET pcb and init control ; + diff --git a/system/base/1.7.5/src/real b/system/base/1.7.5/src/real new file mode 100644 index 0000000..3e3c651 --- /dev/null +++ b/system/base/1.7.5/src/real @@ -0,0 +1,442 @@ +(* ------------------- VERSION 6 05.05.86 ------------------- *) +PACKET real DEFINES (* Autor: J.Liedtke *) + + text , + int , + real , + round , + floor , + frac , + decimal exponent , + set exp , + INCR , + DECR , + abs , + ABS , + sign , + SIGN , + MOD , + min , + max , + max real , + small real : + +LET mantissa length = 13 , + digit zero index = 1 , + digit nine index = 10 ; +INT CONST + decimal point index := -1 ; + +TEXT VAR mantissa ; + +ROW 10 REAL VAR real digit ; + +INT VAR i ; REAL VAR d := 0.0 ; +FOR i FROM 1 UPTO 10 REP + real digit (i) := d ; + d := d + 1.0 +PER ; + +REAL PROC max real : 9.999999999999e126 ENDPROC max real ; + +REAL PROC small real : 1.0e-12 ENDPROC small real ; + +PROC sld (INT CONST in, REAL VAR real, INT VAR out) : + EXTERNAL 96 +ENDPROC sld ; + +INT PROC decimal exponent (REAL CONST mantissa) : + EXTERNAL 97 +ENDPROC decimal exponent ; + +PROC set exp (INT CONST exponent, REAL VAR number) : + EXTERNAL 98 +ENDPROC set exp ; + +REAL PROC tenpower (INT CONST exponent) : + REAL VAR result := 1.0 ; + set exp (exponent, result) ; + result +ENDPROC tenpower ; + +REAL PROC floor (REAL CONST real) : + EXTERNAL 99 +ENDPROC floor ; + +REAL PROC round (REAL CONST real, INT CONST digits) : + + REAL VAR result := real ; + IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length) + THEN round result ; + FI ; + result . + +round result : + set exp (decimal exponent (result) + digits, result) ; + IF result >= 0.0 + THEN result := floor (result + 0.5) + ELSE result := floor (result - 0.5) + FI ; + IF result <> 0.0 + THEN set exp (decimal exponent (result) - digits, result) + FI . + +ENDPROC round ; + +TEXT VAR result ; + +TEXT PROC text (REAL CONST real) : + + REAL VAR value := rounded to seven digits ; + IF value = 0.0 + THEN "0.0" + ELSE + process sign ; + get mantissa (value) ; + INT CONST exponent := decimal exponent (value) ; + get short mantissa ; + IF exponent > 7 OR exponent < LENGTH short mantissa - 7 + THEN scientific notation + ELSE short notation + FI + FI . + +rounded to seven digits : + round ( real * tenpower( -decimal exponent(real) ) , 6 ) + * tenpower ( decimal exponent(real) ) . + +process sign : + IF value < 0.0 + THEN result := "-" ; + value := - value + ELSE result := "" + FI . + +get short mantissa : + INT VAR i := 7 ; + WHILE (mantissa SUB i) = "0" REP + i DECR 1 + UNTIL i=1 END REP ; + TEXT CONST short mantissa := subtext (mantissa, 1, i) . + +scientific notation : + result CAT (mantissa SUB 1) ; + result CAT "." ; + result CAT subtext (mantissa, 2, 7) ; + result + "e" + text (exponent) . + +short notation : + IF exponent < 0 + THEN result + "0." + (-exponent - 1) * "0" + short mantissa + ELSE result CAT subtext (short mantissa, 1, exponent+1) ; + result CAT (exponent+1 - LENGTH short mantissa) * "0" ; + result CAT "." ; + result CAT subtext (short mantissa, exponent+2) ; + IF LENGTH short mantissa < exponent + 2 + THEN result + "0" + ELSE result + FI + FI . + +ENDPROC text ; + +PROC get mantissa (REAL CONST number) : + + REAL VAR real mantissa := number ; + mantissa := "" ; + INT VAR i , digit ; + FOR i FROM 1 UPTO mantissa length REP + sld (0, real mantissa, digit) ; + mantissa CAT code (digit + 48) + PER ; + +ENDPROC get mantissa ; + +TEXT PROC text (REAL CONST real, INT CONST length) : + + INT CONST mantissa length := min (length - 7, 13) ; + IF mantissa length > 0 + THEN construct scientific notation + ELSE result := length * "*" + FI ; + result . + +construct scientific notation : + REAL VAR value := rounded real ; + IF value = 0.0 + THEN result := subtext (" 0.0 ", 1, length) + ELSE process sign ; + process mantissa ; + process exponent + FI . + +rounded real : + round (real * tenpower ( -decimal exponent (real)) , mantissa length - 1) + * tenpower (decimal exponent (real)) . + +process sign : + IF value < 0.0 + THEN result := "-" + ELSE result := "+" + FI . + +process mantissa : + get mantissa (value) ; + result CAT (mantissa SUB 1) ; + result CAT "." ; + result CAT subtext (mantissa, 2, mantissa length) . + +process exponent : + IF decimal exponent (value) >= 0 + THEN result CAT "e+" + ELSE result CAT "e-" + FI ; + result CAT text (ABS decimal exponent (value), 3) ; + change all (result, " ", "0") . + +ENDPROC text ; + +TEXT PROC text (REAL CONST real, INT CONST length, fracs) : + + REAL VAR value := round (real, fracs) ; + INT VAR exponent := decimal exponent (value) ; + IF value = 0.0 THEN exponent := 0 FI ; + INT VAR floors := exponent + 1 , + floor length := length - fracs - 1 ; + IF value < 0.0 THEN floor length DECR 1 FI ; + + IF value too big + THEN length * "*" + ELSE transformed value + FI . + +transformed value : + process leading blanks and sign ; + get mantissa (value) ; + result CAT subtext (mantissa, 1, floors) ; + IF LENGTH mantissa < floors + THEN result CAT (floors - LENGTH mantissa) * "0" + FI ; + result CAT "." ; + IF exponent < 0 + THEN result CAT (-floors) * "0" ; + result CAT subtext (mantissa, 1, length - LENGTH result) + ELSE result CAT subtext (mantissa, floors+1, floors + fracs) + FI ; + IF LENGTH result < length + THEN result CAT (length - LENGTH result) * "0" + FI ; + result . + +process leading blanks and sign : + result := (floor length - max(floors,0)) * " " ; + IF value < 0.0 + THEN result CAT "-" ; + value := - value + FI . + +value too big : + floors > floor length . + +ENDPROC text ; + +REAL PROC real (TEXT CONST text) : + + skip leading blanks ; + sign ; + mantissa part ; + exponent ; + result . + +skip leading blanks : + INT VAR pos := 1 ; + skip blanks . + +skip blanks : + WHILE (text SUB pos) = " " REP + pos INCR 1 + PER . + +sign : + BOOL VAR negative ; + IF (text SUB pos) = "-" + THEN negative := TRUE ; + pos INCR 1 + ELIF (text SUB pos) = "+" + THEN negative := FALSE ; + pos INCR 1 + ELSE negative := FALSE + FI . + +mantissa part: + REAL VAR value ; + INT VAR exponent pos := 0 ; + get first digit ; + WHILE pos <= LENGTH text REP + digit := code (text SUB pos) - 47 ; + IF digit >= digit zero index AND digit <= digit nine index + THEN value := value * 10.0 + real digit (digit) ; + pos INCR 1 + ELIF digit = decimal point index AND exponent pos = 0 + THEN pos INCR 1 ; + exponent pos := pos + ELSE LEAVE mantissa part + FI + END REP . + +get first digit : + INT VAR digit := code (text SUB pos) - 47 ; + IF digit = decimal point index + THEN pos INCR 1 ; + exponent pos := pos ; + digit := code (text SUB pos) - 47 + FI ; + IF digit >= digit zero index AND digit <= digit nine index + THEN value := real digit (digit) ; + pos INCR 1 + ELSE set conversion (FALSE) ; + LEAVE real WITH 0.0 + FI . + +exponent : + INT VAR exp ; + IF exponent pos > 0 + THEN exp := exponent pos - pos + ELSE exp := 0 + FI ; + IF (text SUB pos) = "e" + THEN exp INCR int (subtext(text,pos+1)) + ELSE no more nonblank chars permitted + FI . + +no more nonblank chars permitted : + skip blanks ; + IF pos > LENGTH text + THEN set conversion (TRUE) + ELSE set conversion (FALSE) + FI . + +result : + value := value * tenpower (exp) ; + IF negative + THEN - value + ELSE value + FI . + +ENDPROC real ; + + +REAL PROC abs (REAL CONST value) : + + IF value >= 0.0 + THEN value + ELSE -value + FI + +ENDPROC abs ; + +REAL OP ABS (REAL CONST value) : + + abs (value) + +ENDOP ABS ; + +INT PROC sign (REAL CONST value) : + + IF value < 0.0 THEN -1 + ELIF value = 0.0 THEN 0 + ELSE 1 + FI + +ENDPROC sign ; + +INT OP SIGN (REAL CONST value) : + + sign (value) + +ENDOP SIGN ; + +REAL OP MOD (REAL CONST left, right) : + + REAL VAR result := left - floor (left/right) * right ; + IF result < 0.0 + THEN result + abs (right) + ELSE result + FI + +ENDOP MOD ; + +REAL PROC frac (REAL CONST value) : + + value - floor (value) + +ENDPROC frac ; + +REAL PROC max (REAL CONST a, b) : + + IF a > b THEN a ELSE b FI + +ENDPROC max ; + +REAL PROC min (REAL CONST a, b) : + + IF a < b THEN a ELSE b FI + +ENDPROC min ; + +OP INCR (REAL VAR dest, REAL CONST increment) : + + dest := dest + increment + +ENDOP INCR ; + +OP DECR (REAL VAR dest, REAL CONST decrement) : + + dest := dest - decrement + +ENDOP DECR ; + +INT PROC int (REAL CONST value) : + + IF value = minint value + THEN minint + ELSE compute int result ; + IF value < 0.0 + THEN - result + ELSE result + FI + FI . + +compute int result : + INT VAR result := 0, digit ,i ; + REAL VAR mantissa := value ; + + FOR i FROM 0 UPTO decimal exponent (value) REP + sld (0, mantissa, digit) ; + result := result * 10 + digit + PER . + +minint value : - 32768.0 . +minint : - 32767 - 1 . + +ENDPROC int ; + +REAL PROC real (INT CONST value) : + + IF value < 0 + THEN - real (-value) + ELIF value < 10 + THEN real digit (value+1) + ELSE split value into head and last digit ; + real (head) * 10.0 + real digit (last digit+1) + FI . + +split value into head and last digit : + INT CONST + head := value DIV 10 , + last digit := value - head * 10 . + +ENDPROC real ; + +ENDPACKET real ; + diff --git a/system/base/1.7.5/src/scanner b/system/base/1.7.5/src/scanner new file mode 100644 index 0000000..35a632c --- /dev/null +++ b/system/base/1.7.5/src/scanner @@ -0,0 +1,325 @@ +(* ------------------- VERSION 4 14.05.86 ------------------- *) +PACKET scanner DEFINES (* Autor: J.Liedtke *) + + scan , + continue scan , + next symbol : + + +LET tag = 1 , + bold = 2 , + number = 3 , + text = 4 , + operator= 5 , + delimiter = 6 , + end of file = 7 , + within comment = 8 , + within text = 9 ; + +LET digit 0 = 48 , + digit 9 = 57 , + upper case a = 65 , + upper case z = 90 , + lower case a = 97 , + lower case z = 122; + + +TEXT VAR line := "" , + char := "" , + chars:= "" ; + +INT VAR position := 0 , + comment depth ; +BOOL VAR continue text ; + + +PROC scan (TEXT CONST scan text) : + + comment depth := 0 ; + continue text := FALSE ; + continue scan (scan text) + +ENDPROC scan ; + +PROC continue scan (TEXT CONST scan text) : + + line := scan text ; + position := 0 ; + nextchar + +ENDPROC continue scan ; + +PROC next symbol (TEXT VAR symbol) : + + INT VAR type ; + next symbol (symbol, type) + +ENDPROC next symbol ; + +PROC next symbol (TEXT VAR symbol, INT VAR type) : + + skip blanks ; + IF is begin comment THEN process comment + ELIF comment depth > 0 THEN comment depth DECR 1 ; + process comment + ELIF is quote OR continue text THEN process text + ELIF is lower case letter THEN process tag + ELIF is upper case letter THEN process bold + ELIF is digit THEN process number + ELIF is delimiter THEN process delimiter + ELIF is niltext THEN eof + ELSE process operator + FI . + + +process comment : + read comment ; + IF comment depth = 0 + THEN next symbol (symbol, type) + ELSE type := within comment ; + symbol := "" + FI . + +process tag : + type := tag ; + assemble chars (lower case a, lower case z) ; + symbol := chars ; + REP + skip blanks ; + IF is lower case letter + THEN assemble chars (lower case a, lower case z) + ELIF is digit + THEN assemble chars (digit 0, digit 9) + ELSE LEAVE process tag + FI ; + symbol CAT chars + PER ; + nextchar . + +process bold : + type := bold ; + assemble chars (upper case a, upper case z) ; + symbol := chars . + +process number : + type := number ; + assemble chars (digit 0, digit 9) ; + symbol := chars ; + IF char = "." AND ahead char is digit + THEN process fraction ; + IF char = "e" + THEN process exponent + FI + FI . + +ahead char is digit : + digit 0 <= code (ahead char) AND code (ahead char) <= digit 9 . + +process fraction : + symbol CAT char ; + nextchar ; + assemble chars (digit 0, digit 9) ; + symbol CAT chars . + +process exponent : + symbol CAT char ; + nextchar ; + IF char = "+" OR char = "-" + THEN symbol CAT char ; + nextchar + FI ; + assemble chars (digit 0, digit 9) ; + symbol CAT chars . + +process text : + type := text ; + symbol := "" ; + IF continue text + THEN continue text := FALSE + ELSE next char + FI ; + WHILE not end of text REP + assemble chars (35, 254) ; + symbol CAT chars ; + IF NOT is quote + THEN symbol CAT char ; + nextchar + FI + ENDREP . + +not end of text : + IF is niltext + THEN continue text := TRUE ; type := within text ; FALSE + ELIF is quote + THEN end of text or exception + ELSE TRUE + FI . + +end of text or exception : + next char ; + IF is quote + THEN get quote ; TRUE + ELIF is digit + THEN get special char ; TRUE + ELSE FALSE + FI . + +get quote : + symbol CAT char ; + nextchar . + +get special char : + assemble chars (digit 0, digit 9) ; + symbol CAT code (int (chars) ) ; + nextchar . + +process delimiter : + type := delimiter ; + symbol := char ; + nextchar . + +process operator : + type := operator ; + symbol := char ; + nextchar ; + IF symbol = ":" + THEN IF char = "=" OR char = ":" + THEN symbol := ":=" ; + nextchar + ELSE type := delimiter + FI + ELIF is relational double char + THEN symbol CAT char ; + nextchar + ELIF symbol = "*" AND char = "*" + THEN symbol := "**" ; + next char + FI . + +eof : + type := end of file ; + symbol := "" . + +is lower case letter : + lower case a <= code (char) AND code (char) <= lower case z . + +is upper case letter : + upper case a <= code (char) AND code (char) <= upper case z . + +is digit : + digit 0 <= code (char) AND code (char) <= digit 9 . + +is delimiter : pos ( "()[].,;" , char ) > 0 . + +is relational double char : + TEXT VAR double := symbol + char ; + double = "<>" OR double = "<=" OR double = ">=" . + +is quote : char = """" . + +is niltext : char = "" . + +is begin comment : char = "{" OR char = "(" AND ahead char = "*" . + +ENDPROC next symbol ; + +PROC next char : + + position INCR 1 ; + char := line SUB position + +ENDPROC next char ; + +PROC skip blanks : + + position := pos (line, ""33"", ""254"", position) ; + IF position = 0 + THEN position := LENGTH line + 1 + FI ; + char := line SUB position . + +ENDPROC skip blanks ; + +TEXT PROC ahead char : + + line SUB position+1 + +ENDPROC ahead char ; + +PROC assemble chars (INT CONST low, high) : + + INT CONST begin := position ; + position behind valid text ; + chars := subtext (line, begin, position-1) ; + char := line SUB position . + +position behind valid text : + position := pos (line, ""32"", code (low-1), begin) ; + IF position = 0 + THEN position := LENGTH line + 1 + FI ; + INT CONST higher pos := pos (line, code (high+1), ""254"", begin) ; + IF higher pos <> 0 AND higher pos < position + THEN position := higher pos + FI . + +ENDPROC assemble chars ; + + +PROC read comment : + + TEXT VAR last char ; + comment depth INCR 1 ; + REP + last char := char ; + nextchar ; + IF is begin comment + THEN read comment + FI ; + IF char = "" + THEN LEAVE read comment + FI + UNTIL is end comment PER ; + comment depth DECR 1 ; + next char ; + skip blanks . + +is end comment : + char = "}" OR char = ")" AND last char = "*" . + +is begin comment : + char = "{" OR char = "(" AND ahead char = "*" . + +ENDPROC read comment ; + + +PROC scan (FILE VAR f) : + + getline (f, line) ; + scan (line) + +ENDPROC scan ; + +PROC next symbol (FILE VAR f, TEXT VAR symbol) : + + INT VAR type ; + next symbol (f, symbol, type) + +ENDPROC next symbol ; + +TEXT VAR scanned ; + +PROC next symbol (FILE VAR f, TEXT VAR symbol, INT VAR type) : + + next symbol (symbol, type) ; + WHILE type >= 7 AND NOT eof (f) REP + getline (f, line) ; + continue scan (line) ; + next symbol (scanned, type) ; + symbol CAT scanned + PER . + +ENDPROC next symbol ; + +ENDPACKET scanner ; + diff --git a/system/base/1.7.5/src/screen b/system/base/1.7.5/src/screen new file mode 100644 index 0000000..7e64961 --- /dev/null +++ b/system/base/1.7.5/src/screen @@ -0,0 +1,33 @@ + +PACKET screen description DEFINES + + xsize, ysize, marksize, mark refresh line mode : + + +INT VAR xs := 80, ys := 24, ms := 1; + +INT PROC xsize: xs END PROC xsize; + +INT PROC ysize: ys END PROC ysize; + +INT PROC marksize: ms END PROC marksize; + +PROC xsize (INT CONST i): xs := i END PROC xsize; + +PROC ysize (INT CONST i): ys := i END PROC ysize; + +PROC marksize (INT CONST i): ms := i END PROC marksize; + + +BOOL VAR line mode := FALSE; + +BOOL PROC mark refresh line mode: + line mode +END PROC mark refresh line mode; + +PROC mark refresh line mode (BOOL CONST b): + line mode := b +END PROC mark refresh line mode; + +END PACKET screen description ; + diff --git a/system/base/1.7.5/src/std transput b/system/base/1.7.5/src/std transput new file mode 100644 index 0000000..94c51db --- /dev/null +++ b/system/base/1.7.5/src/std transput @@ -0,0 +1,264 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PACKET std transput DEFINES + + sysout , + sysin , + put , + putline , + line , + page , + write , + get , + getline , + get secret line : + + +LET cr = ""13"" , + cr lf = ""13""10"" , + home clear = ""1""4"" , + esc = ""27"" , + rubout = ""12"" , + bell = ""7"" , + back blank back = ""8" "8"" , + del line cr lf = ""5""13""10"" ; + +TEXT VAR number word , exit char ; + +BOOL VAR console output := TRUE, console input := TRUE ; + +FILE VAR outfile, infile ; +TEXT VAR outfile name := "", infile name := "" ; + + +PROC sysout (TEXT CONST file name) : + + outfile name := file name ; + IF file name = "" + THEN console output := TRUE + ELSE outfile := sequential file (output, file name) ; + console output := FALSE + FI + +ENDPROC sysout ; + +TEXT PROC sysout : + outfile name +ENDPROC sysout ; + +PROC sysin (TEXT CONST file name) : + + infile name := file name ; + IF file name = "" + THEN console input := TRUE + ELSE infile := sequential file (input, file name) ; + console input := FALSE + FI + +ENDPROC sysin ; + +TEXT PROC sysin : + infile name +ENDPROC sysin ; + + +PROC put (TEXT CONST word) : + + IF console output + THEN out (word) ; out (" ") + ELSE put (outfile, word) + FI + +ENDPROC put ; + +PROC put (INT CONST number) : + + put (text (number)) + +ENDPROC put ; + +PROC put (REAL CONST number) : + + put (text (number)) + +ENDPROC put ; + +PROC putline (TEXT CONST textline) : + + IF console output + THEN out (textline) ; out (cr lf) + ELSE putline (outfile, textline) + FI + +ENDPROC putline ; + +PROC line : + + IF console output + THEN out (cr lf) + ELSE line (outfile) + FI + +ENDPROC line ; + +PROC line (INT CONST times) : + + INT VAR i ; + FOR i FROM 1 UPTO times REP + line + PER + +ENDPROC line ; + +PROC page : + + IF console output + THEN out (home clear) + FI + +ENDPROC page ; + +PROC write (TEXT CONST word) : + + IF console output + THEN out (word) + ELSE write (outfile, word) + FI + +ENDPROC write ; + + +PROC get (TEXT VAR word) : + + IF console input + THEN get from console + ELSE get (infile, word) + FI . + +get from console : + REP + word := "" ; + editget (word, " ", "", exit char) ; + echoe exit char + UNTIL word <> "" AND word <> " " PER ; + delete leading blanks . + +delete leading blanks : + WHILE (word SUB 1) = " " REP + word := subtext (word,2) + PER . + +ENDPROC get ; + +PROC get (TEXT VAR word, TEXT CONST separator) : + + IF console input + THEN get from console + ELSE get (infile, word, separator) + FI . + +get from console : + word := "" ; + editget (word, separator, "", exit char) ; + echoe exit char . + +ENDPROC get ; + +PROC echoe exit char : + + IF exit char = ""13"" + THEN out (""13""10"") + ELSE out (exit char) + FI + +ENDPROC echoe exit char ; + +PROC get (INT VAR number) : + + get (number word) ; + number := int (number word) + +ENDPROC get ; + +PROC get (REAL VAR number) : + + get (number word) ; + number := real (number word) + +ENDPROC get ; + +PROC get (TEXT VAR word, INT CONST length) : + + IF console input + THEN get from console + ELSE get (infile, word, length) + FI . + +get from console : + word := "" ; + editget (word, length, exit char) ; + echoe exit char . + +ENDPROC get ; + +PROC getline (TEXT VAR textline) : + + IF console input + THEN get from console + ELSE getline (infile, textline) + FI . + +get from console : + textline := "" ; + editget (textline, "", "", exit char) ; + echoe exit char + +ENDPROC getline ; + +PROC get secret line (TEXT VAR textline) : + + TEXT VAR char ; + textline := "" ; + get start cursor position ; + get line very secret ; + IF char = esc + THEN get line little secret + FI ; + cursor to start position ; + out (del line cr lf) . + +get line very secret : + REP + inchar (char) ; + IF char = esc OR char = cr + THEN LEAVE get line very secret + ELIF char = rubout + THEN delete last char + ELIF char >= " " + THEN textline CAT char ; + out (".") + ELSE out (bell) + FI + PER . + +delete last char : + IF LENGTH textline = 0 + THEN out (bell) + ELSE out (back blank back) ; + delete char (textline, LENGTH textline) + FI . + +get line little secret : + cursor to start position ; + editget (textline, "", "", exit char) . + +get start cursor position : + INT VAR x, y; + get cursor (x, y) . + +cursor to start position : + cursor (x, y) . + +ENDPROC get secret line ; + +ENDPACKET std transput ; + diff --git a/system/base/1.7.5/src/tasten b/system/base/1.7.5/src/tasten new file mode 100644 index 0000000..752303b --- /dev/null +++ b/system/base/1.7.5/src/tasten @@ -0,0 +1,113 @@ + +PACKET tasten verwaltung DEFINES (* #009 *) + (***************) + + lernsequenz auf taste legen, + lernsequenz auf taste, + kommando auf taste legen, + kommando auf taste, + taste enthaelt kommando, + std tastenbelegung : + + + +LET kommandoidentifikation = ""0"" , + esc = ""27"" , + niltext = "" , + hop right left up down cr tab rubin rubout mark esc + = ""1""2""8""3""10""13""9""11""12""16""27"" ; + + +ROW 256 TEXT VAR belegung; +INT VAR i; FOR i FROM 1 UPTO 256 REP belegung (i) := "" PER; + +std tastenbelegung; + + +PROC lernsequenz auf taste legen (TEXT CONST taste, lernsequenz) : + + belege (belegung (code (taste) + 1), taste, lernsequenz) + +ENDPROC lernsequenz auf taste legen ; + +PROC belege (TEXT VAR tastenpuffer, TEXT CONST taste, lernsequenz) : + tastenpuffer := lernsequenz ; + verhindere rekursives lernen . + +verhindere rekursives lernen : + loesche alle folgen esc taste aber nicht esc esc taste ; + IF taste ist freies sonderzeichen + THEN change all (tastenpuffer, taste, niltext) + FI . + +loesche alle folgen esc taste aber nicht esc esc taste : + INT VAR i := pos (tastenpuffer, esc + taste) ; + WHILE i > 0 REP + IF ist esc esc taste + THEN i INCR 1 + ELSE change (tastenpuffer, i, i+1, niltext) + FI ; + i := pos (tastenpuffer, esc + taste, i) + PER . + +ist esc esc taste : + (tastenpuffer SUB i-1) = esc AND (tastenpuffer SUB i-2) <> esc . + +taste ist freies sonderzeichen : + taste < ""32"" AND + pos (hop right left up down cr tab rubin rubout mark esc, taste) = 0 . + +END PROC belege ; + + +TEXT PROC lernsequenz auf taste (TEXT CONST taste) : + IF taste enthaelt kommando (taste) + THEN "" + ELSE belegung (code (taste) + 1) + FI +END PROC lernsequenz auf taste; + + +PROC kommando auf taste legen (TEXT CONST taste, kommando) : + + belegung (code (taste) + 1) := kommandoidentifikation; + belegung (code (taste) + 1) CAT kommando + +END PROC kommando auf taste legen; + + +TEXT PROC kommando auf taste (TEXT CONST taste) : + IF taste enthaelt kommando (taste) + THEN subtext (belegung (code (taste) + 1), 2) + ELSE "" + FI +END PROC kommando auf taste; + + +BOOL PROC taste enthaelt kommando (TEXT CONST taste) : + (belegung (code (taste) + 1) SUB 1) = kommandoidentifikation +END PROC taste enthaelt kommando; + + +PROC std tastenbelegung: + lernsequenz auf taste legen ("(", ""91""); + lernsequenz auf taste legen (")", ""93""); + lernsequenz auf taste legen ("<", ""123""); + lernsequenz auf taste legen (">", ""125""); + lernsequenz auf taste legen ("A", ""214""); + lernsequenz auf taste legen ("O", ""215""); + lernsequenz auf taste legen ("U", ""216""); + lernsequenz auf taste legen ("a", ""217""); + lernsequenz auf taste legen ("o", ""218""); + lernsequenz auf taste legen ("u", ""219""); + lernsequenz auf taste legen ("k", ""220""); + lernsequenz auf taste legen ("-", ""221""); + lernsequenz auf taste legen ("#", ""222""); + ler�sequenz auf taste legen (" ", ""223""); + lernsequenz auf taste legen ("B", ""251""); + lernsequenz auf taste legen ("s", ""251""); +END PROC std tastenbelegung; + + +END PACKET tasten verwaltung; + diff --git a/system/base/1.7.5/src/text b/system/base/1.7.5/src/text new file mode 100644 index 0000000..4c659cf --- /dev/null +++ b/system/base/1.7.5/src/text @@ -0,0 +1,391 @@ +(* ------------------- VERSION 3 06.03.86 ------------------- *) +PACKET text DEFINES + + max text length , + SUB , + subtext , + text , + length , LENGTH , + CAT , + + , + * , + replace , + change , + change all , + compress , + pos , + code , + ISUB , + RSUB , + delete char , + insert char , + delete int , + insert int , + heap size , + collect heap garbage , + stranalyze , + LEXEQUAL , + LEXGREATER , + LEXGREATEREQUAL : + + + +TEXT VAR text buffer , tail buffer ; + +INT CONST max text length := 32000 ; + +TEXT OP SUB (TEXT CONST text, INT CONST pos ) : + EXTERNAL 48 +END OP SUB ; + +TEXT PROC subtext (TEXT CONST source, INT CONST from, to ): + EXTERNAL 49 +ENDPROC subtext ; + +TEXT PROC subtext (TEXT CONST source, INT CONST from ) : + EXTERNAL 50 +ENDPROC subtext ; + +INT PROC code (TEXT CONST text) : + EXTERNAL 46 +END PROC code ; + +TEXT PROC code (INT CONST code) : + EXTERNAL 47 +ENDPROC code ; + +INT OP ISUB (TEXT CONST text, INT CONST index) : + EXTERNAL 44 +ENDOP ISUB ; + +PROC replace (TEXT VAR text, INT CONST index, value) : + EXTERNAL 45 +ENDPROC replace ; + +REAL OP RSUB (TEXT CONST text, INT CONST index) : + EXTERNAL 100 +ENDOP RSUB ; + +PROC replace (TEXT VAR text, INT CONST index, REAL CONST code) : + EXTERNAL 101 +ENDPROC replace ; + + +PROC replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) : + EXTERNAL 51 +ENDPROC replace ; + +TEXT PROC text (TEXT CONST source, INT CONST length ) : + + IF length < LENGTH source + THEN text buffer := subtext (source,1,length) + ELSE text buffer := source ; + mit blanks auffuellen + FI ; + text buffer . + +mit blanks auffuellen : + INT VAR i ; + FOR i FROM 1 UPTO length - LENGTH source REP + text buffer CAT " " + PER . + +ENDPROC text ; + +TEXT PROC text (TEXT CONST source, INT CONST length, from) : + text ( subtext (source, from) , length ) +ENDPROC text ; + +OP CAT (TEXT VAR right, TEXT CONST left ) : + EXTERNAL 52 +ENDOP CAT ; + +TEXT OP + (TEXT CONST left, right) : + text buffer := left ; + text buffer CAT right ; + text buffer +ENDOP + ; + +TEXT OP * (INT CONST times, TEXT CONST source ) : + + text buffer := "" ; + INT VAR i ; + FOR i FROM 1 UPTO times REP + text buffer CAT source + PER ; + text buffer + +ENDOP * ; + +INT PROC length (TEXT CONST text ) : + EXTERNAL 53 +ENDPROC length ; + +INT OP LENGTH (TEXT CONST text ) : + EXTERNAL 53 +ENDOP LENGTH ; + +INT PROC pos (TEXT CONST source, pattern) : + EXTERNAL 54 +ENDPROC pos ; + +INT PROC pos (TEXT CONST source, pattern, INT CONST from) : + EXTERNAL 55 +ENDPROC pos ; + +INT PROC pos (TEXT CONST source, pattern, INT CONST from, to) : + EXTERNAL 56 +ENDPROC pos ; + +INT PROC pos (TEXT CONST source, low, high, INT CONST from) : + EXTERNAL 58 +ENDPROC pos ; + +TEXT PROC compress (TEXT CONST text) : + + INT VAR begin, end ; + + search first non blank ; + search last non blank ; + text buffer := subtext (text, begin, end) ; + text buffer . + +search first non blank : + begin := 1 ; + WHILE (text SUB begin) = " " REP + begin INCR 1 + PER . + +search last non blank : + end := LENGTH text ; + WHILE (text SUB end) = " " REP + end DECR 1 + PER . + +ENDPROC compress ; + +PROC change (TEXT VAR destination, INT CONST from, to, TEXT CONST new) : + + IF LENGTH new = to - from + 1 AND to <= LENGTH destination + THEN replace (destination, from, new) + ELSE change via buffer + FI . + +change via buffer : + text buffer := subtext (destination, 1, from-1) ; + text buffer CAT new ; + tail buffer := subtext (destination, to + 1) ; + text buffer CAT tail buffer ; + destination := text buffer + +ENDPROC change ; + +PROC change (TEXT VAR destination, TEXT CONST old, new) : + + INT CONST position := pos (destination, old) ; + IF position > 0 + THEN change (destination, position, position + LENGTH old -1, new) + FI + +ENDPROC change ; + +PROC change all (TEXT VAR destination, TEXT CONST old, new) : + + INT VAR position := pos (destination, old) ; + IF LENGTH old = LENGTH new + THEN change by replace + ELSE change by change + FI . + +change by replace : + WHILE position > 0 REP + replace (destination, position, new) ; + position := pos (destination, old, position + LENGTH new) + PER . + +change by change : + WHILE position > 0 REP + change (destination, position, position + LENGTH old - 1 , new) ; + position := pos (destination, old, position + LENGTH new) + PER . + +ENDPROC change all ; + +PROC delete char (TEXT VAR string, INT CONST delete pos) : + + IF delete pos > 0 + THEN tail buffer := subtext (string, delete pos + 1) ; + string := subtext (string, 1, delete pos - 1) ; + string CAT tail buffer + FI + +END PROC delete char ; + +PROC insert char (TEXT VAR string, TEXT CONST char, + INT CONST insert pos) : + + IF insert pos > 0 AND insert pos <= LENGTH string + 1 + THEN tail buffer := subtext (string, insert pos) ; + string := subtext (string, 1, insert pos - 1) ; + string CAT char ; + string CAT tail buffer + FI + +END PROC insert char ; + +INT PROC heap size : + EXTERNAL 93 +ENDPROC heap size ; + +PROC collect heap garbage : + EXTERNAL 94 +ENDPROC collect heap garbage ; + +PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum, + TEXT CONST string, INT VAR index, INT CONST to, + INT VAR exit code) : + EXTERNAL 57 +ENDPROC stranalyze ; + +(*******************************************************************) +(* lexikographische Vergleiche *) +(* Nach DIN 5007, Abschnitt 1 und Abschnitt 3.2 (Bindestrich) *) +(* Autor: Rainer Hahn, Jochen Liedtke *) +(* Stand: 1.7.4 (Jan. 1985) *) +(*******************************************************************) +LET first umlaut = ""214"" , + umlauts = ""214""215""216""217""218""219""251"" ; + + +TEXT VAR left letter, right letter; + +BOOL OP LEXEQUAL (TEXT CONST left, right) : + + compare (left, right) ; + left letter = right letter + +ENDOP LEXEQUAL ; + +BOOL OP LEXGREATER (TEXT CONST left, right) : + + compare (left, right) ; + left letter > right letter + +ENDOP LEXGREATER ; + +BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) : + + compare (left, right) ; + left letter >= right letter + +ENDOP LEXGREATEREQUAL ; + +PROC compare (TEXT CONST left, right) : + + to begin of lex relevant text ; + REP + get left letter ; + get right letter + UNTIL NOT letter match OR both ended PER . + +to begin of lex relevant text : + INT VAR + left pos := pos (left, ""65"",""254"", 1) , + right pos := pos (right,""65"",""254"", 1) ; + IF left pos = 0 + THEN left pos := LENGTH left + 1 + FI ; + IF right pos = 0 + THEN right pos := LENGTH right + 1 + FI . + +get left letter : + left letter := left SUB left pos ; + left pos INCR 1 . + +get right letter : + right letter := right SUB right pos ; + right pos INCR 1 . + +letter match : + IF left letter = right letter + THEN TRUE + ELSE dine (left, left letter, left pos) ; + dine (right, right letter, right pos) ; + IF exactly one letter is double letter + THEN expand other letter + FI ; + left letter = right letter + FI . + +exactly one letter is double letter : + LENGTH left letter <> LENGTH right letter. + +expand other letter : + IF LENGTH left letter = 1 + THEN left letter CAT (left SUB left pos) ; + left pos INCR 1 + ELSE right letter CAT (right SUB right pos) ; + right pos INCR 1 + FI . + +both ended : left letter = "" . + +ENDPROC compare ; + +PROC dine (TEXT CONST string, TEXT VAR char, INT VAR string pos) : + + skip non letter chars ; + IF is capital letter + THEN translate to small letter + ELIF char >= first umlaut + THEN translate umlaut + FI . + +skip non letter chars : + WHILE NOT (is letter OR end of string) REP + char := string SUB string pos ; + string pos INCR 1 + PER . + +translate to small letter : + char := code (code (char) + 32) . + +translate umlaut : + SELECT pos (umlauts, char) OF + CASE 1,4 : char := "ae" + CASE 2,5 : char := "oe" + CASE 3,6 : char := "ue" + CASE 7 : char := "ss" + ENDSELECT . + +is capital letter : + INT VAR char code := code (char) ; + 65 <= char code AND char code <= 90 . + +is letter : + char code := code (char) OR 32 ; + (97 <= char code AND char code <= 122) OR char code >= 128 . + +end of string : char = "" . + +ENDPROC dine ; + +OP CAT (TEXT VAR result, INT CONST number) : + result CAT " "; + replace (result, LENGTH result DIV 2, number); +END OP CAT; + +PROC insert int (TEXT VAR result, INT CONST insert pos, number) : + INT VAR pos := insert pos * 2 - 1; + change (result, pos, pos - 1, " "); + replace (result, insert pos, number); +END PROC insert int; + +PROC delete int (TEXT VAR result, INT CONST delete pos) : + INT VAR pos := delete pos * 2; + change (result, pos - 1, pos, "") +END PROC delete int; + +ENDPACKET text ; + diff --git a/system/base/1.7.5/src/texter errors b/system/base/1.7.5/src/texter errors new file mode 100644 index 0000000..9c4383d --- /dev/null +++ b/system/base/1.7.5/src/texter errors @@ -0,0 +1,284 @@ +(* ------------------- VERSION 66 vom 06.03.86 -------------------- *) +PACKET texter errors and common DEFINES + only command line, + skip input, + char pos move, + begin of this char, + number chars, + display and pause, + report text processing error, + report text processing warning: + +(* Programm zur zentralen Haltung aller Fehlermeldungen der Textkosmetik + Autor: Rainer Hahn + Stand: 1.7.1 Febr. 1984 + 1.7.3 Juli " + 1.7.4 Febr. 1985 + *) + +LET escape = ""27""; + +TEXT VAR fehlerdummy; + +BOOL PROC only command line (TEXT CONST zeile): +INT VAR anfang, ende; +LET kommando zeichen = "#"; + IF pos (zeile, kommando zeichen) = 1 + THEN ende := pos (zeile, kommando zeichen, 2); + IF ende > 0 + THEN zaehle kommandos durch; + LEAVE only command line WITH richtiges kommandoende + FI + FI; + FALSE. + +zaehle kommandos durch: + WHILE ende + 1 = pos (zeile, kommando zeichen, ende +1) REP + anfang := pos (zeile, kommando zeichen, ende + 1); + ende := pos (zeile, kommando zeichen, anfang + 1) + END REP. + +richtiges kommandoende: + ende > 0 AND + (ende = length (zeile) OR (ende = length (zeile) - 1 AND absatzzeile)). + +absatzzeile: + (zeile SUB length (zeile)) = " ". +END PROC only command line; + +PROC skip input: + REP + TEXT CONST zeichen :: incharety; + IF zeichen = escape + THEN errorstop ("Abbruch durch ESC") + FI + UNTIL zeichen = "" END REP +END PROC skip input; + +PROC char pos move (TEXT CONST ein text, INT VAR zpos, INT CONST richtung): + zpos INCR richtung; + IF within kanji (ein text, zpos) + THEN zpos INCR richtung + FI +END PROC char pos move; + +PROC begin of this char (TEXT CONST ein text, INT VAR zpos): + IF zpos < 1 OR zpos > length (ein text) + THEN display and pause (7) + ELSE suche zeichenposition + FI. + +suche zeichenposition: + IF within kanji (ein text, zpos) + THEN zpos DECR 1 + FI. +END PROC begin of this char; + +INT PROC number chars (TEXT CONST ein text, INT CONST von pos, bis pos): + INT VAR index :: von pos, anz :: 0; + WHILE index <= bis pos REP + IF index > length (ein text) OR index > bis pos + THEN display and pause (5); LEAVE number chars WITH 0 + FI; + IF is kanji esc (ein text SUB index) + THEN index INCR 2 + ELSE index INCR 1 + FI; + anz INCR 1 + END REP; + anz +END PROC number chars; + +PROC display and pause (INT CONST nr): + line ; put ("LINER ERROR"); put (nr); pause +END PROC display and pause; + +PROC report text processing error (INT CONST error nr, + INT CONST line nr, + TEXT VAR message, + TEXT CONST addition): + + einfache meldung aufbauen; + meldung in fehlerdatei ausgeben. + +einfache meldung aufbauen: + message := "FEHLER Zeile "; + message CAT text (line nr); + message CAT ": "; + message CAT simple message; + message CAT " "; + message CAT addition. + +meldung in fehlerdatei ausgeben: + note (message); + note line; + fehlerdummy := " >>> "; + fehlerdummy CAT zusatz; + note (fehlerdummy); + note line. + +simple message: + SELECT error nr OF + CASE 1: "Unbekannter Schriftyp ignoriert:" + CASE 2: "#-Zeichen fehlt" + CASE 3: "foot in Fußnote (ignoriert)" + CASE 4: "cm-Angabe fehlt (REAL) (ignoriert):" + CASE 5: "INT-Parameter erwartet (ignoriert):" + CASE 6: "(versuchte) Trennung in Macro-Text" + CASE 7: "ie-Anweisung fehlt bei Seitenende" + CASE 8: "Unbekannte Anweisung (ignoriert):" + CASE 9: "Nicht kompilierbares Programm:" + CASE 10: "Einrückung (Leerzeichen am Zeilenanfang) zu groß" + CASE 11: "Anweisung hier nicht erlaubt (ignoriert):" + CASE 12: "Tabellen-Position liegt innerhalb eines b pos:" + CASE 13: "free-Wert > Textteil der Seite (ignoriert)" + CASE 14: "Mehr als 1 Zeichen in pagenr (ignoriert)" + CASE 15: "Macro innerhalb eines Macros definiert (ignoriert):" + CASE 16: "Mehr als drei Seitenzeichen" + CASE 17: "Mehr als zehn Zeilen im Index" + CASE 18: "Index Parameter inkorrekt (ignoriert): " + CASE 19: "Hinter Anweisung darf nichts mehr stehen (ignoriert):" + CASE 20: "Doppelter Index ignoriert:" + CASE 21: "ib(..) fehlt:" + CASE 22: "Inkorrekte Anweisung:" + CASE 23: "2 Byte Zeichen ohne zweites Zeichen am Zeilenende" + CASE 24: "free-Wert größer Seitenlänge (ignoriert):" + CASE 25: "Seitenende in head, bottom oder foot-Bereich plaziert" + CASE 26: "Anzahl columns < 2 ignoriert" + CASE 27: "INT-Parameter <= 0 ignoriert:" + CASE 28: "Kein Textzeichen vor oder hinter b" + CASE 29: "Nochmaliges columns ohne columns end (ignoriert)" + CASE 30: "set count-Parameter inkorrekt (ignoriert):" + CASE 31: "end ohne vorangehendes head, bottom oder foot" + CASE 32: "Max. Anzahl von Tabellen-Positionen überschritten" + CASE 33: "Macro-Aufruf oder -Definition in einem Macro (ignoriert):" + CASE 34: "counter nicht initialisiert (ignoriert):" + CASE 35: "store counter Kennung bereits vorhanden (ignoriert):" + CASE 36: "Spaltenbreite > limit" + CASE 37: "Zentimeter-Angabe in limit = 0 (ignoriert)" + CASE 38: "Zentimeter-Angabe inkorrekt (ignoriert):" + CASE 39: "Zentimeter-Angabe > als eingestelltes limit (ignoriert):" + CASE 40: "Makro-Definition (ignoriert):" + CASE 41: "Nochmaliges table ohne table end (ignoriert)" + CASE 42: "pos bereits hier gesetzt (ignoriert):" + CASE 43: "Druckposition (pos) nicht vorhanden:" + CASE 44: "Text breiter als Spalte bei:" + CASE 45: "rpos überschreibt vorherige Spalte bei:" + CASE 46: "cpos überschreibt vorherige Spalte bei:" + CASE 47: "dpos überschreibt vorherige Spalte bei:" + CASE 48: "Geblockter Text breiter als Spalte bei:" + CASE 49: "table end fehlt" + CASE 50: "Zentrierzeichen für dpos fehlt bei:" + CASE 51: "e-Anweisung ohne vorangehendes d oder u" + CASE 52: "fehlendes e auf dieser Zeile" + CASE 53: "Wort mit Exponent oder Index zu lang" + CASE 54: "Modifikation bereits angeschaltet bei on:" + CASE 55: "Modifikation nicht angeschaltet bei off:" + CASE 56: "Index bereits angeschaltet bei ib:" + CASE 57: "Index nicht angeschaltet bei ie:" + CASE 58: "Inkorrekte direkte Drucker-Anweisung (TEXT-Denoter):" + CASE 59: "tableend ohne vorangehendes table" + CASE 60: "put counter fehlt für:" + CASE 61: "store counter fehlt für:" + OTHERWISE "" + ENDSELECT. + +zusatz: + SELECT error nr OF + CASE 1: "type-Anweisung korrigieren" + CASE 2: "Bitte Einfügen" + CASE 3: "Geschachtelte Fußnoten sind nicht möglich" + CASE 4: "Beispiel: limit(16.0)" + CASE 5: "Beispiele: page(4), pagenr(""%"",4)" + CASE 6: "Trennung erscheint nicht im Ausdruck!" + CASE 7: "Index in Indexdatei ggf. vervollständigen" + CASE 10: "für Zeilenbreite (limit): Leerzeichen entfernen" + CASE 11: "(In head-, bottom- und foot-Bereichen)" + CASE 13: "Parameterwert verkleinern" + CASE 14: "Beispiel: pagenr(""$"",5)" + CASE 15: "Macros kontrollieren und ggf. neu laden" + CASE 16: "sind z.Z. nicht zugelassen" + CASE 17: "ie(..) vergessen?" + CASE 18: "1.Parameter gibt die Index-Nummer (1-10) an. Beispiel: ie(9)" + CASE 19: "Anweisung muß alleine oder am Zeilenende stehen" + CASE 24: "in einem head, bottom oder foot-Bereich" + CASE 25: "Vor oder hinter den Bereich plazieren" + CASE 26: "1.Parameter in columns korrigieren" + CASE 27: "Beispiel: page(20)" + CASE 29: "page und columnsend vorher einfügen" + CASE 30: "Beispiele: setcount(0); setcount(27)" + CASE 31: "end ggf. entfernen" + CASE 34: "Bitte set counter einfuegen" + CASE 37: "Muß positiv sein" + CASE 38: "Beispiel: limit(16.0)" + CASE 40: "pos-Anweisungen vor table plazieren" + CASE 41: "tableend vergessen?" + CASE 42: "Bitte pos-Anweisungen überprüfen" + CASE 43: "in clear pos-Anweisung" + CASE 48: "Ggf. lineform über die Spalte" + CASE 49: "Bitte vor Dateiende einfügen" + CASE 51, 52: "Bitte u und d-Anweisungen kontrollieren" + CASE 53: "e-Anweisung vergessen?" + CASE 54, 55, 56, 57: "Anweisung in angegebener Zeilennummer überprüfen" + CASE 60: "Bitte store counter Anweisungen überprüfen" + OTHERWISE "Bitte Korrigieren" + END SELECT. +END PROC report text processing error; + +PROC report text processing warning (INT CONST error nr, + INT CONST line nr, + TEXT VAR message, + TEXT CONST addition): + + einfache meldung aufbauen; + meldung in fehlerdatei ausgeben. + +einfache meldung aufbauen: + message := "WARNUNG Zeile "; + message CAT text (line nr); + message CAT ": "; + message CAT simple message; + message CAT " "; + message CAT addition. + +meldung in fehlerdatei ausgeben: + note (message); + note line; + fehlerdummy := " >>> "; + fehlerdummy CAT zusatz; + note (fehlerdummy); + note line. + +simple message: + SELECT error nr OF + CASE 1, 2: "" + CASE 3: "Nicht referenziert:" + CASE 4: "Ziel-Referenz fehlt:" + CASE 5: "Modifikation bei Dateiende nicht ausgeschaltet:" + CASE 6: "Index bei Dateiende nicht ausgeschaltet:" + CASE 7: "Nicht getrenntes Wort zu lang für Zeilenbreite:" + CASE 8: "Umschaltung auf gleichen Schrifttyp:" + CASE 9: "Kennzeichen schon vorhanden (Duplikat ignoriert):" + CASE 10: "Tabellenzeile breiter als limit" + CASE 11: "Mehr Spalten als Tabellen-Positionen bei:" + CASE 12: "Ãœberschreibung nach" + CASE 13: "Leerzeichen vor:" + CASE 14: "Weniger Spalten als Tabellen-Positionen" + CASE 15: "counter mit dieser Kennung bereits initialisiert:" + OTHERWISE "" + ENDSELECT. + +zusatz: + SELECT error nr OF + CASE 3: "topage oder value fehlt" + CASE 4: "goalpage oder value fehlt" + CASE 7: "Bitte nachträglich trennen!" + CASE 8: "Schrifttyp wurde darum nicht verändert!" + CASE 9: "count und goalpage überprüfen" + CASE 12: "Bitte fehlende Leerzeichen einfügen" + CASE 13: "erzeugt ggf. zusätzliche Leerzeile" + OTHERWISE "Bitte überprüfen" + END SELECT. +END PROC report text processing warning; +END PACKET texter errors and common; + diff --git a/system/base/1.7.5/src/thesaurus b/system/base/1.7.5/src/thesaurus new file mode 100644 index 0000000..5ef7251 --- /dev/null +++ b/system/base/1.7.5/src/thesaurus @@ -0,0 +1,332 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PACKET thesaurus handling (* Autor: J.Liedtke *) + + DEFINES THESAURUS , + := , + empty thesaurus , + insert, (* fuegt ein Element ein *) + delete, (* loescht ein Element falls vorhanden*) + rename, (* aendert ein Element falls vorhanden*) + CONTAINS , (* stellt fest, ob enthalten *) + link , (* index in thesaurus *) + name , (* name of entry *) + get , (* get next entry ("" is eof)*) + highest entry : (* highest valid index of thes*) + + +TYPE THESAURUS = TEXT ; + +LET thesaurus size = 200 , + nil = 0 , + niltext = "" , + max name length = 80 , + + begin entry char = ""0"" , + end entry char = ""1"" , + + nil entry = ""0""1"" , + nil name = "" , + + quote = """" ; + +TEXT VAR entry ; +INT VAR cache index := 0 , + cache pos ; + + +PROC access (THESAURUS CONST thesaurus, TEXT CONST name) : + + construct entry ; + IF NOT cache identifies entry + THEN search through thesaurus list + FI ; + IF entry found + THEN cache index := code (list SUB (cache pos - 1)) + ELSE cache index := 0 + FI . + +construct entry : + entry := begin entry char ; + entry CAT name ; + decode invalid chars (entry, 2) ; + entry CAT end entry char . + +search through thesaurus list : + cache pos := pos (list, entry) . + +cache identifies entry : + cache pos <> 0 AND + pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos . + +entry found : cache pos > 0 . + +list : CONCR (thesaurus) . + +ENDPROC access ; + +PROC access (THESAURUS CONST thesaurus, INT CONST index) : + + IF cache identifies index + THEN cache index := index ; + construct entry + ELSE cache pos := pos (list, code (index) + begin entry char) ; + IF entry found + THEN cache pos INCR 1 ; + cache index := index ; + construct entry + ELSE cache index := 0 ; + entry := niltext + FI + FI . + +construct entry : + entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) . + +cache identifies index : + subtext (list, cache pos-1, cache pos) = code (index) + begin entry char . + +entry found : cache pos > 0 . + +list : CONCR (thesaurus) . + +ENDPROC access ; + + + +THESAURUS PROC empty thesaurus : + + THESAURUS : (""1"") + +ENDPROC empty thesaurus ; + + +OP := (THESAURUS VAR dest, THESAURUS CONST source ) : + + CONCR (dest) := CONCR (source) . + +ENDOP := ; + +TEXT VAR insert name ; + +PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) : + + insert name := name ; + decode invalid chars (insert name, 1) ; + IF insert name = "" OR LENGTH insert name > max name length + THEN index := nil ; errorstop ("Name unzulaessig") + ELSE insert element + FI . + +insert element : + search free entry ; + IF entry found + THEN insert into directory + ELSE add entry to directory if possible + FI . + +search free entry : + access (thesaurus, nil name) . + +insert into directory : + change (list, cache pos + 1, cache pos, insert name) ; + index := cache index . + +add entry to directory if possible : + INT CONST next free index := code (list SUB LENGTH list) ; + IF next free index <= thesaurus size + THEN add entry to directory + ELSE directory overflow + FI . + +add entry to directory : + list CAT begin entry char ; + cache pos := LENGTH list ; + cache index := next free index ; + list CAT insert name ; + list CAT end entry char + code (next free index + 1) ; + index := cache index . + +directory overflow : + index := nil . + +entry found : cache index > 0 . + +list : CONCR (thesaurus) . + +ENDPROC insert ; + +PROC decode invalid chars (TEXT VAR name, INT CONST start pos) : + + INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ; + WHILE invalid char pos > 0 REP + change (name, invalid char pos, invalid char pos, decoded char) ; + invalid char pos := pos (name, ""0"", ""31"", invalid char pos) + PER . + +decoded char : quote + text(code(name SUB invalid char pos)) + quote. + +ENDPROC decode invalid chars ; + +PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) : + + INT VAR index ; + insert (thesaurus, name, index) ; + IF index = nil AND NOT is error + THEN errorstop ("THESAURUS-Ueberlauf") + FI . + +ENDPROC insert ; + +PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) : + + access (thesaurus, name) ; + index := cache index ; + delete (thesaurus, index) . + +ENDPROC delete ; + +PROC delete (THESAURUS VAR thesaurus, INT CONST index) : + + access (thesaurus, index) ; + IF entry found + THEN delete entry + FI . + +delete entry : + IF is last entry of thesaurus + THEN cut off as much as possible + ELSE set to nil entry + FI . + +set to nil entry : + change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) . + +cut off as much as possible : + WHILE predecessor is also nil entry REP + set cache to this entry + PER ; + list := subtext (list, 1, cache pos - 1) ; + erase cache . + +predecessor is also nil entry : + subtext (list, cache pos - 3, cache pos - 2) = nil entry . + +set cache to this entry : + cache pos DECR 3 . + +erase cache : + cache pos := 0 ; + cache index := 0 . + +is last entry of thesaurus : + pos (list, end entry char, cache pos) = LENGTH list - 1 . + +list : CONCR (thesaurus) . + +entry found : cache index > nil . + +ENDPROC delete ; + + +BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) : + + IF name = niltext OR LENGTH name > max name length + THEN FALSE + ELSE access (thesaurus, name) ; entry found + FI . + +entry found : cache index > nil . + +ENDOP CONTAINS ; + +PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) : + + rename (thesaurus, link (thesaurus, old), new) + +ENDPROC rename ; + +PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) : + + insert name := new ; + decode invalid chars (insert name, 1) ; + IF insert name = "" OR LENGTH insert name > max name length + THEN errorstop ("Name unzulaessig") + ELSE change to new name + FI . + +change to new name : + access (thesaurus, index) ; + IF cache index <> 0 AND entry <> "" + THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name) + FI . + +list : CONCR (thesaurus) . + +ENDPROC rename ; + +INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) : + + access (thesaurus, name) ; + cache index . + +ENDPROC link ; + +TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) : + + access (thesaurus, index) ; + subtext (entry, 2, LENGTH entry - 1) . + +ENDPROC name ; + +PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) : + + identify index ; + REP + to next entry + UNTIL end of list COR valid entry found PER . + +identify index : + IF index = 0 + THEN cache index := 0 ; + cache pos := 1 + ELSE access (thesaurus, index) + FI . + +to next entry : + cache pos := pos (list, begin entry char, cache pos + 1) ; + IF cache pos > 0 + THEN get entry + ELSE get nil entry + FI . + +get entry : + cache index INCR 1 ; + index := cache index ; + name := subtext (list, cache pos + 1, end entry pos - 1) . + +get nil entry : + cache index := 0 ; + cache pos := 0 ; + index := 0 ; + name := "" . + +end entry pos : pos (list, end entry char, cache pos) . + +end of list : index = 0 . + +valid entry found : name <> "" . + +list : CONCR (thesaurus) . + +ENDPROC get ; + +INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*) + + code (list SUB LENGTH list) - 1 . + +list : CONCR (thesaurus) . + +ENDPROC highest entry ; + +ENDPACKET thesaurus handling ; + diff --git a/system/base/unknown/src/SPOLMAN5.ELA b/system/base/unknown/src/SPOLMAN5.ELA new file mode 100644 index 0000000..99d4ec2 --- /dev/null +++ b/system/base/unknown/src/SPOLMAN5.ELA @@ -0,0 +1,1003 @@ +PACKET queue handler DEFINES enter into que,
+ exists in que,
+ all in que,
+ erase from que,
+ erase last top of que,
+ get top of que,
+ restore ,
+ list que,
+ info, killer,first,
+ que status,
+ que empty,
+ set entry types,
+ change entry types,
+ initialize que:
+
+
+LET que size = 100,
+
+ empty = 0,
+ used = 1,
+ blocked = 2,
+ nil = 0,
+ user error = 99,
+ unused char = ""0"",
+ used char = ""1"",
+ blocked char= ""2"",
+ ENTRY = STRUCT(TEXT title, TASK origin, TEXT origin name,
+ DATASPACE space, INT storage, acc code ) ;
+
+ROW que size ENTRY VAR que ;
+
+TEXT VAR status list;
+BOOL VAR n ok := FALSE;
+INT VAR top of que,
+ first que entry,
+ last que entry,
+ index ;
+
+.entry: que[index]. ;
+
+PROC initialize que :
+ FOR index FROM 1 UPTO que size REP
+ forget( entry.space );
+ entry.acc code := empty
+ END REP ;
+ first que entry := nil;
+ last que entry := nil;
+ top of que := nil;
+ index := nil;
+ status list := que size * unused char;
+END PROC initialize que ;
+
+initialize que ;
+
+(****************** Interne Queue-Zugriffsoperationen **********************)
+
+INT PROC next (INT CONST pre) :
+ pre MOD que size + 1
+END PROC next ;
+
+PROC block (INT CONST entry number) :
+ que [entry number].acc code := blocked;
+ replace (status list,entry number,blocked char);
+ENDPROC block;
+
+PROC unblock (INT CONST entry number) :
+ que [entry number].acc code := used;
+ replace (status list,entry number,used char);
+ENDPROC unblock;
+
+PROC to next que entry:
+ REP
+ IF index = last que entry OR index = nil
+ THEN index := nil ; LEAVE to next que entry
+ FI ;
+ index := next(index)
+ UNTIL entry.acc code <> empty PER
+END PROC to next que entry ;
+
+PROC to first que entry :
+ index := first que entry
+END PROC to first que entry ;
+
+PROC search que entry (TEXT CONST title, TASK CONST origin) :
+
+ check if index identifies entry ;
+ IF last que entry = nil
+ THEN index := nil
+ ELSE index := last que entry ;
+ REPEAT
+ IF is wanted entry
+ THEN LEAVE search que entry
+ FI ;
+ IF index = first que entry
+ THEN index := nil
+ ELSE index DECR 1 ;
+ IF index = 0
+ THEN index := que size
+ FI
+ FI
+ UNTIL index = nil PER
+ FI.
+
+is wanted entry:
+
+ entry.acc code <> empty CAND
+ entry.title = title CAND
+ (entry.origin = origin OR
+ origin = niltask ).
+
+check if index identifies entry:
+
+ IF index <> nil CAND is wanted entry
+ THEN LEAVE search que entry
+ FI
+
+END PROC search que entry ;
+
+PROC exec erase :
+
+ forget (entry.space) ; entry.acc code := empty ;
+ replace (status list,index,unused char);
+ try to cut off queue ends.
+
+try to cut off queue ends:
+
+ WHILE first entry is not valid REP
+ check if que empty ;
+ first que entry := next(first que entry)
+ END REP ;
+ WHILE last entry is not valid REP
+ make index invalid if necessary ;
+ last que entry DECR 1 ;
+ IF last que entry = 0
+ THEN last que entry := que size
+ FI
+ END REP .
+
+first entry is not valid:
+ que [first que entry].acc code = empty.
+
+last entry is not valid:
+ que [last que entry].acc code = empty.
+
+check if que empty:
+ IF first que entry = last que entry
+ THEN first que entry := nil ;
+ last que entry := nil ;
+ index := nil ;
+ LEAVE try to cut off queue ends
+ FI.
+
+make index invalid if necessary:
+ IF index = last que entry
+ THEN index := nil
+ FI.
+
+END PROC exec erase ;
+
+PROC exec first:
+ IF next (last que entry) = first que entry
+ THEN errorstop ("Queue ist voll - vorziehen unmoeglich")
+ ELIF index = top of que
+ THEN errorstop ("Auftrag wird bereits bearbeitet")
+ ELIF entry.acc code = empty
+ THEN errorstop ("undefinierter Queue-Eintrag. /exec first")
+ ELSE first que entry DECR 1 ;
+ IF first que entry = 0
+ THEN first que entry := que size
+ FI ;
+ que[first que entry] := que[index] ;
+ replace (status list,first que entry,code (entry.acc code));
+ exec erase
+ FI
+END PROC exec first ;
+
+PROC erase last top of que:
+ IF top of que <> nil
+ THEN index := top of que; exec erase;
+ top of que := nil
+ FI
+END PROC erase last top of que;
+
+
+(****************** Behandlung von DATASPACE-typen ***********************)
+
+LET semicolon = ";" ,
+ colon = ":" ,
+ quote = """";
+TEXT VAR entry types :: "" ;
+
+BOOL PROC no permitted type (DATASPACE CONST ds) :
+ TEXT CONST type nr :: semicolon + text(type(ds)) + colon;
+ INT CONST t pos :: pos (entry types,type nr) ;
+ entry types <> "" CAND t pos = 0
+END PROC no permitted type ;
+
+TEXT PROC record of que entry:
+ IF entry.acc code = empty
+ THEN errorstop ("undefinierter Queue-Eintrag. /record");""
+ ELSE TEXT VAR record :: "" ;
+ record CAT storage in k ;
+ record CAT type of entry ;
+ record CAT name of entry ;
+ record CAT origin of entry ;
+ IF entry.acc code = blocked THEN record CAT "- blocked -" FI;
+ record
+ FI.
+
+storage in k:
+
+ text (entry.storage,3) + " K ".
+
+type of entry:
+
+ IF entry types = ""
+ THEN 12 * "?"
+ ELSE TEXT CONST type nr :: semicolon + text(type(entry.space)) + colon ;
+ INT CONST semi colon pos :: pos (entry types, type nr),
+ start type :: semi colon pos + LENGTH type nr ,
+ end type :: pos(entrytypes,semicolon,starttype)-1;
+ IF semi colon pos = 0
+ THEN 12 * "?"
+ ELSE text( subtext(entry types, starttype, endtype),12)
+ FI
+ FI.
+
+name of entry:
+
+ text (quote+ entry.title +quote, 20) .
+
+origin of entry:
+
+ IF entry.origin = niltask
+ THEN 20 * " "
+ ELSE text (" TASK: "+entry.origin name,20)
+ FI
+
+END PROC record of que entry ;
+
+PROC set entry types (TEXT CONST t) :
+ check if void ;
+ IF first char is no semicolon
+ THEN entry types := semicolon
+ ELSE entry types := ""
+ FI;
+ entry types CAT t ;
+ IF last char is no semicolon
+ THEN entry types CAT semicolon
+ FI.
+
+check if void:
+ IF t = ""
+ THEN entry types := "";
+ LEAVE set entry types
+ FI.
+
+first char is no semicolon:
+ (t SUB 1) <> semicolon.
+
+last char is no semicolon:
+ (t SUB length(t)) <> semicolon
+
+END PROC set entry types ;
+
+PROC change entry types:
+ TEXT VAR t :: entry types;
+ line;putline("Entrytypes :");
+ editget(t);
+ set entry types (t)
+END PROC change entry types;
+
+
+(************************ Std Zugriffe auf Queue ***************************)
+
+
+PROC erase from que (TEXT CONST title, TASK CONST origin) :
+ search que entry (title, origin) ;
+ IF index = nil
+ THEN errorstop ("Auftrag existiert nicht. /erase")
+ ELIF index = top of que
+ THEN errorstop (user error, "Dieser Auftrag wird bereits bearbeitet")
+ ELSE exec erase
+ FI
+END PROC erase from que ;
+
+BOOL PROC exists in que (TEXT CONST title, TASK CONST origin) :
+ search que entry (title, origin) ;
+ index <> nil
+END PROC exists in que ;
+
+PROC info (BOOL CONST b) : n ok := b ENDPROC info;
+
+THESAURUS PROC all in que (TASK CONST origin) :
+
+ THESAURUS VAR result := empty thesaurus ;
+ to first que entry ;
+ WHILE index <> 0 REP
+ IF entry.origin = origin OR origin = niltask
+ THEN insert (result, entry.title)
+ FI ;
+ to next que entry
+ END REP ;
+ result
+
+END PROC all in que ;
+
+PROC enter into que (TEXT CONST title, TASK CONST origin,
+ DATASPACE CONST space ):
+
+ IF next(last que entry) = first que entry
+ THEN errorstop ("Queue zu voll")
+ ELIF no permitted type (space) OR title = ""
+ THEN errorstop (user error, "Auftrag wird nicht angenommen")
+ ELSE last que entry := next(last que entry);
+ index := last que entry;
+ entry := ENTRY:
+ ( title, origin,task name, space, storage(space), used ) ;
+ IF first que entry = nil
+ THEN first que entry := 1
+ FI ;
+ replace (status list,last que entry,used char);
+ FI.
+
+task name :
+ TEXT VAR name of task :: name (origin);
+ IF name of task = "stemmer" AND n ok THEN "stemmi" ELSE name of task FI.
+
+END PROC enter into que ;
+
+PROC get top of que (DATASPACE VAR top space) :
+ forget (top space) ;
+ IF que empty
+ THEN errorstop ("kein Auftrag vorhanden. /get")
+ ELSE erase last top of que;
+ top of que := first que entry;
+ IF que [top of que].acc code = blocked THEN
+ wrap around if necessary
+ ELSE top space := que [first que entry].space ; FI;
+ FI .
+
+wrap around if necessary :
+
+ IF entry is allowed to be printed THEN
+ give it to spool manager
+ ELSE enter into end of queue FI.
+
+entry is allowed to be printed :
+ pos (status list,used char) = nil.
+
+give it to spool manager :
+ top space := que [first que entry].space;
+ que [first que entry].acc code := used.
+
+enter into end of queue :
+ top space := que [first que entry].space;
+ enter into que (que [first que entry].title,que [first que entry].origin
+ ,top space);
+ index := first que entry;
+ IF entry.acc code = blocked THEN block (index) FI;
+ get top of que (top space).
+
+END PROC get top of que ;
+
+PROC restore:
+ top of que := nil
+END PROC restore ;
+
+BOOL PROC que empty: (* 'top of que' gilt nicht *)
+ first que entry = last que entry AND
+ top of que = last que entry.
+END PROC que empty ;
+
+PROC que status (INT VAR size, TEXT VAR top title,
+ TASK VAR top origin, TEXT VAR top origin name ):
+
+ size := last que entry - first que entry ; (* geloeschte Eintraege *)
+ IF size < 0 (* zaehlen mit !! *)
+ THEN size INCR que size (* (aber nicht 'top' ) *)
+ FI ;
+ IF top of que <> nil
+ THEN top title := que [top of que].title ;
+ top origin := que [top of que].origin ;
+ top origin name := que [top of que].origin name
+ ELSE size INCR 1 ;
+ top title := "" ;
+ top origin := niltask ;
+ top origin name := ""
+ FI
+END PROC que status ;
+
+TEXT VAR sep :: 79 * "_", record :: "",
+ ask :: "editieren (e),kopieren (k),loeschen (l)," +
+ "vorziehen (v),duplizieren (d),"13""10"" +
+ "print --> quickprint (q),blockieren (b),freigeben (f)," +
+ "weiter (w) ? ";
+
+PROC info :
+
+ to first que entry;
+ WHILE index <> nil REP
+ record := record of que entry;
+ WHILE index <> top of que REPEAT
+ ask user what to do;
+ out (input char);
+ exec command
+ UNTIL command index = 1 PER;
+ to next que entry;
+ PER.
+
+ask user what to do :
+
+ out (""13""10"");out (sep);out (""13""10""13""10"");
+ out (record);
+ out (""13""10""10"");out (ask);
+ INT VAR command index; TEXT VAR input char;
+ REPEAT
+ inchar (input char);
+ command index := pos ("w eklvdqbf",input char);
+ UNTIL command index > 0 PER.
+
+exec command :
+
+ SELECT command index OF
+ CASE 3 : INT VAR old dataspace type := type (entry.space);
+ type (entry.space,1003);
+ FILE VAR f :: sequentialfile (modify,entry.space);
+ edit (f); line (2);
+ type (entry.space,old dataspace type)
+ CASE 4 : forget (entry.title,quiet);
+ copy (entry.space,entry.title);
+ type (old (entry.title),1003)
+ CASE 5 : exec erase ;command index := 1
+ CASE 6 : exec first ;command index := 1
+ CASE 7 : INT VAR dummy no := index;
+ enter into que (que [dummy no].title,que [dummy no].origin,
+ que [dummy no].space)
+ CASE 8 : type (entry.space,1103) ;record := record of que entry;
+ CASE 9 : block (index) ;record := record of que entry;
+ CASE 10: unblock (index); record := record of que entry;
+ ENDSELECT.
+
+ENDPROC info;
+
+PROC list que (FILE VAR f, DATASPACE VAR ds) :
+ open listfile ;
+ to first que entry ;
+ WHILE index <> nil REP
+ TEXT VAR record :: record of que entry ;
+ IF index = top of que
+ THEN record := text(record,60) ;
+ record CAT ""15"wird bearbeitet"14""
+ FI ;
+ putline (f,record) ;
+ to next que entry
+ END REP.
+
+open listfile:
+
+ forget (ds) ;
+ ds := nilspace ;
+ f := sequentialfile (output,ds) ;
+ headline (f, name(myself) + " - Queue") ;
+ line (f)
+
+END PROC list que ;
+
+PROC killer : info ENDPROC killer;
+PROC first : info ENDPROC first;
+
+END PACKET queue handler ;
+
+(***************************************************************************)
+(* Programm zur Verwaltung einer Servertask *)
+(* (benutzt 'queue handler') *)
+(* Autor: A.Vox *)
+(* Stand: 3.6.85 *)
+(* *)
+(***************************************************************************)
+PACKET spool manager DEFINES server status,
+ server modus,
+ server task,
+ server channel,
+ server routine,
+ server fail msg,
+
+ log edit,
+ logline,
+ logfilename,
+ check,
+ feed server if hungry,
+ check if server vanished,
+
+ spool manager,
+ get title and origin,
+
+ start,
+ stop,
+ pause,
+ spool info,
+ list,
+ spool maintenance:
+
+
+ LET user error = 99;
+
+ LET { Status: } { Modus: }
+ init = 0, active = 0,
+ work = 1, paused = 1,
+ wait = 2, stopped = 2,
+ dead = 3;
+
+ LET cmd form feed = ""12"";
+
+INT VAR status :: init,
+ modus :: stopped;
+
+TASK VAR server :: niltask;
+TEXT VAR routine :: "",
+ fail msg:: "";
+INT VAR channel :: 0;
+(************ Globale Variablen fuer alle 'que status'-Aufrufe ************)
+
+INT VAR que size;
+TEXT VAR actual title,
+ actual origin name;
+TASK VAR actual origin;
+
+
+(*********** Zugriffsoperationen auf wichtige Paketvariablen **************)
+
+TASK PROC servertask : server END PROC servertask;
+INT PROC serverstatus : status END PROC serverstatus;
+INT PROC servermodus : modus END PROC servermodus;
+TEXT PROC serverroutine : routine END PROC serverroutine;
+TEXT PROC serverfailmsg : fail msg END PROC serverfailmsg;
+INT PROC serverchannel : channel END PROC serverchannel;
+
+PROC serverroutine (TEXT CONST neu):
+ routine := neu
+END PROC serverroutine;
+
+PROC serverfailmsg (TEXT CONST neu):
+ failmsg := neu
+END PROC serverfailmsg;
+
+PROC serverchannel (INT CONST neu):
+ channel := neu
+END PROC serverchannel;
+
+(************************* Basic Spool Routines ***************************)
+
+TEXT CONST logfilename :: "Vorkommnisse";
+FILE VAR logfile;
+
+TEXT VAR fail title :: "" ;
+TASK VAR fail origin :: niltask ;
+REAL VAR fail time :: 0.0 ;
+
+PROC logline (TEXT CONST mess):
+ logfile := sequential file(output, logfilename) ;
+ clear file if too large ;
+ put(logfile, date);
+ put(logfile, time of day);
+ put(logfile, " : ");
+ putline(logfile, mess)
+END PROC logline ;
+
+PROC log edit:
+ enable stop ;
+ IF NOT exists(logfilename)
+ THEN errorstop ("keine Eintragungen vorhanden")
+ ELSE logfile := sequentialfile(modify,logfilename) ;
+ position to actual page;
+ edit(logfile);
+ line (2);
+ forget (logfilename);
+ FI.
+
+position to actual page:
+
+ INT CONST begin of last page :: lines(logfile)-22 ;
+ logfile := sequential file(modify,logfilename);
+ IF begin of last page < 1
+ THEN toline(logfile,1)
+ ELSE toline(logfile,begin of last page)
+ FI
+
+END PROC logedit;
+
+PROC clear file if too large:
+ IF lines(logfile) > 1000
+ THEN modify (logfile) ;
+ toline (logfile, 900) ;
+ remove (logfile, 900) ;
+ clear removed (logfile) ;
+ output (logfile)
+ FI
+END PROC clear file if too large ;
+
+PROC end server (TEXT CONST mess):
+ access catalogue;
+ IF exists (server) CAND son(myself) = server
+ THEN end(server)
+ FI;
+ failtime := clock(1);
+ que status (que size, fail title, fail origin, actual origin name) ;
+ logline (mess) ;
+ IF fail title <> ""
+ THEN logline(""""+fail title+""" von Task: "+actual origin name)
+ ELSE logline("kein Auftrag betroffen")
+ FI ;
+ status := dead ;
+ server := niltask
+END PROC end server;
+
+PROC check (TEXT CONST title, TASK CONST origin):
+ check if server vanished ;
+ IF less than 3 days ago AND
+ was failure AND
+ title matches AND
+ origin matches
+ THEN fail origin := myself ;
+ errorstop (user error, """"+fail title+""" abgebrochen")
+ FI.
+
+less than 3 days ago:
+ clock(1) < fail time + 3.0 * day.
+
+origin matches:
+ (origin = fail origin OR origin = niltask).
+
+title matches:
+ (title = fail title OR title = "").
+
+was failure:
+ fail title <> ""
+
+END PROC check ;
+
+PROC start server:
+ begin (PROC server start,server) ;
+ status := init
+END PROC start server;
+
+PROC server start:
+ disable stop ;
+ IF channel <> 0
+ THEN continue (channel) ;
+ FI ;
+ command dialogue (FALSE) ;
+ out (cmd form feed);
+ do (routine) ;
+ IF is error
+ THEN call(logline code, "Server-Fehler :",father);
+ call(logline code, error message, father) ;
+ call(logline code, "Zeile: " + text(errorline) +
+ " Code: " + text(errorcode) ,father)
+ ELSE call(logline code, "Ende des Server-Programms erreicht",father)
+ FI ;
+ IF online
+ THEN out (fail msg)
+ FI ;
+ call (terminate code,fail msg, father) ;
+ end (myself)
+END PROC server start ;
+
+PROC check if server vanished:
+ IF NOT (server = nil task) CAND NOT exists (server)
+ THEN end server ("Server gestorben :") ;
+ start server
+ FI
+END PROC check if server vanished;
+
+
+(*************************** Manager Routines *****************************)
+
+ LET ack = 0,
+ second phase ack = 5,
+ not existing nak = 6,
+
+ begin code = 4,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ clear code = 18,
+ release code = 20,
+ check code = 22,
+
+ terminate code = 25,
+ logline code = 26,
+ get title code = 27,
+
+ continue code = 100;
+
+
+DATASPACE VAR packet space ;
+INT VAR reply ;
+BOUND STRUCT(TEXT f name,a,b) VAR msg ;
+.f name: msg.f name. ;
+
+TEXT VAR save title :: "";
+FILE VAR listfile;
+
+PROC get title and origin (TEXT VAR title, origin):
+ forget (packet space) ;
+ packet space := nilspace ;
+ call (father, get title code, packet space, reply) ;
+ IF reply = ack
+ THEN msg := packet space ;
+ title := msg.f name ;
+ origin := msg.a ;
+ forget (packet space)
+ ELSE forget (packet space) ;
+ errorstop ("'get title' nicht erfolgreich. Antwort="+text(reply))
+ FI
+END PROC get title and origin;
+
+PROC feed server if hungry:
+ check if server vanished ;
+ IF status = wait AND NOT que empty
+ THEN get top of que (packet space) ;
+ send (server, ack, packet space, reply) ;
+ forget (packet space) ;
+ IF reply = ack
+ THEN status := work
+ ELSE restore ;
+ end server ("Server nimmt keinen Auftrag an") ;
+ start server
+ FI
+ FI
+ENDPROC feed server if hungry;
+
+PROC server request (DATASPACE VAR ds, INT CONST order, phase) :
+
+ enable stop ;
+ msg := ds ;
+ SELECT order OF
+ CASE terminate code: terminate
+ CASE logline code: logline (f name) ;send(server, ack, ds)
+ CASE get title code: send title
+ OTHERWISE
+ IF order = fetch code CAND f name = "-"
+ THEN send top of que
+ ELSE freemanager (ds,order,phase,server)
+ FI
+ END SELECT ;
+ forget(ds).
+
+terminate:
+ end server ("Server terminiert :") ;
+ start server.
+
+send title:
+ forget (ds) ;
+ ds := nilspace ;
+ msg := ds ;
+ que status (que size, msg.f name, actual origin, msg.a) ;
+ send (server, ack, ds).
+
+send top of que:
+ status := wait ;
+ erase last top of que ;
+ IF modus = active
+ THEN feed server if hungry
+ FI
+
+END PROC server request;
+
+PROC spool manager(DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+
+ IF ordertask < myself
+ THEN server request (ds,order,phase)
+ ELIF ordertask = supervisor
+ THEN system request
+ ELSE spool command (ds,order,phase,order task)
+ FI;
+ check storage;
+ error protocol.
+
+check storage:
+ INT VAR size, used;
+ storage(size,used);
+ IF used > size
+ THEN logline("Speicher-Engpass :");
+ initialize que;
+ logline("Queue geloescht !!");
+ stop
+ FI.
+
+error protocol:
+ IF is error AND error code <> user error
+ THEN logline ("Spool-Fehler :") ;
+ logline (errormessage) ;
+ logline (" Zeile: " + text(errorline) +
+ " Code: " + text(errorcode) )
+ FI.
+
+system request:
+ IF order > continue code
+ THEN call (supervisor,order,ds,reply) ;
+ forget(ds) ;
+ IF reply = ack
+ THEN spool maintenance
+ FI
+ FI
+
+END PROC spool manager;
+
+PROC spool command (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task):
+
+ enable stop ;
+ check if server vanished ;
+ msg := ds ;
+ SELECT order OF
+ CASE begin code : special begin
+ CASE fetch code: y get logfile
+ CASE save code : y save
+ CASE exists code: y exists
+ CASE erase code: y erase
+ CASE list code: y list
+ CASE all code: y all
+ CASE release code,
+ clear code: y restart
+ CASE check code: y check
+ OTHERWISE errorstop (user error, "Kein Kommando fuer SPOOLER")
+ END SELECT.
+
+special begin :
+ INT VAR dummy;
+ call (public,begin code,ds,dummy);
+ send (order task,ack,ds).
+
+y get logfile:
+ forget(ds) ;
+ ds := old(logfilename) ;
+ send (ordertask, ack, ds).
+
+y erase:
+ IF NOT exists in que (f name,ordertask)
+ THEN manager message(""""+f name+""" steht nicht in der Queue")
+ ELIF phase = 1
+ THEN manager question (""""+f name+""" aus der Queue loeschen")
+ ELSE erase from que (f name,ordertask) ;
+ send (ordertask, ack, ds)
+ FI.
+
+y save:
+ IF phase = 1
+ THEN save title := f name ;
+ send (order task,second phase ack,ds);
+ ELSE enter into que (save title, ordertask, ds) ;
+ IF modus = active
+ THEN feed server if hungry
+ FI ;
+ send (order task,ack,ds);
+ FI.
+
+y list:
+ list que (listfile,ds) ;
+ send (ordertask, ack, ds).
+
+y all:
+ forget(ds) ;
+ ds := nilspace ;
+ BOUND THESAURUS VAR all names := ds ;
+ all names := all in que (ordertask) ;
+ send (ordertask, ack, ds).
+
+y exists:
+ IF exists in que (f name,ordertask)
+ THEN send (ordertask, ack, ds)
+ ELSE send (ordertask, not existing nak, ds)
+ FI.
+
+y check:
+ check (f name,ordertask) ;
+ questatus (que size, actual title, actual origin, actual origin name) ;
+ IF there is a title AND
+ is actual origin AND
+ is actual title
+ THEN manager message (""""+f name+""" wird soeben bearbeitet")
+ ELIF exists in que (f name,ordertask)
+ THEN manager message (""""+f name+""" steht noch in der Queue")
+ ELSE errorstop (usererror, """"+f name+""" steht nicht in der Queue")
+ FI.
+
+ there is a title: actual title <> "" .
+ is actual origin: ordertask = actual origin .
+ is actual title : (f name = "" OR f name = actual title) .
+
+y restart:
+ questatus (que size, actual title, actual origin, actual origin name) ;
+ IF actual origin = ordertask
+ THEN IF phase = 1
+ THEN manager question (""""+actual title+""" unterbrechen")
+ ELSE end server ("unterbrochen durch Auftraggeber :") ;
+ start server ;
+ IF order = clear code
+ THEN restore
+ ELSE erase last top of que
+ FI ;
+ manager message ("Auftrag unterbrochen")
+ FI
+ ELSE errorstop (usererror, "kein eigener Auftrag")
+ FI
+
+END PROC spool command ;
+
+PROC start:
+ IF modus = stopped
+ THEN start server ;
+ modus := active;
+ message ("Server aktiviert")
+ ELIF modus = paused
+ THEN modus := active ;
+ message ("'Pause'-Modus zurueckgesetzt") ;
+ feed server if hungry
+ ELSE message ("Server bereits aktiv")
+ FI
+END PROC start;
+
+PROC stop:
+ IF modus <> stopped
+ THEN end server ("Gestoppt :");
+ modus := stopped ;
+ status := init ;
+ message ("Server gestoppt")
+ ELSE message ("Server bereits gestoppt")
+ FI
+END PROC stop;
+
+PROC pause:
+ IF modus = active
+ THEN modus := paused ;
+ message ("'Pause'-Modus gesetzt")
+ ELIF modus = paused
+ THEN message ("'Pause'-Modus bereits gesetzt")
+ ELSE errorstop ("Server ist gestoppt")
+ FI
+END PROC pause;
+
+PROC message (TEXT CONST mess):
+ say(""13""10"") ;
+ say(mess) ;
+ say(""13""10"")
+END PROC message ;
+
+PROC list:
+ list que(listfile,packet space) ;
+ show(listfile)
+END PROC list;
+
+PROC spool maintenance:
+ command dialogue (TRUE);
+ IF exists(logfilename)
+ THEN logedit
+ FI;
+ WHILE online REP
+ get command ("gib spool kommando :") ;
+ do command
+ END REP ;
+ command dialogue (FALSE) ;
+ break ;
+ set autonom
+END PROC spool maintenance ;
+
+PROC spoolinfo:
+ check if server vanished ;
+ que status (que size, actual title, actual origin, actual origin name) ;
+ line(2) ;
+ putline("Queue :") ;
+ put("Auslastung :");put(que size); line;
+ IF actual title <> ""
+ THEN put("Aktueller Auftrag :");putline(actual title);
+ put(" von Task :");putline(actual origin name)
+ FI ;
+ line ;
+ putline("Server :");
+ put("Status :");
+ SELECT status OF
+ CASE init : putline("initialisiert")
+ CASE work : putline("arbeitet")
+ CASE wait : putline("wartet")
+ OTHERWISE putline("gestorben")
+ END SELECT ;
+ put("Modus :");
+ SELECT modus OF
+ CASE active : putline("aktiv")
+ CASE paused : putline("pausierend")
+ OTHERWISE putline("gestoppt")
+ END SELECT ;
+ put("Kanal :");put(pcb(server,4));
+ line(2)
+END PROC spool info
+
+END PACKET spool manager;
+
diff --git a/system/base/unknown/src/STD.ELA b/system/base/unknown/src/STD.ELA new file mode 100644 index 0000000..047db9a --- /dev/null +++ b/system/base/unknown/src/STD.ELA @@ -0,0 +1,220 @@ +PACKET command dialogue DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 26.04.82 *)
+ command dialogue ,
+ say ,
+ yes ,
+ no ,
+ param position ,
+ last param :
+
+
+LET up = ""3"" ,
+ right = ""2"" ,
+ param pre = " (""" ,
+ param post = """)"13""10"" ;
+
+TEXT VAR std param := "" ;
+
+BOOL VAR dialogue flag := TRUE ;
+
+INT VAR param x := 0 ;
+
+
+BOOL PROC command dialogue :
+ dialogue flag
+ENDPROC command dialogue ;
+
+PROC command dialogue (BOOL CONST status) :
+ dialogue flag := status
+ENDPROC command dialogue ;
+
+
+BOOL PROC yes (TEXT CONST question) :
+
+ IF dialogue flag
+ THEN ask question
+ ELSE TRUE
+ FI .
+
+ask question :
+ put (question) ;
+ skip previous input chars ;
+ put ("(j/n) ?") ;
+ get answer ;
+ IF correct answer
+ THEN putline (answer) ;
+ positive answer
+ ELSE out (""7"") ;
+ LENGTH question + 9 TIMESOUT ""8"" ;
+ yes (question)
+ FI .
+
+get answer :
+ TEXT VAR answer ;
+ inchar (answer) .
+
+correct answer :
+ pos ("jnyJNY", answer) > 0 .
+
+positive answer :
+ pos ("jyJY", answer) > 0 .
+
+skip previous input chars :
+ REP UNTIL incharety = "" PER .
+
+ENDPROC yes ;
+
+BOOL PROC no (TEXT CONST question) :
+
+ NOT yes (question)
+
+ENDPROC no ;
+
+PROC say (TEXT CONST message) :
+
+ IF dialogue flag
+ THEN out (message)
+ FI
+
+ENDPROC say ;
+
+PROC param position (INT CONST x) :
+
+ param x := x
+
+ENDPROC param position ;
+
+TEXT PROC last param :
+
+ IF param x > 0
+ THEN out (up) ;
+ param x TIMESOUT right ;
+ out (param pre) ;
+ out (std param) ;
+ out (param post)
+ FI ;
+ std param
+
+ENDPROC last param ;
+
+PROC last param (TEXT CONST new) :
+ std param := new
+ENDPROC last param ;
+
+ENDPACKET command dialogue ;
+
+
+PACKET input DEFINES (* Stand: 01.05.81 *)
+
+ get ,
+ getline ,
+ get secret line :
+
+
+LET cr = ""13"" ,
+ esc = ""27"" ,
+ rubout = ""12"" ,
+ bell = ""7"" ,
+ back blank back = ""8" "8"" ,
+ del line cr lf = ""5""13""10"" ;
+
+PROC get (TEXT VAR word) :
+
+ REP
+ get (word, " ")
+ UNTIL word <> "" AND word <> " " PER ;
+ delete leading blanks .
+
+delete leading blanks :
+ WHILE (word SUB 1) = " " REP
+ word := subtext (word,2)
+ PER .
+
+ENDPROC get ;
+
+PROC get (TEXT VAR word, TEXT CONST separator) :
+
+ word := "" ;
+ feldseparator (separator) ;
+ editget (word) ;
+ feldseparator ("") ;
+ echoe last char
+
+ENDPROC get ;
+
+PROC echoe last char :
+
+ TEXT CONST last char := feldzeichen ;
+ IF last char = ""13""
+ THEN out (""13""10"")
+ ELSE out (last char)
+ FI
+
+ENDPROC echoe last char ;
+
+PROC get (TEXT VAR word, INT CONST length) :
+
+ word := "" ;
+ feldseparator ("") ;
+ editget (word, length, length) ;
+ echoe last char
+
+ENDPROC get ;
+
+PROC getline (TEXT VAR line ) :
+
+ line := "" ;
+ feldseparator ("") ;
+ editget (line) ;
+ echoe last char
+
+ENDPROC getline ;
+
+PROC get secret line (TEXT VAR line) :
+
+ TEXT VAR char ;
+ line := "" ;
+ get start cursor position ;
+ get line very secret ;
+ IF char = esc
+ THEN get line little secret
+ FI ;
+ cursor to start position ;
+ out (del line cr lf) .
+
+get line very secret :
+ REP
+ inchar (char) ;
+ IF char = esc OR char = cr
+ THEN LEAVE get line very secret
+ ELIF char = rubout
+ THEN delete last char
+ ELIF char >= " "
+ THEN line CAT char ;
+ out (".")
+ ELSE out (bell)
+ FI
+ PER .
+
+delete last char :
+ IF LENGTH line = 0
+ THEN out (bell)
+ ELSE out (back blank back) ;
+ delete char (line, LENGTH line)
+ FI .
+
+get line little secret :
+ feldseparator ("") ;
+ cursor to start position ;
+ editget (line) .
+
+get start cursor position :
+ INT VAR x, y;
+ get cursor (x, y) .
+
+cursor to start position :
+ cursor (x, y) .
+
+ENDPROC get secret line ;
+
+ENDPACKET input ;
diff --git a/system/base/unknown/src/STDPLOT.ELA b/system/base/unknown/src/STDPLOT.ELA new file mode 100644 index 0000000..be55e33 --- /dev/null +++ b/system/base/unknown/src/STDPLOT.ELA @@ -0,0 +1,365 @@ +PACKET std plot DEFINES (* J. Liedtke 06.02.81 *)
+ (* H.Indenbirken, 19.08.82 *)
+ transform,
+ set values,
+
+ clear ,
+ begin plot ,
+ end plot ,
+ dir move,
+ dir draw ,
+ pen,
+ pen info :
+
+LET pen down = "*"8"" ,
+ y raster = 43,
+ display hor = 78.0,
+ display vert = 43.0;
+
+INT CONST up := 1 ,
+ right := 1 ,
+ down := -1 ,
+ left := -1 ;
+
+REAL VAR h min limit :: 0.0, h max limit :: display hor,
+ v min limit :: 0.0, v max limit :: display vert,
+ h :: display hor/2.0, v :: display vert/2.0,
+ size hor :: 23.5, size vert :: 15.5;
+
+ROW 5 ROW 5 REAL VAR p :: ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+ROW 5 ROW 5 REAL VAR result;
+INT VAR i, j;
+
+ROW 5 ROW 5 REAL OP * (ROW 5 ROW 5 REAL CONST l, r) :
+ ROW 5 ROW 5 REAL VAR erg;
+ FOR i FROM 1 UPTO 5
+ REP FOR j FROM 1 UPTO 5
+ REP erg [i] [j] := zeile i mal spalte j
+ PER
+ PER;
+ erg .
+
+zeile i mal spalte j :
+ INT VAR k;
+ REAL VAR summe :: 0.0;
+ FOR k FROM 1 UPTO 5
+ REP summe INCR zeile i * spalte j PER;
+ summe .
+
+zeile i : l [i] [k] .
+
+spalte j : r [k] [j] .
+
+END OP *;
+
+PROC set values (ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 3 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ norm p;
+ set views;
+ calc two dim extrema;
+ calc limits;
+ calc result values .
+
+norm p :
+ p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0/dx, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 1.0/dy, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 1.0/dz, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (size [1][1]/dx, size [2][1]/dy,
+ size [3][1]/dz, 0.0, 1.0)) .
+
+dx : size [1][2] - size [1][1] .
+dy : size [2][2] - size [2][1] .
+dz : size [3][2] - size [3][1] .
+
+set views :
+ REAL VAR sin a := sind (angles [1]), cos a := cosd (angles [1]),
+ sin p := sind (angles [2]), cos p := cosd (angles [2]),
+ sin t := sind (angles [3]), cos t := cosd (angles [3]),
+ norm a :: oblique [1] * p [1][1],
+ norm b :: oblique [2] * p [2][2],
+ norm cx :: perspective [1] * p [1][1],
+ norm cy :: perspective [2] * p [2][2],
+ norm cz :: perspective [3] * p [3][3];
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (cos p*cos t, -sin p, cos p*sin t, 0.0, 0.0),
+ ROW 5 REAL : (sin p*cos t, cos p, sin p*sin t, 0.0, 0.0),
+ ROW 5 REAL : ( -sin t, 0.0, cos t, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p*result;
+
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( 1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( norm a, norm b, 0.0, norm cz, 0.0),
+ ROW 5 REAL : (-norm cx, -norm cy, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p * result;
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (cos a,-sin a, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (sin a, cos a, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p * result .
+
+calc two dim extrema :
+ REAL VAR max x :: - max real, min x :: max real,
+ max y :: - max real, min y :: max real, x, y;
+
+ transform (size [1][1], size [2][1], size [3][1], x, y);
+ extrema;
+ transform (size [1][2], size [2][1], size [3][1], x, y);
+ extrema;
+ transform (size [1][2], size [2][2], size [3][1], x, y);
+ extrema;
+ transform (size [1][1], size [2][2], size [3][1], x, y);
+ extrema;
+ transform (size [1][1], size [2][1], size [3][2], x, y);
+ extrema;
+ transform (size [1][2], size [2][1], size [3][2], x, y);
+ extrema;
+ transform (size [1][2], size [2][2], size [3][2], x, y);
+ extrema;
+ transform (size [1][1], size [2][2], size [3][2], x, y);
+ extrema .
+
+extrema :
+ min x := min (min x, x);
+ max x := max (max x, x);
+
+ min y := min (min y, y);
+ max y := max (max y, y) .
+
+calc limits :
+ IF all limits smaller than 2
+ THEN prozente
+ ELSE zentimeter FI .
+
+all limits smaller than 2 :
+ limits [1][2] < 2.0 AND limits [2][2] < 2.0 .
+
+prozente :
+ h min limit := limits [1][1] * display hor * (size vert/size hor);
+ h max limit := limits [1][2] * display hor * (size vert/size hor);
+
+ v min limit := limits [2][1] * display vert;
+ v max limit := limits [2][2] * display vert .
+
+zentimeter :
+ h min limit := display hor * (limits [1][1]/size hor);
+ h max limit := display hor * (limits [1][2]/size hor);
+
+ v min limit := display vert * (limits [2][1]/size vert);
+ v max limit := display vert * (limits [2][2]/size vert) .
+
+calc result values :
+ REAL VAR sh := (h max limit - h min limit) / (max x - min x),
+ sv := (v max limit - v min limit) / (max y - min y),
+ dh := h min limit - min x*sh,
+ dv := v min limit - min y*sv;
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( sh, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, sv, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( dh, dv, 0.0, 0.0, 1.0));
+ p := p * result .
+
+END PROC set values;
+
+PROC transform (REAL CONST x, y, z, REAL VAR h, v) :
+ REAL CONST w :: 1.0/(x*p [1][4] + y*p [2][4] + z*p [3][4] + p [4][4]);
+
+ h := (x*p [1][1]+y*p [2][1]+z*p [3][1]+p [4][1])*w + p [5][1];
+ v := (x*p [1][2]+y*p [2][2]+z*p [3][2]+p [4][2])*w + p [5][2];
+END PROC transform;
+
+(************************** Eigentliches plot *************************)
+INT VAR x pos := 0 ,
+ y pos := 0 ,
+ new x pos ,
+ new y pos ;
+
+ROW 24 TEXT VAR display;
+clear ;
+
+PROC clear :
+
+ INT VAR i;
+ display (1) := 79 * " " ;
+ FOR i FROM 2 UPTO 24
+ REP display [i] := display [1]
+ PER;
+ out (""6""2""0""4"")
+
+END PROC clear ;
+
+PROC begin plot :
+
+ cursor (x pos + 1, 24 - (y pos) DIV 2 )
+
+ENDPROC begin plot ;
+
+PROC end plot :
+
+ENDPROC end plot ;
+
+PROC dir move (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ move (round (h), round (v))
+
+END PROC dir move;
+
+PROC move (INT CONST x val, y val) :
+
+ x pos := x val;
+ y pos := y val
+
+ENDPROC move ;
+
+PROC dir draw (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ draw (round (h), round (v))
+
+END PROC dir draw;
+
+PROC draw (INT CONST x val, y val) :
+
+ new x pos := x val;
+ new y pos := y val;
+
+ plot vector (new x pos - x pos, new y pos - y pos) ;
+
+END PROC draw ;
+
+PROC dir draw (TEXT CONST text, REAL CONST angle, height) :
+ out (""6"");
+ out (code (23 - (y pos DIV 2)));
+ out (code (x pos));
+
+ out (text)
+
+END PROC dir draw;
+
+INT VAR act no :: 1, act thickness :: 1, act line type :: 1;
+
+PROC pen (INT CONST no, thickness, line type) :
+ act no := no;
+ act thickness := thickness;
+ act line type := line type
+
+ENDPROC pen ;
+
+PROC pen info (INT VAR no, thickness, line type) :
+ no := act no;
+ thickness := act thickness;
+ line type := act line type
+
+END PROC pen info;
+
+PROC plot vector (INT CONST dx , dy) :
+
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (y pos, x pos, dy, dx, up, right)
+ ELIF dy > 0 THEN vector (x pos, y pos, dx, dy, right, up)
+
+ ELIF dy > -dx THEN vector (x pos, y pos, dx, -dy, right, down)
+ ELSE vector (y pos, x pos, -dy, dx, down, right)
+ FI
+ ELSE IF dy > -dx THEN vector (y pos, x pos, dy, -dx, up, left)
+ ELIF dy > 0 THEN vector (x pos, y pos, -dx, dy, left, up)
+
+ ELIF dy > dx THEN vector (x pos, y pos, -dx, -dy, left, down)
+ ELSE vector (y pos, x pos, -dy, -dx, down, left)
+ FI
+ FI .
+
+ENDPROC plot vector ;
+
+PROC vector (INT VAR x pos, y pos; INT CONST dx, dy, right, up) :
+
+ prepare first step ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO dx REP
+ do one step
+ PER .
+
+prepare first step :
+ point;
+ INT VAR old error := 0 ,
+ up right error := dy - dx ,
+ right error := dy .
+
+do one step :
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+ENDPROC vector ;
+
+
+PROC point :
+ INT CONST line :: y pos DIV 2;
+ BOOL CONST above :: (y pos MOD 2) = 1;
+ TEXT CONST point :: display [line+1] SUB (x pos+1),
+ new point :: calculated point;
+
+ replace (display [line+1], x pos+1, new point);
+ out (""6"") ;
+ out (code (23-line)) ;
+ out (code (x pos)) ;
+ out (new point) .
+
+calculated point :
+ IF above
+ THEN IF point = "," OR point = "|"
+ THEN "|"
+ ELSE "'" FI
+ ELSE IF point = "'" OR point = "|"
+ THEN "|"
+ ELSE "," FI
+ FI
+
+END PROC point;
+
+REAL CONST real max int := real (max int);
+INT PROC round (REAL CONST x) :
+ IF x > real max int
+ THEN max int
+ ELIF x < 0.0
+ THEN 0
+ ELSE int (x + 0.5) FI
+
+END PROC round;
+
+ENDPACKET std plot ;
diff --git a/system/base/unknown/src/bildeditor b/system/base/unknown/src/bildeditor new file mode 100644 index 0000000..c84a300 --- /dev/null +++ b/system/base/unknown/src/bildeditor @@ -0,0 +1,722 @@ +
+PACKET b i l d e d i t o r DEFINES (* Autor: P.Heyderhoff *)
+ (*****************) (* Stand: 06.02.82 *)
+ (* Vers.: 1.6.0 *)
+ bildeditor, (* test des bildeditors, *)
+ schreiberlaubnis,
+ zeile unveraendert,
+ feldanfangsmarke,
+ bildmarksatz,
+ bildeinfuegen,
+ bildneu,
+ bildzeile,
+ bildmarke,
+ bildstelle,
+ bildlaenge,
+ bildmaxlaenge,
+ bildsatz,
+ bildrand :
+
+
+LET anker = 2, freianker = 1, satzmax = 4075,
+ DATEI = ROW satzmax STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt);
+
+INT VAR stelle :: anker, marke :: 0, satz :: 1, zeile :: 1,
+ zeilen :: 0, maxlaenge :: 23, laenge :: maxlaenge, rand :: 0,
+ marksatz :: 0, alte feldstelle :: 1, alte feldmarke :: 0;
+
+TEXT VAR kommando :: "", teil :: "", zeichen :: "";
+
+BOOL VAR neu :: TRUE, zeileneu :: TRUE, ueberschriftneu :: FALSE,
+ einfuegen :: FALSE, schreiben erlaubt :: TRUE;
+
+LET hop mark rubout up down cr = ""1""16""12""3""10""13"",
+ hop cr mark down up right rubin = ""1""13""16""10""3""2""11"",
+ hop rubin rubout down up cr tab esc = ""1""11""12""10""3""13""9""27"",
+ blank = " ", hop = ""1"", clear eop = ""4"", clear eol = ""5"",
+ left = ""8"", right = ""2"", up = ""3"", down = ""10"", bell = ""7"",
+ tab = ""9"", cr = ""13"", escape = ""27"", begin mark = ""15"",
+ end mark = ""14"", hoechstes steuerzeichen = ""31"", escape q = ""27"q",
+ rubin = ""11"", mark = ""16"", down clear eol = ""10""5"";
+
+(****************** z u g r i f f s p r o z e d u r e n ******************)
+
+BOOL PROC schreiberlaubnis :
+ schreiben erlaubt
+END PROC schreiberlaubnis;
+
+PROC schreiberlaubnis (BOOL CONST b) :
+ schreiben erlaubt := b
+END PROC schreiberlaubnis;
+
+BOOL PROC bildneu :
+ neu
+END PROC bildneu;
+
+PROC bildneu (BOOL CONST b) :
+ neu := b
+END PROC bildneu;
+
+PROC bildeinfuegen (BOOL CONST b):
+ einfuegen := b
+END PROC bildeinfuegen;
+
+INT PROC bildmarke :
+ marke
+END PROC bildmarke;
+
+PROC bildmarke (INT CONST i) :
+ marke := i
+END PROC bildmarke;
+
+INT PROC feldanfangsmarke :
+ alte feldmarke
+END PROC feldanfangsmarke;
+
+PROC feldanfangsmarke (INT CONST i) :
+ alte feldmarke := i
+END PROC feldanfangsmarke;
+
+INT PROC bildstelle :
+ stelle
+END PROC bildstelle;
+
+PROC bildstelle (INT CONST i) :
+ stelle := i
+END PROC bildstelle;
+
+INT PROC bildmarksatz :
+ marksatz
+END PROC bildmarksatz;
+
+PROC bildmarksatz (INT CONST i) :
+ marksatz := i
+END PROC bildmarksatz;
+
+INT PROC bildsatz :
+ satz
+END PROC bildsatz;
+
+PROC bildsatz (INT CONST i) :
+ satz := i
+END PROC bildsatz;
+
+INT PROC bildzeile :
+ zeile
+END PROC bildzeile;
+
+PROC bildzeile (INT CONST i) :
+ zeile := min (i, laenge)
+END PROC bildzeile;
+
+INT PROC bildlaenge :
+ laenge
+END PROC bildlaenge;
+
+PROC bildlaenge (INT CONST i) :
+ laenge := i
+END PROC bildlaenge;
+
+PROC bildmaxlaenge (INT CONST i) :
+ maxlaenge := i
+END PROC bildmaxlaenge;
+
+INT PROC bildrand :
+ rand
+END PROC bildrand;
+
+PROC bildrand (INT CONST i) :
+ rand := i
+END PROC bildrand;
+
+INT PROC max (INT CONST a, b) :
+ IF a > b THEN a ELSE b FI
+END PROC max;
+
+PROC zeile unveraendert :
+ zeileneu := FALSE
+END PROC zeile unveraendert;
+
+
+(************************** b i l d e d i t o r **************************)
+
+PROC bildeditor (DATEI VAR datei) :
+
+ INTERNAL 293 ;
+
+ INT VAR j;
+
+ kommando := feldkommando;
+ IF neu
+ THEN bild ausgeben (datei)
+ ELIF zeileneu
+ THEN satz ausgeben (datei); ueberschriftneu := TRUE
+ ELSE feldposition; zeileneu := TRUE
+ FI;
+ REPEAT
+ IF neu THEN bild ausgeben (datei)
+ ELIF ueberschriftneu THEN ueberschrift (datei)
+ FI ;
+ IF stelle = anker
+ THEN IF schreiben erlaubt
+ THEN satz erzeugen (datei, stelle); (* gestrichen z:=z *)
+ satz ausgeben (datei)
+ ELSE feldkommando (escape q); out(bell); LEAVE bildeditor
+ FI
+ FI ;
+ feldbearbeitung;
+ IF zeichen <> escape THEN kommandoausfuehrung FI
+ UNTIL zeichen = escape
+ END REPEAT;
+ feldkommando (kommando) .
+
+feldbearbeitung :
+ feldkommando (kommando);
+ IF schreiben erlaubt
+ THEN feldeditor (inhalt); kommando := feldkommando
+ ELSE teil := inhalt; feldeditor (teil);
+ IF teil <> inhalt
+ THEN kommando := escape q; kommando CAT teil
+ ELSE kommando := feldkommando
+ FI
+ FI;
+ zeichen := kommando SUB 1;
+ feldnachbehandlung .
+
+
+feldnachbehandlung :
+ IF inhalt = ""
+ THEN IF schreiben erlaubt
+ THEN IF zeichen > hoechstes steuerzeichen
+ THEN inhalt := subtext (kommando, 1, feldlimit);
+ kommando := subtext (kommando, feldlimit+1);
+ feldout (inhalt); zeichen := cr
+ FI FI FI .
+
+kommandoausfuehrung :
+ delete char (kommando, 1);
+ IF marke > 0
+ THEN bildmarkeditor (datei)
+ ELSE
+ SELECT pos (hop cr mark down up right rubin, zeichen) OF
+ CASE 1:
+ zeichen := kommando SUB 1; delete char (kommando, 1);
+ SELECT pos (hop rubin rubout down up cr tab esc, zeichen) OF
+ CASE 1: oben links
+ CASE 2: IF schreiben erlaubt
+ THEN zeilen einfuegen ELSE out (bell) FI
+ CASE 3: IF schreiben erlaubt
+ THEN zeile ausfuegen ELSE out (bell) FI
+ CASE 4: weiterblaettern
+ CASE 5: zurueckblaettern
+ CASE 6: neue seite
+ CASE 7: ueberschriftneu := TRUE
+ CASE 8: lernmodus umschalten
+ OTHERWISE zeichen := ""; out (bell)
+ END SELECT
+ CASE 2: neue zeile
+ CASE 3: markieren beginnen
+ CASE 4: naechster satz
+ CASE 5: vorgaenger (datei)
+ CASE 6: feldposition (feldanfang); naechster satz
+ CASE 7: ueberschriftneu := TRUE;
+ OTHERWISE
+ IF zeichen > hoechstes steuerzeichen
+ THEN IF schreiben erlaubt THEN ueberlauf FI
+ ELSE insert char (kommando, zeichen, 1);
+ insert char (kommando, escape, 1)
+ FI
+ END SELECT
+ FI .
+
+oben links :
+ ueberschriftneu := TRUE;
+ WHILE zeile > 1 REP vorgaenger (datei) PER;
+ feldposition (feldanfang) .
+
+zeile ausfuegen :
+ IF feldstelle = 1
+ THEN satz loeschen (datei);
+ IF stelle = anker THEN vorgaenger (datei) FI
+ ELSE zeilen rekombinieren
+ FI .
+
+zeilen einfuegen :
+ ueberschriftneu := TRUE;
+ IF einfuegen
+ THEN einfuegen := FALSE;
+ IF inhalt = "" THEN satz loeschen (datei) FI;
+ IF zeilen < laenge THEN bild ausgeben (datei) FI
+ ELSE einfuegen := TRUE;
+ IF logischer satzanfang
+ THEN satz erzeugen (datei, stelle);
+ IF zeilen >= zeile THEN bildrest loeschen FI;
+ zeilen := zeile; satz ausgeben (datei)
+ ELSE IF feldstelle <= LENGTH inhalt
+ THEN zeile auftrennen
+ FI;
+ IF zeile < zeilen
+ THEN nachfolger (datei); bildrest loeschen;
+ vorgaenger (datei); zeilen := zeile
+ FI ; feldposition
+ FI
+ FI .
+
+logischer satzanfang :
+ FOR j FROM feldanfang UPTO feldstelle - 1
+ REP IF (inhalt SUB j) = ""
+ THEN LEAVE logischer satzanfang WITH TRUE
+ ELIF (inhalt SUB j) <> " "
+ THEN LEAVE logischer satzanfang WITH FALSE
+ FI
+ END REP; TRUE .
+
+zeilen rekombinieren :
+ IF eof (datei) THEN
+ ELSE inhalt CAT (feldstelle-1-LENGTH inhalt) * " ";
+ inhalt CAT datei (datei (stelle).nachfolger).inhalt;
+ stelle := datei (stelle).nachfolger;
+ satz loeschen (datei, stelle);
+ stelle := datei (stelle).vorgaenger;
+ bildausgeben (datei)
+ FI .
+
+zeile auftrennen :
+ marke := stelle; (feldende-feldstelle+1) TIMESOUT " ";
+ stelle := datei (stelle).nachfolger;
+ satz erzeugen (datei, stelle);
+ inhalt := subtext (datei (datei (stelle).vorgaenger).inhalt, feldstelle);
+ stelle := marke; marke := 0;
+ inhalt := subtext (inhalt, 1, feldstelle-1) .
+
+weiterblaettern :
+ ueberschriftneu := TRUE;
+ IF eof (datei)
+ THEN out (bell)
+ ELSE IF zeile = laenge
+ THEN nachfolger (datei); zeile := 1; bild ausgeben (datei)
+ ELIF einfuegen
+ THEN IF zeile = zeilen THEN bild ausgeben (datei) FI
+ FI;
+ WHILE zeile < zeilen AND stelle <> anker
+ REP nachfolger (datei) END REP;
+ IF stelle = anker
+ THEN vorgaenger (datei)
+ FI FI .
+
+zurueckblaettern :
+ ueberschriftneu := TRUE;
+ IF satz > 1
+ THEN IF zeile = 1
+ THEN vorgaenger (datei); zeile := laenge
+ FI;
+ WHILE zeile > 1 AND satz > 1
+ REP vorgaenger (datei) PER;
+ zeile := 1
+ FI .
+
+ueberlauf :
+ insert char (kommando, zeichen, 1);
+ feldposition (feldanfang); feld einruecken (inhalt); nachfolger (datei);
+ satz erzeugen (datei, stelle);
+ inhalt := ""0"" ; (* 12.01.81 *)
+ IF zeile <= zeilen OR neu
+ THEN bild ausgeben (datei) ELSE satz ausgeben (datei)
+ FI ;
+ inhalt := "" .
+
+lernmodus umschalten :
+ feldlernmodus (NOT feldlernmodus);
+ ueberschriftneu := TRUE;
+ IF feldlernmodus
+ THEN feldaudit (""); zeichen := ""
+ ELSE insert char (kommando, escape, 1);
+ insert char (kommando, hop, 1)
+ FI.
+
+neue seite :
+ feldstelle (feldanfang); zeile := 1; neu := TRUE .
+
+neue zeile :
+ BOOL VAR wirklich einfuegen := einfuegen;
+ IF feldstelle > LENGTH inhalt OR feldstelle >= feldende
+ THEN feldposition (feldanfang); feld einruecken (inhalt); nachfolger(datei)
+ ELIF einfuegen AND logischer satzanfang
+ THEN feldposition (feldanfang); feldeinruecken (inhalt)
+ ELSE feldposition (feldanfang); nachfolger (datei);
+ wirklich einfuegen := FALSE
+ FI;
+ IF stelle = anker THEN
+ ELIF wirklich einfuegen
+ THEN satz erzeugen (datei, stelle);
+ IF zeile <= zeilen OR neu
+ THEN bild ausgeben (datei)
+ ELSE satz ausgeben (datei)
+ FI
+ ELIF neu THEN
+ ELSE IF zeile > zeilen
+ THEN satz ausgeben (datei)
+ FI;
+ FOR j FROM feldanfang UPTO min (feldstelle, LENGTH inhalt)
+ REP IF (inhalt SUB j) <> blank
+ THEN feldposition (j); LEAVE neue zeile FI
+ PER
+ FI .
+
+naechster satz :
+ nachfolger (datei);
+ IF neu
+ THEN IF stelle = anker
+ THEN IF datei (datei (stelle).vorgaenger).inhalt = ""
+ THEN stelle := datei (stelle).vorgaenger; satz DECR 1;
+ neu := FALSE
+ FI FI
+ ELIF zeile <= zeilen THEN
+ ELIF stelle = anker THEN
+ ELSE satz ausgeben (datei)
+ FI .
+
+markieren beginnen :
+ IF feldstelle <= min (LENGTH inhalt, feldende)
+ THEN feldmarke (feldstelle); marke := stelle;
+ marksatz := satz; satz ausgeben (datei);
+ alte feldmarke := feldmarke
+ ELSE out (bell)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC bildeditor;
+
+
+(******************** b i l d - m a r k e d i t o r **********************)
+
+PROC bildmarkeditor (DATEI VAR datei) :
+ INT VAR j, k;
+
+ IF zeichen = right OR zeichen = tab
+ THEN zeichen := down;
+ feldposition (feldanfang)
+ FI;
+ SELECT pos (hop mark rubout up down cr, zeichen) OF
+ CASE 1: zeichen := kommando SUB 1; delete char (kommando, 1);
+ IF zeichen = up
+ THEN rueckblaetternd demarkieren
+ ELIF zeichen = down
+ THEN weiterblaetternd markieren
+ ELSE out (bell)
+ FI;
+ zeichen := ""
+ CASE 2: markieren beenden
+ CASE 3: IF schreiben erlaubt
+ THEN markiertes loeschen
+ ELSE out (bell)
+ FI
+ CASE 4: zeile demarkieren
+ CASE 5,6: zeile markieren
+ OTHERWISE insert char (kommando, zeichen, 1);
+ insert char (kommando, escape, 1)
+ END SELECT;
+ IF marke > 0
+ THEN IF stelle = marke
+ THEN feldmarke (alte feldmarke)
+ ELSE feldmarke (feldanfang)
+ FI
+ FI .
+
+markieren beenden :
+ feldmarke (0); alte feldmarke := 0;
+ IF marke = stelle
+ THEN satz ausgeben (datei); ueberschriftneu := TRUE;
+ marke := 0;
+ ELSE marke := 0; neu := TRUE
+ FI .
+
+markiertes loeschen :
+ IF stelle = marke
+ THEN satzausschnitt loeschen
+ ELSE letzten satz bis stelle loeschen;
+ ersten satz ab marke loeschen;
+ alle zwischensaetze loeschen;
+ IF zeile <= 1
+ THEN zeile := 1
+ FI;
+ feldstelle (feldanfang); feldmarke (0);
+ alte feldmarke := 0; marke := 0; neu := TRUE
+ FI .
+
+satzausschnitt loeschen :
+ inhalt := subtext (inhalt, 1, feldmarke-1) + subtext (inhalt, feldstelle);
+ feldstelle (feldmarke); feldmarke (0); marke := 0;
+ IF inhalt = ""
+ THEN satz loeschen (datei)
+ ELSE satz ausgeben (datei)
+ FI .
+
+letzten satz bis stelle loeschen :
+ IF feldstelle > LENGTH inhalt
+ THEN satz loeschen (datei, stelle)
+ ELIF feldstelle > feldanfang
+ THEN inhalt := subtext (inhalt, feldstelle)
+ FI .
+
+ersten satz ab marke loeschen :
+ INT CONST altstelle := stelle;
+ stelle := marke;
+ IF alte feldmarke = 1
+ THEN satz loeschen (datei, stelle);
+ satz DECR 1; zeile DECR 1
+ ELSE IF alte feldmarke <= LENGTH inhalt
+ THEN inhalt := text (inhalt, alte feldmarke-1)
+ FI;
+ stelle := datei (stelle).nachfolger
+ FI .
+
+alle zwischensaetze loeschen :
+ WHILE stelle <> altstelle
+ REP satzloeschen (datei, stelle);
+ satz DECR 1; zeile DECR 1
+ PER .
+
+zeile markieren :
+ IF zeichen = cr
+ THEN feldstelle (feldanfang)
+ FI;
+ IF eof (datei)
+ THEN feldstelle (feldende)
+ ELSE nachfolger (datei)
+ FI;
+ markierung justieren (datei);
+ satz ausgeben (datei) .
+
+zeile demarkieren :
+ IF stelle = marke
+ THEN out (bell); LEAVE zeile demarkieren
+ FI;
+ feldmarke (0); satz ausgeben (datei);
+ vorgaenger (datei);
+ markierung justieren (datei);
+ satz ausgeben (datei) .
+
+weiterblaetternd markieren :
+ IF zeile >= laenge THEN zeile := 0 FI; out (hop);
+ WHILE NOT eof (datei)
+ REP nachfolger (datei) UNTIL zeile = laenge PER;
+ IF eof (datei)
+ THEN feldstelle (feldende);
+ FI;
+ neu := TRUE .
+
+rueckblaetternd demarkieren :
+ IF stelle = marke
+ THEN out (bell); LEAVE rueckblaetternd demarkieren
+ FI;
+ FOR j FROM 1 UPTO laenge
+ WHILE stelle <> marke
+ REP vorgaenger (datei) PER;
+ neu := TRUE .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC bildmarkeditor;
+
+PROC markierung justieren (DATEI CONST datei) :
+ IF feldstelle > LENGTH inhalt
+ THEN feldstelle (min (feldende, LENGTH inhalt) + 1)
+ FI;
+ IF stelle = marke
+ THEN feldmarke (alte feldmarke);
+ IF feldstelle < feldmarke
+ THEN feldstelle (feldmarke)
+ FI
+ ELSE feldmarke (feldanfang)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC markierung justieren;
+
+PROC vorgaenger (DATEI VAR datei) :
+ IF eof (datei)
+ THEN IF inhalt = "" THEN satz loeschen (datei)
+ FI FI ;
+ stelle := datei (stelle).vorgaenger; satz DECR 1;
+ IF stelle = anker
+ THEN out (bell); stelle := datei (anker).nachfolger;
+ satz := 1; zeile := 1
+ ELIF zeile > 1
+ THEN out (up); zeile DECR 1
+ ELSE neu := TRUE
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC vorgaenger;
+
+PROC nachfolger (DATEI CONST datei) :
+ stelle := datei (stelle).nachfolger; satz INCR 1; zeile INCR 1;
+ IF zeile <= laenge
+ THEN out (down)
+ ELIF laenge <> maxlaenge
+ THEN neu := TRUE ; zeile := laenge
+ FI
+END PROC nachfolger;
+
+PROC bild ausgeben (DATEI VAR datei) :
+
+ IF marke > 0 THEN markierung justieren (datei) FI;
+ alte feldstelle := feldstelle; feldstelle (feldende+1);
+ INT VAR altstelle :: stelle, altsatz :: satz,
+ altzeile :: zeile, altmarke :: feldmarke;
+ ueberschrift (datei);
+ IF marke > 0 OR neu
+ THEN zurueck zur ersten zeile;
+ cursor (1, rand+2) FI;
+ IF (rand+laenge) = maxlaenge THEN out (clear eop) FI;
+ WHILE zeile <= laenge AND stelle <> anker
+ REP zeile schreiben PER;
+ feldstelle (alte feldstelle);
+ feldmarke (altmarke);
+ zeilen := zeile - 1;
+ IF zeile > laenge
+ THEN zeile := laenge; feldposition
+ ELSE bildrest loeschen
+ FI;
+ (zeile - altzeile) TIMESOUT up;
+ zeile := altzeile; satz := altsatz; stelle := altstelle;
+ neu := FALSE .
+
+zurueck zur ersten zeile :
+ IF eof (datei)
+ THEN WHILE inhalt = "" AND datei(stelle).vorgaenger <> anker
+ REP vorgaenger (datei) END REP;
+ altstelle := stelle; altsatz := satz; altzeile := zeile;
+ FI;
+ WHILE zeile > 1 AND datei (stelle).vorgaenger <> anker
+ REP IF stelle = marke
+ THEN feldmarke (0)
+ FI;
+ vorgaenger (datei)
+ PER;
+ altzeile DECR (zeile-1); zeile := 1 .
+
+inhalt :
+ datei (stelle).inhalt .
+
+zeile schreiben :
+ IF stelle = marke THEN feldmarke (alte feldmarke) FI;
+ IF stelle = altstelle THEN feldstelle (alte feldstelle) FI;
+ feldout (inhalt);
+ IF stelle = altstelle
+ THEN feldmarke (0)
+ ELIF feldmarke > feldanfang
+ THEN feldmarke (feldanfang)
+ FI;
+ zeile INCR 1;
+ IF zeile <= laenge
+ THEN stelle := datei (stelle).nachfolger;
+ satz INCR 1; out (down)
+ FI .
+
+END PROC bild ausgeben;
+
+PROC ueberschrift (DATEI CONST datei) :
+ cursor (feldrand+1, rand+1); out(begin mark);
+ INT CONST punkte ::
+ (feldende-feldanfang-13-length(datei(anker).inhalt)) DIV 2;
+ punkte TIMESOUT "."; out (" ", datei(anker).inhalt, " .");
+ cursor (feldrand+3, rand+1);
+ IF feldeinfuegen
+ THEN out ("RUBIN"2""2"")
+ ELSE out (""2""2""2""2""2""2""2"") FI;
+ IF einfuegen
+ THEN out ("INS")
+ ELSE out (""2""2""2"") FI;
+ IF feldlernmodus THEN out ("..LEARN.") FI;
+ cursor (feldrand+feldende-feldanfang-9-punkte, rand+1);
+ punkte TIMESOUT ".";
+ out (" zeile ", end mark, " ");
+ cursor (feldrand+feldende-feldanfang-2, rand+1) ;
+ IF satz <= zeile THEN out("1")
+ ELSE out (text (satz-zeile+1)) FI;
+ cursor (feldrand+2, rand+1);
+ feldtab (tabulator);
+ outsubtext (tabulator, feldanfang+1, min (feldende, LENGTH tabulator));
+ cursor (1, rand+zeile+1); feldposition;
+ ueberschriftneu := FALSE
+
+END PROC ueberschrift;
+
+TEXT VAR tabulator;
+
+PROC satz ausgeben (DATEI VAR datei) :
+ IF zeile > laenge
+ THEN roll up
+ ELIF zeile > zeilen
+ THEN zeilen INCR 1
+ FI;
+ feldout (datei (stelle).inhalt); feldposition .
+roll up :
+ out (down); cursor (1, rand + zeile); zeile DECR 1 .
+END PROC satz ausgeben;
+
+PROC satz loeschen (DATEI VAR datei) :
+ satz loeschen (datei, stelle); zeilen DECR 1;
+ IF zeile > zeilen
+ THEN bildrest loeschen;
+ IF stelle <> anker THEN satz ausgeben (datei) FI
+ ELSE bild ausgeben (datei)
+ FI
+END PROC satz loeschen;
+
+PROC bildrest loeschen :
+ out (cr); feldrand TIMESOUT right;
+ IF (rand+laenge) = maxlaenge
+ THEN out (clear eop)
+ ELSE out (up);
+ (laenge-zeile+1) TIMESOUT (down clear eol);
+ (laenge-zeile) TIMESOUT up
+ FI;
+ feldposition
+END PROC bildrest loeschen;
+
+BOOL PROC eof (DATEI CONST datei) :
+ datei (stelle).nachfolger = anker
+END PROC eof;
+
+(*************************** schrott *************************************)
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291 ;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+(************************** testprogramm ***********************************)
+(*
+PROC test des bildeditors :
+
+ IF NOT exists ("test")
+ THEN FILE VAR file 1 := sequential file (modify, "test"); close (file 1)
+ FI ;
+ DATASPACE VAR ds := old ("test");
+ BOUND DATEI VAR datei := ds ;
+ feldwortweise (NOT feldwortweise);
+ bildneu (TRUE); bildmarke (0);
+ bildstelle (CONCR(datei) (anker).nachfolger); bildsatz (1);
+ feldmarke (0); feldseparator (""); feldstelle (1) ;
+ REP b i l d e d i t o r (CONCR (datei));
+ out (""7""); feldkommando ("")
+ UNTIL (feldkommando SUB 1) = ""27""
+ PER;
+
+END PROC test des bildeditors;
+*)
+END PACKET bildeditor;
diff --git a/system/base/unknown/src/command handler b/system/base/unknown/src/command handler new file mode 100644 index 0000000..3e06280 --- /dev/null +++ b/system/base/unknown/src/command handler @@ -0,0 +1,239 @@ +
+PACKET command handler DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 29.02.82 *)
+ command handler ,
+ do command ,
+ command error ,
+ set command :
+
+
+LET esc = ""27"" ,
+ esc k = ""27"k" ,
+ cr lf = ""4""13""10"" ,
+ command pre = ""4""13" " ,
+ command post = ""13""10" " ,
+
+ tag type = 1 ,
+ texttype = 4 ,
+ eof type = 7 ;
+
+
+TEXT VAR command line := "" ,
+ previous command line := "" ,
+ symbol ,
+ procedure ,
+ pattern ,
+ error note := "" ;
+
+INT VAR symbol type ,
+ allowed type := 0 ;
+
+
+PROC set command (TEXT CONST command, INT CONST type) :
+
+ param position (0) ;
+ command line := command ;
+ allowed type := type
+
+ENDPROC set command ;
+
+PROC do command :
+
+ do (command line)
+
+ENDPROC do command ;
+
+
+PROC command handler ( TEXT CONST command list,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2,
+ TEXT CONST command text ) :
+
+prepare and get command ;
+command handler (command list,command index,number of params,param1,param2).
+
+prepare and get command :
+ set line nr (0) ;
+ error protocoll ;
+ get command from console .
+
+error protocoll :
+ IF is error
+ THEN put error ;
+ clear error
+ ELSE command line := "" ;
+ FI .
+
+get command from console :
+ INT VAR x, y;
+ out (crlf) ;
+ get cursor (x, y) ;
+ cursor (x, y) ;
+ REP
+ out (command pre) ;
+ out (command text) ;
+ out (command post) ;
+ editget command
+ UNTIL command line <> "" PER ;
+ param position (LENGTH command line) ;
+ out (command post) .
+
+editget command :
+ feldaudit ("") ;
+ feldlernmodus (FALSE) ;
+ REP
+ feldtabulator ("") ;
+ feldseparator (esc) ;
+ editget (command line) ;
+ ignore halt errors during editget ;
+ IF feldzeichen = esc k
+ THEN command line := previous command line
+ ELSE previous command line := command line ;
+ LEAVE editget command
+ FI
+ PER .
+
+ignore halt errors during editget :
+ IF is error
+ THEN clear error
+ FI .
+
+ENDPROC command handler ;
+
+PROC command handler ( TEXT CONST command list,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ scan (command line) ;
+ next symbol ;
+ IF pos (command list, symbol) > 0
+ THEN procedure name ;
+ parameter list pack option ;
+ nothing else in command line ;
+ decode command
+ ELSE impossible command
+ FI .
+
+procedure name :
+ IF symbol type = tag type OR symbol = "?"
+ THEN procedure := symbol ;
+ next symbol
+ ELSE error ("incorrect procedure name")
+ FI .
+
+parameter list pack option :
+ number of params := 0 ;
+ param 1 := "" ;
+ param 2 := "" ;
+ IF symbol = "("
+ THEN next symbol ;
+ parameter list ;
+ IF symbol <> ")"
+ THEN error (") expected")
+ FI
+ ELIF symbol type <> eof type
+ THEN error ("( expected")
+ FI .
+
+parameter list :
+ parameter (param 1, number of params) ;
+ IF symbol = ","
+ THEN next symbol ;
+ parameter (param 2, number of params) ;
+ FI ;
+ IF symbol <> ")"
+ THEN error (") expected")
+ FI .
+
+nothing else in command line :
+ next symbol ;
+ IF symbol <> ""
+ THEN error ("command too complex")
+ FI .
+
+decode command :
+ command index := index (command list, procedure, number of params) .
+
+impossible command :
+ command index := 0 .
+
+ENDPROC command handler ;
+
+PROC parameter (TEXT VAR param, INT VAR number of params) :
+
+ IF symbol type = text type OR symbol type = allowed type
+ THEN param := symbol ;
+ number of params INCR 1 ;
+ next symbol
+ ELSE error ("parameter is no text denoter ("" missing!)")
+ FI
+
+ENDPROC parameter ;
+
+INT PROC index (TEXT CONST list, procedure, INT CONST params) :
+
+ pattern := procedure ;
+ pattern CAT ":" ;
+ INT CONST index pos := pos (list, pattern) ;
+ IF procedure name found
+ THEN get colon pos ;
+ get dot pos ;
+ get end pos ;
+ get command index ;
+ get param index ;
+ IF param index >= 0
+ THEN command index + param index
+ ELSE - command index
+ FI
+ ELSE 0
+ FI .
+
+procedure name found :
+ index pos > 0 AND (list SUB index pos - 1) <= "9" .
+
+get param index :
+ INT CONST param index :=
+ pos (list, text (params), dot pos, end pos) - dot pos - 1 .
+
+get command index :
+ INT CONST command index :=
+ int ( subtext (list, colon pos + 1, dot pos - 1) ) .
+
+get colon pos :
+ INT CONST colon pos := pos (list, ":", index pos) .
+
+get dot pos :
+ INT CONST dot pos := pos (list, ".", index pos) .
+
+get end pos :
+ INT CONST end pos := dot pos + 4 .
+
+ENDPROC index ;
+
+PROC error (TEXT CONST message) :
+
+ error note := message ;
+ scan ("") ;
+ procedure := "-"
+
+ENDPROC error ;
+
+PROC command error :
+
+ disable stop ;
+ IF error note <> ""
+ THEN errorstop (error note) ;
+ error note := ""
+ FI ;
+ enable stop
+
+ENDPROC command error ;
+
+
+PROC next symbol :
+
+ next symbol (symbol, symbol type)
+
+ENDPROC next symbol ;
+
+iNDPACKET command handler ;
diff --git a/system/base/unknown/src/dateieditorpaket b/system/base/unknown/src/dateieditorpaket new file mode 100644 index 0000000..8aedb2d --- /dev/null +++ b/system/base/unknown/src/dateieditorpaket @@ -0,0 +1,743 @@ +
+PACKET d a t e i e d i t o r paket DEFINES (* Autor: P.Heyderhoff *)
+ (*******************) (* Stand: 19.02.82 *)
+ (* Vers.: 1.6.0 *)
+ define escape ,
+ dateieditor :
+
+LET satzmax = 4075, dateianker = 2, left = ""8"", escape = ""27"",
+ hop = ""1"", right = ""2"", hoechstes steuerzeichen = ""31"",
+ clear = ""1""4"", hop and mark = ""1""15"", code f = "f",
+ clear line mark = ""5""14"", bell = ""7"", freianker = 1, down = ""10"",
+ begin mark = ""15"", end mark = ""14"", escape escape = ""27""27"",
+ clear eol and mark = ""5""15"";
+
+LET DATEI = ROW satzmax STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt);
+FOR j FROM 1 UPTO 127 REP escapefkt (j) := "" PER;
+INT VAR j, haltzeile :: satzmax, symboltyp, typ,
+ zahlwert, stelle, satz, marke, maxbildlaenge :: 23;
+FILE VAR sekundaerfile ;
+TEXT VAR zeichen :: "", ersatz :: "", kommando :: "",
+ symbol :: "", textwert :: "", lernsequenz::"";
+BOOL VAR war fehler, boolwert;
+LET op1namen =
+";+;-;BEGIN;COL;GET;HALT;LIMIT;MARK;PUT;IF;NOT;REPEAT;WRITE;SIZE";
+LET b = 5, c = 11, g = 15, h = 19, l = 24, m = 30,
+ p = 35, i = 39, n = 42, r = 46, w = 53, s=59;
+LET op2namen = "&+&-&*&/&;&CHANGETO;&OR";
+LET plus = 1, minus = 3, mal = 5, durch = 7, semicolon = 9,
+ changecode = 11, or = 21;
+LET proznamen = ";col;row;halt;limit;mark;len;eof;";
+LET pcol = 1, prow = 5, phalt = 9, plimit = 14, pmark = 20,
+ plen = 25, peof = 29;
+LET void = 0, (* keine angabe des typs *)
+ tag = 1, (* typ: lower case letter *)
+ bold = 2, (* typ: upper case letter *)
+ integer = 3, (* typ: digit *)
+ texttyp = 4, (* typ: quote *)
+ operator = 5, (* typ: operator +-*=<> ** := *)
+ delimiter = 6, (* typ: delimiter ( ) , ; . *)
+ eol = 7, (* typ: niltext, Zeilenende *)
+ bool = 8; (* typ: boolean *)
+LET varimax = 10;
+INT VAR freivar :: 1;
+ROW varimax INT VAR varzahlwert, vartyp;
+ROW varimax TEXT VAR vartextwert, varname;
+FOR j FROM 1 UPTO varimax
+REP vartextwert (j) := ""; varname (j) := "" PER;
+
+ROW 127 TEXT VAR escapefkt;
+
+
+(************************* d a t e i e d i t o r *************************)
+
+PROC dateieditor (DATEI VAR datei) :
+
+ INTERNAL 295 ;
+
+ REP datei editieren
+ UNTIL (feldkommando SUB 1) <> escape
+ PER .
+
+datei editieren :
+ war fehler := FALSE ;
+ zeichen := feldkommando SUB 2;
+ IF zeichen = "q" OR zeichen = "w"
+ THEN LEAVE dateieditor
+ ELIF zeichen = escape
+ THEN kommando ermitteln
+ ELSE tastenkommando ermitteln ; (* Li 19.1.82 *)
+ abbruchtest;
+ feldkommando (subtext (feldkommando, 3))
+ FI;
+ a u s f u e h r e n .
+
+tastenkommando ermitteln :
+ IF zeichen > ""0"" AND zeichen < ""128""
+ THEN kommando := escapefkt (code (zeichen)) (* Li 06.01.82 *)
+ ELSE kommando := ""
+ FI .
+
+abbruchtest :
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+
+kommando ermitteln :
+ IF (feldkommando SUB 1) = hop
+ THEN lernsequenz auf taste legen;
+ feldkommando (subtext (feldkommando, 4));
+ LEAVE datei editieren
+ FI;
+ feldkommando (subtext (feldkommando, 3));
+ kommando := ""; dialog; analysieren .
+
+dialog:
+ REP kommandodialog;
+ IF (feldzeichen SUB 1) <> escape OR kommando <> "?"
+ THEN LEAVE dialog
+ ELIF (feldzeichen SUB 2) > ""0"" THEN (* Li 19.02.82 *)
+ kommando := escapefkt (code (feldzeichen SUB 2) MOD 128 )
+ ELSE kommando := ""
+ FI
+ PER .
+
+lernsequenz auf taste legen :
+ lernsequenz := feldaudit;
+ lernsequenz := subtext (lernsequenz, 1, LENGTH lernsequenz - 3);
+ INT CONST lerncode := code (feldkommando SUB 3) MOD 128 ;
+ escapefkt (lerncode) := "W""" ;
+ escapefkt (lerncode) CAT lernsequenz ; (* Li 5.1.81 *)
+ escapefkt (lerncode) CAT """" .
+
+kommandodialog :
+ INT CONST feldlaenge :: max (feldende-feldanfang-21, 6) ;
+ cursor (feldrand+1, bildrand+bildzeile+1);
+ out (begin mark, "gib editor kommando: ");
+ feldlaenge TIMESOUT "."; out(end mark);
+ bildneu (TRUE);
+ cursor (feldrand+23, bildrand+bildzeile+1); feldseparator (escape);
+ editget (kommando, 255, feldlaenge); feldseparator ("") .
+
+analysieren :
+ IF (feldzeichen SUB 1) = escape AND (feldzeichen SUB 2) > ""0"" (*02.82*)
+ THEN escapefkt (code (feldzeichen SUB 2) MOD 128) := kommando; (* Li 5.1.*)
+ LEAVE datei editieren
+ ELIF kommando = ""
+ THEN LEAVE datei editieren
+ ELIF (kommando SUB 1) = "?"
+ THEN kommandos erklaeren;
+ LEAVE datei editieren
+ ELIF pos ("quit", kommando) = 1
+ THEN feldkommando (escape escape);
+ LEAVE dateieditor
+ ELSE escapefkt (code (code f)) := kommando
+ FI .
+
+ausfuehren :
+ haltzeile := satzmax;
+ IF kommando = ""
+ THEN zeile unveraendert
+ ELSE scan (kommando); nextsymbol;
+ IF a u s d r u c k (datei)
+ THEN IF symboltyp <> eol THEN fehler bearbeiten FI
+ FI;
+ IF war fehler THEN inchar (zeichen) (* warten *) FI
+ FI .
+
+kommandos erklaeren :
+ out (clear);
+ putline ("kommandos fuer den benutzer :"); line;
+ putline ("quit : beendet das editieren");
+ putline (" n : positioniert auf zeile n");
+ putline ("+ n : blaettert n zeilen vorwaerts");
+ putline ("- n : blaettert n zeilen rueckwaerts");
+ putline (" ""z"" : sucht angegebene zeichenkette ");
+ putline ("""muster"" CHANGETO ""ersatz"" :");
+ putline (" muster wird durch ersatz ersetzt");
+ putline ("HALT n : sieht anhalten des suchens in zeile n vor");
+ putline ("GET ""d"" : kopiert datei d und markiert");
+ putline ("PUT ""d"" : schreibt markierten abschnitt in datei d");
+ putline ("LIMIT n : setzt schreibende auf spalte n");
+ putline ("BEGIN n : setzt feldanfang auf spalte n");
+ putline ("SIZE n : setzt bildlaenge auf n"); line;
+ putline ("?ESCx : zeigt kommando auf escapetaste x");
+ inchar (zeichen) .
+
+END PROC dateieditor;
+
+PROC define escape (TEXT CONST cmd char, kommando) :
+ escapefkt (code (cmd char) MOD 128) := kommando
+END PROC define escape ;
+
+
+(******************** h i l f s - p r o z e d u r e n ********************)
+
+PROC fehler bearbeiten :
+ IF NOT war fehler
+ THEN war fehler := TRUE; bildneu (TRUE);
+ out (""2""2""2" kommandofehler bei ",symbol," erkannt.");
+ out (clear line mark)
+ FI
+END PROC fehler bearbeiten;
+
+BOOL PROC fehler : fehler bearbeiten; FALSE END PROC fehler;
+
+BOOL PROC klammerzu :
+ IF symbol = ")"
+ THEN nextsymbol; TRUE
+ ELSE fehler
+ FI
+END PROC klammerzu;
+
+PROC nextsymbol :
+ nextsymbol (symbol, symboltyp);
+ IF symboltyp = eol THEN symbol := "kommandoende" FI
+END PROC nextsymbol;
+
+PROC eof (DATEI VAR datei) :
+ boolwert := (bildstelle = dateianker); typ := void
+END PROC eof;
+
+PROC nachsatz (DATEI CONST datei) :
+ stelle := datei (stelle).nachfolger;
+ satz INCR 1; protokoll
+END PROC nachsatz;
+
+PROC vorsatz (DATEI CONST datei) :
+ stelle := datei (stelle).vorgaenger;
+ satz DECR 1; protokoll
+END PROC vorsatz;
+
+
+PROC protokoll :
+ cout (satz) ;
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+END PROC protokoll;
+
+
+(******************* s p r i n g e n und s u c h e n *******************)
+
+PROC row (DATEI VAR datei) :
+ IF ziel voraus THEN vorwaerts springen ELSE rueckwaerts springen FI;
+ bildsatz (satz); bildstelle (stelle); typ := void; bildneu (TRUE) .
+
+ziel voraus :
+ satz := bildsatz; stelle := bildstelle;
+ IF zahlwert > satz
+ THEN TRUE
+ ELIF zahlwert <= satz DIV 2 AND bildmarke = 0
+ THEN stelle := datei (dateianker).nachfolger; satz := 1; TRUE
+ ELSE FALSE
+ FI .
+
+vorwaerts springen :
+ IF zahlwert <= 0
+ THEN fehler bearbeiten
+ FI ;
+ WHILE stelle <> dateianker AND satz < zahlwert
+ REP nachsatz (datei) UNTIL war fehler PER;
+ IF stelle = dateianker AND satz > 1
+ THEN vorsatz (datei);
+ feldstelle (LENGTH (datei (stelle).inhalt)+1)
+ FI .
+
+rueckwaerts springen :
+ WHILE stelle <> bildmarke AND satz > zahlwert
+ REP vorsatz (datei) UNTIL war fehler PER .
+
+END PROC row;
+
+PROC search (DATEI VAR datei) :
+ stelle := bildstelle;
+ IF textwert <> "" THEN contextadressierung FI;
+ typ := void .
+
+contextadressierung :
+ j := feldstelle - 1; satz := bildsatz;
+ WHILE noch nicht gefunden REP nachsatz (datei) UNTIL war fehler PER;
+ IF stelle = dateianker
+ THEN vorsatz (datei);
+ feldstelle (LENGTH (datei (stelle).inhalt)+1)
+ ELIF j > 0
+ THEN feldstelle ((LENGTH textwert)+j)
+ FI;
+ IF bildstelle <> stelle
+ THEN bildstelle (stelle); bildsatz (satz); bildneu (TRUE)
+ FI .
+
+noch nicht gefunden :
+ j := pos (datei (stelle).inhalt, textwert, j+1);
+ j = 0 AND stelle <> dateianker AND satz < haltzeile .
+
+END PROC search;
+
+
+(******************** vom file holen, in file bringen ********************)
+
+PROC vom file holen (DATEI VAR datei, TEXT VAR textwert) :
+ stelle := bildstelle; satz := bildsatz;
+ IF datei eroeffnung korrekt
+ THEN IF stelle = dateianker THEN satz erzeugen (datei, stelle) FI;
+ zeile auftrennen; file kopieren; kopiertes markieren;
+ bildstelle (stelle); bildsatz (satz); bildmarke (marke)
+ FI ; textwert := "" .
+
+datei eroeffnung korrekt :
+ IF textwert = ""
+ THEN sekundaerfile := sequential file (input); NOT eof (sekundaerfile)
+ ELIF exists (textwert)
+ THEN sekundaerfile := sequential file (input, textwert);
+ NOT eof (sekundaerfile)
+ ELSE FALSE
+ FI .
+
+file kopieren :
+ INT VAR altstelle;
+ FOR j FROM 0 UPTO satzmax WHILE NOT eof (sekundaerfile)
+ REP nachsatz (datei); altstelle := stelle;
+ satz erzeugen (datei, stelle);
+ IF stelle = altstelle THEN LEAVE file kopieren FI;
+ getline (sekundaerfile, inhalt)
+ UNTIL war fehler
+ PER .
+
+zeile auftrennen :
+ marke := stelle; bildmarksatz (satz);
+ nachsatz (datei); satz erzeugen (datei, stelle);
+ inhalt := subtext (datei (marke).inhalt, feldstelle);
+ vorsatz (datei); inhalt := text (inhalt, feldstelle-1) .
+
+kopiertes markieren :
+ nachsatz (datei);
+ IF inhalt = "" THEN satz loeschen (datei, stelle) FI;
+ vorsatz (datei);
+ IF datei (marke).inhalt = ""
+ THEN satz loeschen (datei, marke); satz DECR 1;
+ ELSE marke := datei (marke).nachfolger; bildmarksatz (bildmarksatz+1)
+ FI;
+ feldmarke (feldanfang); feldanfangsmarke (feldanfang);
+ feldstelle (1+LENGTH inhalt); bildneu (TRUE) .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC vom file holen;
+
+PROC in file bringen ( DATEI VAR datei, TEXT VAR textwert) :
+ neuen sekundaerfile erzeugen;
+ marke := bildstelle; stelle := bildmarke; satz := bildmarksatz;
+ IF stelle = marke
+ THEN IF feldmarke <> feldstelle
+ THEN putline (sekundaerfile,
+ subtext (inhalt, feldmarke, feldstelle-1))
+ FI
+ ELSE IF feldanfangsmarke <= LENGTH inhalt
+ THEN putline (sekundaerfile, subtext (inhalt, feldanfangsmarke))
+ FI; schreiben;
+ IF feldstelle > feldanfang
+ THEN putline (sekundaerfile, subtext (inhalt, 1, feldstelle-1))
+ FI
+ FI .
+
+schreiben:
+ REP nachsatz (datei);
+ IF stelle = marke OR war fehler THEN LEAVE schreiben FI;
+ putline (sekundaerfile, inhalt)
+ PER .
+
+neuen sekundaerfile erzeugen :
+ IF textwert = ""
+ THEN sekundaerfile := sequential file (output) ;
+ ELSE IF exists (textwert)
+ THEN forget (textwert)
+ FI;
+ IF exists (textwert)
+ THEN LEAVE in file bringen
+ FI;
+ sekundaerfile := sequential file (output, textwert)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC in file bringen;
+
+
+(************************* i n t e r p r e t e r *************************)
+
+BOOL PROC primary (DATEI VAR datei) :
+
+ SELECT symboltyp OF
+ CASE integer :
+ IF LENGTH symbol <= 4 (* Li 20.01.82 *)
+ THEN zahlwert := int (symbol);
+ typ := symboltyp;
+ nextsymbol; TRUE
+ ELSE fehler
+ FI
+ CASE texttyp :
+ textwert := symbol; typ := symboltyp; nextsymbol; TRUE
+ CASE delimiter :
+ IF symbol = "("
+ THEN nextsymbol;
+ IF ausdruck (datei) THEN klammerzu ELSE fehler FI
+ ELSE fehler
+ FI
+ CASE tag :
+ INT CONST pcode :: pos (proznamen, ";" + symbol + ";");
+ IF pcode = 0
+ THEN is variable
+ ELSE nextsymbol; prozedurieren
+ FI
+ CASE bold, operator :
+ INT CONST op1code :: pos (op1namen, ";" + symbol);
+ IF op1code = 0
+ THEN fehler
+ ELIF op1code = r (* Li 12.01.81 *)
+ THEN wiederholung (datei)
+ ELSE nextsymbol ;
+ IF primary (datei)
+ THEN operieren
+ ELSE fehler
+ FI
+ FI
+ OTHERWISE : fehler
+ END SELECT .
+
+is variable :
+ INT VAR var :: 1;
+ WHILE varname (var) <> symbol AND var <> freivar REP var INCR 1 PER;
+ IF var = freivar
+ THEN varname (var) := symbol; nextsymbol;
+ IF symbol = ":="
+ THEN deklarieren
+ ELSE LEAVE is variable WITH fehler
+ FI
+ ELSE nextsymbol
+ FI;
+ IF symbol = ":=" THEN nextsymbol; assignieren ELSE dereferenzieren FI .
+
+dereferenzieren :
+ typ := vartyp (var); zahlwert := varzahlwert (var);
+ textwert := vartextwert (var); TRUE .
+
+assignieren :
+ IF primary (datei)
+ THEN IF typ = integer
+ THEN varzahlwert (var) := zahlwert
+ ELIF typ = texttyp
+ THEN vartextwert (var) := textwert
+ ELSE fehler bearbeiten
+ FI;
+ vartyp (var) := typ; typ := void
+ ELSE fehler bearbeiten
+ FI;
+ NOT war fehler .
+
+deklarieren :
+ IF freivar = varimax
+ THEN fehler bearbeiten
+ ELSE freivar INCR 1
+ FI .
+
+prozedurieren :
+ typ := integer;
+ SELECT pcode OF
+ CASE pcol : zahlwert := feldstelle
+ CASE plen : zahlwert := LENGTH (datei (bildstelle).inhalt)
+ CASE prow : zahlwert := bildsatz
+ CASE phalt : zahlwert := haltzeile
+ CASE plimit : zahlwert := feldlimit
+ CASE pmark : zahlwert := bildmarke
+ CASE peof : eof (datei)
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ NOT war fehler .
+
+operieren :
+ SELECT op1code OF
+ CASE plus : zahlwert INCR bildsatz; row (datei)
+ CASE minus : zahlwert := bildsatz - zahlwert; row (datei)
+ CASE b : begin
+ CASE c : col
+ CASE g : get
+ CASE h : halt
+ CASE l : limit
+ CASE m : mark
+ CASE p : put
+ CASE i : if
+ CASE w : write
+ CASE s : size
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ typ := void; TRUE .
+
+begin :
+ zahlwert := zahlwert MOD 180;
+ feldende (feldende+zahlwert-feldanfang); feldanfang (zahlwert) .
+
+col :
+ zahlwert := zahlwert MOD 256; feldstelle (zahlwert) .
+
+get :
+ IF bildmarke <= 0 AND schreiberlaubnis
+ THEN vom file holen (datei, textwert)
+ FI .
+
+halt :
+ haltzeile := zahlwert .
+
+limit :
+ zahlwert := zahlwert MOD 256; feldlimit (zahlwert) .
+
+mark :
+ IF zahlwert = 0
+ THEN bildmarke (0); feldmarke (0); bildneu (TRUE)
+ ELSE bildmarke (bildstelle); feldmarke (feldstelle);
+ bildmarksatz (bildsatz)
+ FI .
+
+put :
+ IF bildmarke > 0 THEN in file bringen (datei, textwert) FI .
+
+if :
+ IF bedingung (datei)
+ THEN IF boolwert
+ THEN IF pos ("THEN", symbol) = 1
+ THEN nextsymbol;
+ IF ausdruck (datei)
+ THEN skip elseteil
+ ELSE fehler bearbeiten
+ FI
+ ELSE fehler bearbeiten
+ FI
+ ELSE skip thenteil;
+ IF j = 1
+ THEN elseteil
+ ELIF j <> 5
+ THEN fehler bearbeiten
+ FI
+ FI
+ ELSE fehler bearbeiten
+ FI .
+
+elseteil :
+ IF ausdruck (datei)
+ THEN IF symbol = "FI" THEN nextsymbol ELSE fehler bearbeiten FI
+ FI .
+
+skip elseteil :
+ WHILE symboltyp <> eol AND pos ("FI", symbol) <> 1 REP nextsymbol PER;
+ nextsymbol .
+
+skip thenteil :
+ WHILE (symboltyp <> eol) AND nicht elsefi REP nextsymbol PER;
+ nextsymbol .
+
+nicht elsefi :
+ j := pos ("ELSEFI", symbol); j = 0 .
+
+write :
+ feldkommando (textwert); zeile unveraendert .
+
+size :
+ IF bildlaenge > maxbildlaenge
+ THEN maxbildlaenge := bildlaenge
+ FI;
+ bildlaenge (max (1, min (zahlwert, maxbildlaenge)));
+ bildzeile (min (bildzeile, bildlaenge));
+ bildrand (0); bildneu (TRUE); page .
+
+END PROC primary;
+
+
+(*********** w i e d e r h o l u n g , b e d i n g u n g ***************)
+
+BOOL PROC wiederholung (DATEI VAR datei) :
+
+ fix scanner ; (* Li 12.01.81 *)
+ wiederholt interpretieren;
+ skip endrep; typ := void;
+ NOT war fehler .
+
+wiederholt interpretieren :
+ REP reset scanner; nextsymbol; (* 12.01.81 *)
+ WHILE ausdruck (datei) REP UNTIL until PER; abbruchtest
+ UNTIL ende der wiederholung
+ PER .
+
+until :
+ IF pos ("UNTIL", symbol) = 1
+ THEN nextsymbol;
+ IF primary (datei) THEN FI;
+ IF bedingung (datei)
+ THEN IF boolwert
+ THEN LEAVE wiederholt interpretieren;TRUE
+ ELSE TRUE
+ FI
+ ELSE fehler
+ FI
+ ELSE TRUE
+ FI .
+
+ende der wiederholung :
+ IF war fehler
+ THEN TRUE
+ ELIF datei (stelle).nachfolger = dateianker
+ THEN feldstelle > LENGTH (datei (stelle).inhalt)
+ ELSE FALSE
+ FI .
+
+skip endrep :
+ WHILE pos ("ENDREPEAT", symbol) <> 1 AND symboltyp <> eol
+ REP nextsymbol PER;
+ nextsymbol .
+
+abbruchtest :
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+
+END PROC wiederholung;
+
+BOOL PROC bedingung (DATEI VAR datei) :
+ INT VAR relator;
+ relator := pos ("=><<=>=<>", symbol);
+ IF relator = 0
+ THEN fehler
+ ELSE IF typ = texttyp THEN relator INCR 8 FI;
+ nextsymbol;
+ INT VAR operandtyp :: typ, operandzahlwert :: zahlwert;
+ TEXT VAR operandtextwert :: textwert;
+ IF primary (datei) THEN FI;
+ IF operandtyp <> typ
+ THEN fehler
+ ELSE boolwert := vergleich; typ := bool; TRUE
+ FI
+ FI .
+
+vergleich :
+ SELECT relator OF
+ CASE 1 : operandzahlwert = zahlwert
+ CASE 2 : operandzahlwert > zahlwert
+ CASE 3 : operandzahlwert < zahlwert
+ CASE 4 : operandzahlwert <= zahlwert
+ CASE 6 : operandzahlwert >= zahlwert
+ CASE 8 : operandzahlwert <> zahlwert
+ CASE 9 : operandtextwert = textwert
+ CASE 10 : operandtextwert > textwert
+ CASE 11 : operandtextwert < textwert
+ CASE 12 : operandtextwert <= textwert
+ CASE 14 : operandtextwert >= textwert
+ CASE 16 : operandtextwert <> textwert
+ OTHERWISE fehler
+ END SELECT .
+
+END PROC bedingung;
+
+(**************************** a u s d r u c k ****************************)
+
+BOOL PROC ausdruck (DATEI VAR datei) :
+ INT VAR opcode, operandtyp, operandzahlwert;
+ TEXT VAR operandtextwert;
+ IF primary (datei)
+ THEN BOOL VAR war operation :: TRUE;
+ WHILE operator AND war operation
+ REP IF primary (datei)
+ THEN war operation := operator verarbeiten
+ ELSE war operation := FALSE
+ FI
+ PER;
+ war operation
+ ELSE fehler
+ FI .
+
+operator :
+ IF kommandoende
+ THEN IF typ = integer
+ THEN row (datei)
+ ELIF typ = texttyp
+ THEN search (datei)
+ FI
+ FI;
+ opcode := pos (op2namen, "&" + symbol);
+ IF opcode = 0
+ THEN FALSE
+ ELSE nextsymbol; operandtyp := typ;
+ operandzahlwert := zahlwert;
+ operandtextwert := textwert;
+ NOT war fehler
+ FI .
+
+operator verarbeiten :
+ SELECT opcode OF
+ CASE plus :
+ IF typ = integer
+ THEN zahlwert := operandzahlwert + zahlwert
+ ELSE textwert := operandtextwert + textwert
+ FI
+ CASE minus :
+ zahlwert := operandzahlwert - zahlwert
+ CASE mal :
+ IF typ = integer
+ THEN zahlwert := operandzahlwert * zahlwert
+ ELSE textwert := operandzahlwert * textwert
+ FI
+ CASE durch :
+ zahlwert := operandzahlwert DIV zahlwert
+ CASE changecode :
+ change
+ CASE semicolon :
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ NOT war fehler .
+
+change :
+ IF bildmarke <= 0 AND schreiberlaubnis AND bildstelle <> dateianker
+ THEN ersatz := textwert; textwert := operandtextwert; search (datei);
+ INT VAR fstelle :: feldstelle;
+ IF textwert = "" AND ersatz <> "" AND fstelle > LENGTH inhalt
+ THEN inhalt := text (inhalt, fstelle-1)
+ FI;
+ IF subtext (inhalt, fstelle-LENGTH textwert, fstelle-1) = textwert
+ THEN fstelle := fstelle - LENGTH textwert;
+ FOR j FROM 1 UPTO LENGTH ersatz
+ REP IF j <= LENGTH textwert
+ THEN replace (inhalt, fstelle, ersatz SUB j)
+ ELSE insert char (inhalt, ersatz SUB j, fstelle)
+ FI;
+ fstelle INCR 1
+ PER;
+ FOR j FROM 1+LENGTH ersatz UPTO LENGTH textwert
+ REP delete char (inhalt, fstelle) PER;
+ FI;
+ feldstelle (fstelle); typ := void
+ ELSE fehler bearbeiten
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+kommandoende :
+ SELECT pos (";FIELSEENDREPEATUNTIL", symbol) OF
+ CASE 1,2,4,8,17 : TRUE
+ OTHERWISE symboltyp = eol
+ END SELECT .
+
+END PROC ausdruck;
+
+(************************** schrott ****************************************)
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291 ;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+END PACKET dateieditorpaket;
diff --git a/system/base/unknown/src/editor b/system/base/unknown/src/editor new file mode 100644 index 0000000..63f2f19 --- /dev/null +++ b/system/base/unknown/src/editor @@ -0,0 +1,210 @@ +
+PACKET editor DEFINES (* Autor: P.Heyderhoff *)
+ (* Stand: 26.04.82 *)
+ edit , (* Vers.: 1.6.3 *)
+ show ,
+ editmode :
+
+FILE VAR file 1, file 2 ;
+
+PROC edit (FILE VAR file) :
+ x edit (file) ;
+ENDPROC edit ;
+
+PROC edit (FILE VAR file 1, file 2) :
+ x edit (file 1, file 2 )
+ENDPROC edit ;
+
+PROC edit (TEXT CONST file name) :
+ last param (file name) ;
+ IF exists (file name)
+ THEN edit 1 (file name)
+ ELIF yes ("neue datei einrichten")
+ THEN edit 1 (file name)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit ;
+
+PROC edit :
+ edit (last param)
+ENDPROC edit ;
+
+PROC edit 1 (TEXT CONST name) :
+ file 1 := sequential file (modify, name) ;
+ IF NOT is error
+ THEN edit (file 1)
+ FI
+ENDPROC edit 1 ;
+
+PROC edit (TEXT CONST file name 1, file name 2) :
+ IF exists (file name 1)
+ THEN edit 2 (file name 1, file name 2)
+ ELIF yes ("erste datei neu einrichten")
+ THEN edit 2 (file name 1, file name 2)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit ;
+
+PROC edit 2 (TEXT CONST file name 1, file name 2) :
+ file 1 := sequential file (modify, file name 1) ;
+ IF exists (file name 2)
+ THEN file 2 := sequential file (modify, file name 2) ;
+ edit (file 1, file 2)
+ ELIF yes ("zweite datei neu einrichten")
+ THEN file 2 := sequential file (modify, file name 2) ;
+ edit (file 1, file 2)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit 2 ;
+
+PROC show (FILE VAR file) :
+ schreiberlaubnis (FALSE) ;
+ edit (file) ;
+ schreiberlaubnis (TRUE)
+ENDPROC show ;
+
+PROC show (TEXT CONST file name) :
+ IF exists (file name)
+ THEN file 1 := sequential file (modify, file name) ;
+ show (file 1) ;
+ ELSE errorstop ("file does not exist")
+ FI
+ENDPROC show ;
+
+PROC editmode :
+ feldwortweise (NOT feldwortweise) ;
+ say (" ") ;
+ IF feldwortweise
+ THEN say ("Fließtext"13""10"")
+ ELSE say ("kein Umbruch"13""10"")
+ FI .
+
+ENDPROC editmode ;
+
+
+(****************************** e d i t o r ******************************)
+
+LET DATEI = ROW 4075 STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt),
+ freianker = 1, dateianker = 2, satzmax = 4075,
+ bottom = ""6""23""0"" , escape = ""27"", escape w = ""27"w";
+
+BOOL VAR war kein wechsel ;
+TEXT VAR tabulator :: 77*" ";
+
+
+PROC editor (DATEI VAR datei) :
+ enable stop ;
+ grundzustand;
+ zustand aus datei holen ;
+
+ REP b i l d e d i t o r (datei);
+ d a t e i e d i t o r (datei)
+ UNTIL (feldkommando SUB 1) = escape
+ PER;
+ war kein wechsel := (feldkommando SUB 2) <> "w";
+ feldkommando (subtext (feldkommando, 3));
+
+ IF schreiberlaubnis THEN zustand in datei retten FI;
+ schreiberlaubnis (TRUE);
+ out (bottom) .
+
+grundzustand :
+ bildneu (TRUE); bildeinfuegen (FALSE); bildmarke (0);
+ feldmarke (0); feldseparator (""); feldstelle(1);
+ feldeinfuegen (FALSE).
+
+zustand in datei retten :
+ inhalt := text (bildstelle, 5);
+ inhalt CAT text (bildsatz, 5);
+ inhalt CAT text (bildzeile, 5);
+ inhalt CAT text (feldlimit, 5);
+ feldtab (tabulator);
+ inhalt CAT tabulator .
+
+zustand aus datei holen :
+ INT CONST satz nr := int (subtext (inhalt, 1, 5)) ;
+ IF satz nr > 0
+ THEN bildstelle (satz nr)
+ ELSE bildstelle (datei (dateianker).nachfolger)
+ FI ;
+ bildsatz (int (subtext (inhalt, 6, 10)));
+ bildzeile (int (subtext (inhalt, 11, 15)));
+ feldlimit (int (subtext (inhalt, 16, 20)));
+ tabulator := subtext (inhalt, 21) ;
+ feldtabulator (tabulator) .
+
+inhalt :
+ datei (freianker).inhalt .
+
+END PROC editor;
+
+PROC y edit (DATEI VAR datei) :
+ editor (datei);
+ close
+END PROC y edit;
+
+LET begin mark = ""15"", endmark blank = ""14" ";
+
+PROC y edit (DATEI VAR erste datei, zweite datei) :
+ INT CONST alte laenge := bildlaenge - 1;
+ INT VAR laenge := alte laenge DIV 2, flen := feldende - feldanfang + 2;
+ bildlaenge (laenge); feldkommando (escape w);
+ zweimal editieren;
+ bildlaenge (alte laenge + 1); bildrand (0);
+ close .
+
+zweimal editieren:
+ page;
+ REP cursor ( 1, laenge + 2); out (begin mark);
+ cursor(flen, laenge + 2); out (endmark blank);
+ bildrand (0); editor (erste datei); laenge anpassen;
+ IF war kein wechsel THEN LEAVE zweimal editieren FI;
+ bildrand (alte laenge + 1 - laenge);
+ editor (zweite datei); laenge anpassen
+ UNTIL war kein wechsel
+ PER .
+
+laenge anpassen :
+ laenge := bildlaenge;
+ IF laenge = 1 THEN laenge := 2 FI;
+ IF laenge <= alte laenge - 2
+ THEN laenge := alte laenge - laenge
+ ELSE laenge := 2
+ FI ; bildlaenge (laenge) .
+END PROC y edit;
+
+(**************** schrott ***********************)
+
+PROC x edit (FILE VAR f) :
+ EXTERNAL 296
+ENDPROC x edit ;
+
+PROC x edit (FILE VAR f1, f2) :
+ EXTERNAL 297
+ENDPROC x edit ;
+
+LET FDATEI= STRUCT ( BOUND DATEI f ,
+ INT index, pointer, line counter,
+ mode, max line length, max page length,
+ BOOL edit status unchanged) ;
+
+PROC x edit (FDATEI VAR f1) :
+ INTERNAL 296 ;
+ y edit (CONCR (f1.f))
+ENDPROC x edit ;
+
+PROC x edit (FDATEI VAR f1, f2) :
+ INTERNAL 297 ;
+ y edit (CONCR (f1.f), CONCR (f2.f))
+ENDPROC x edit ;
+
+PROC dateieditor (DATEI VAR d) :
+ EXTERNAL 295
+ENDPROC dateieditor ;
+
+PROC bildeditor (DATEI VAR d) :
+ EXTERNAL 293
+ENDPROC bildeditor ;
+
+ENDPACKET editor ;
diff --git a/system/base/unknown/src/elan b/system/base/unknown/src/elan new file mode 100644 index 0000000..744003d --- /dev/null +++ b/system/base/unknown/src/elan @@ -0,0 +1,245 @@ +
+PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 29.04.80 *)
+ list ,
+ file names :
+
+
+FILE VAR list file ;
+TEXT VAR file name, status text;
+
+PROC list :
+
+ list file := sequential file (output) ;
+ headline (list file, "list") ;
+ list (list file) ;
+ show (list file) ;
+ close
+
+ENDPROC list ;
+
+PROC list (FILE VAR f) :
+
+ begin list ;
+ putline (f, "") ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE list
+ FI ;
+ out (f, status text + " """ ) ;
+ out (f, file name) ;
+ out (f, """") ;
+ line (f)
+ PER
+
+ENDPROC list ;
+
+PROC file names (FILE VAR f) :
+
+ begin list ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE file names
+ FI ;
+ putline (f, file name)
+ PER
+
+ENDPROC file names ;
+
+ENDPACKET local manager part 2 ;
+
+
+PACKET elan DEFINES (*Autor: J.Liedtke *)
+ (*Stand: 01.05.82 *)
+ do ,
+ run ,
+ run again ,
+ insert ,
+ prot ,
+ prot off ,
+ check on ,
+ check off :
+
+
+LET newinit option = FALSE ,
+ ins = TRUE ,
+ no ins = FALSE ,
+ lst = TRUE ,
+ no lst = FALSE ,
+ compiler dump option = FALSE ,
+ sys option = TRUE ,
+ stop at first error = TRUE ,
+ multiple error analysis = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ compile line mode = 2 ,
+
+ error message = 4 ;
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ errors occurred ;
+
+INT VAR run again mod nr := 0 ;
+DATASPACE VAR ds ;
+
+FILE VAR error file, source file ;
+
+
+PROC do (TEXT CONST command) :
+
+ INT VAR dummy mod ;
+ run again mod nr := 0 ;
+ errors occurred := FALSE ;
+ elan (compile line mode, ds, command, dummy mod,
+ newinit option, no ins, compiler dump option, no lst, sys option,
+ check option, stop at first error, no sermon) ;
+ IF errors occurred
+ THEN forget (ds) ;
+ errorstop ("")
+ FI
+
+ENDPROC do ;
+
+
+PROC run (TEXT CONST file name) :
+
+ last param (file name) ;
+ run elan (file name, no ins)
+
+END PROC run;
+
+PROC run :
+
+ run (last param)
+
+ENDPROC run ;
+
+PROC run again :
+
+ IF run again mod nr > 0
+ THEN INT VAR mod := run again mod nr ;
+ elan (run again mode, ds, "", run again mod nr,
+ newinit option, no ins, compiler dump option, no lst,
+ sys option, check option, stop at first error, no sermon)
+ ELSE errorstop ("run again impossible")
+ FI
+
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+
+ last param (file name) ;
+ run elan (file name, ins)
+
+ENDPROC insert ;
+
+PROC insert :
+
+ insert (last param)
+
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+
+ IF exists (file name)
+ THEN compile and execute
+ ELSE errorstop ("file does not exist")
+ FI .
+
+compile and execute :
+ disable stop ;
+ errors occurred := FALSE ;
+ elan (compile file mode, old (file name, 1002), "" , run again mod nr,
+ newinit option, insert option, compiler dump option, list option,
+ sys option, check option, multiple error analysis, sermon) ;
+
+ IF errors occurred
+ THEN ignore halt during compiling ;
+ errors occurred := FALSE ;
+ enable stop ;
+ source file := sequential file (modify, file name) ;
+ modify (error file) ;
+ edit (error file, source file) ;
+ forget (ds)
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+ENDPROC run elan ;
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+ INT VAR start module number,
+ BOOL CONST newinit, ins, dump, lst, sys, rt check, error1, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+PROC out text (TEXT CONST text, INT CONST out type) :
+
+ INTERNAL 257 ;
+ out (text) ;
+ IF out type = error message
+ THEN access error file ;
+ out (error file, text)
+ FI .
+
+access error file :
+ IF NOT errors occurred
+ THEN open error file
+ FI .
+
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+
+ INTERNAL 258 ;
+ out (""13""10"") ;
+ IF out type = error message
+ THEN access error file ;
+ line (error file)
+ FI .
+
+access error file :
+ IF NOT errors occurred
+ THEN open error file
+ FI .
+
+ENDPROC out line ;
+
+PROC open error file :
+
+ errors occurred := TRUE ;
+ forget (ds) ;
+ ds := nilspace ;
+ error file := sequential file (output, ds) ;
+ headline (error file, "errors")
+
+ENDPROC open error file ;
+
+PROC prot :
+ list option := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE
+ENDPROC prot off ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+ENDPACKET elan ;
diff --git a/system/base/unknown/src/feldeditor b/system/base/unknown/src/feldeditor new file mode 100644 index 0000000..4156111 --- /dev/null +++ b/system/base/unknown/src/feldeditor @@ -0,0 +1,747 @@ +
+PACKET f e l d e d i t o r DEFINES (* Autor: P.Heyderhoff *)
+ (*****************) (* Stand: 12.04.82 *)
+ (* Vers.: 1.6.0 *)
+ editget,
+ feldeditor,
+ feldout,
+ feldposition,
+ feldeinruecken,
+ feldtab,
+ feldtabulator,
+ feldseparator,
+ feldmarke,
+ feldstelle,
+ feldwortweise,
+ feldanfang,
+ feldende,
+ feldrand,
+ feldlimit,
+ feldaudit,
+ feldzeichen,
+ feldkommando,
+ feldeinfuegen,
+ feldlernmodus,
+ is incharety,
+ getchar,
+ min :
+
+
+TEXT VAR tabulator :: "", separator :: "", fzeichen ::"",
+ kommando :: "", audit :: "";
+
+INT VAR fmarke :: 0, fstelle :: 1, frand :: 0, limit :: 77,
+ fanfang :: 1, dyn fanfang :: fanfang, flaenge, fj,
+ fende :: 77, dyn fende :: fende, dezimalen :: 0;
+
+BOOL VAR wortweise :: FALSE, feinfuegen :: FALSE,
+ blankseparator :: FALSE, lernmodus :: FALSE,
+ war absatz;
+
+LET blank = " ", hop=""1"", right=""2"", up=""3"", clear eop=""4"",
+ clear eol=""5"", bell=""7"", left=""8"", tab=""9"", down=""10"",
+ rubin=""11"", rubout=""12"", cr=""13"", mark=""16"", escape=""27"",
+ hoechstes steuerzeichen=""31"", dach=""94"", end mark=""14"", begin
+ mark=""15"", clear=""1""4"", hop tab=""1""9"", hop rubin=""1""11"",
+ hop rubout=""1""12"", hop cr=""1""13"", cr down=""13""10"",
+ right left tab rubout escape = ""2""8""9""12""27"", hop escape=""1""27"",
+ left left=""8""8"", left endmark=""8""14"", endmark left=""14""8"",
+ left right=""8""2"", blank left=" "8"",
+ blank left rubout=" "8""12"", absatzmarke=""15""14"",
+ hop esc right left tab rubin rubout cr = ""1""27""2""8""9""11""12""13"",
+ hop esc right left tab down cr = ""1""27""2""8""9""10""13"";
+
+(*************************** p r o z e d u r e n *************************)
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editfende):
+
+ disable stop ; (* J.Liedtke 10.02.82 *)
+
+ INT CONST altflaenge :: LENGTH editsatz, altfrand :: frand,
+ altfmarke :: fmarke, altfstelle :: fstelle,
+ altfanfang :: fanfang, altfende :: fende, altlimit :: limit;
+ BOOL CONST altwortweise :: wortweise, altfeinfuegen :: feinfuegen;
+ fmarke := 0; fstelle := 1; fanfang := 1; dyn fanfang := 1;
+ fende := editfende MOD 256; dyn fende := fende;
+ limit := editlimit MOD 256; wortweise := FALSE;
+ feinfuegen := FALSE;
+ INT VAR x, y; get cursor (x,y); frand := x-1;
+ out (editsatz); cursor (x,y);
+ REP
+ feldeditor (editsatz);
+ IF (kommando SUB 1) = escape OR (kommando SUB 1) = hop
+ THEN delete char (kommando, 1)
+ FI;
+ delete char (kommando, 1)
+ UNTIL fzeichen = cr OR (fzeichen SUB 1) = separator OR is error
+ PER;
+ cursor (x + 1 + editflaenge - dyn fanfang, y);
+ fmarke := altfmarke; fstelle := altfstelle; fanfang := altfanfang;
+ dyn fanfang := fanfang; fende := altfende; dyn fende := fende;
+ limit := altlimit; wortweise := altwortweise; frand := altfrand;
+ feinfuegen := altfeinfuegen .
+
+editflaenge :
+ min (dyn fende, flaenge) .
+
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz) :
+ INT VAR x, y; get cursor (x,y);
+ editget (editsatz, 255, fende-fanfang+2+frand-x)
+END PROC editget;
+
+PROC feldout (TEXT CONST satz) :
+ INT VAR x, y;
+ flaenge := min (fende, LENGTH satz);
+ out (cr);
+ frand TIMESOUT right; feldrest loeschen (fanfang);
+ IF fmarke > 0
+ THEN outsubtext (satz, fanfang, fmarke-1); out (begin mark);
+ outsubtext (satz, fmarke, min (fstelle-1,flaenge));
+ out (end mark); outsubtext (satz, fstelle, flaenge);
+ ELIF absatzmarke noetig (satz)
+ THEN get cursor (x,y); outsubtext (satz, fanfang, flaenge);
+ cursor (x + fende + 1 - fanfang, y); out (absatzmarke)
+ ELSE outsubtext (satz, fanfang, flaenge)
+ FI
+END PROC feldout;
+
+
+PROC feld einruecken (TEXT CONST satz) :
+
+ IF fstelle = fanfang
+ THEN fstelle := neue einrueckposition;
+ (fstelle-fanfang) TIMESOUT right
+ FI .
+
+neue einrueckposition :
+ INT VAR suchindex;
+ FOR suchindex FROM fanfang UPTO min (LENGTH satz, fende)
+ REP IF (satz SUB suchindex) <> blank
+ THEN LEAVE neue einrueckposition WITH suchindex
+ FI
+ PER;
+ fanfang .
+
+END PROC feld einruecken;
+
+TEXT PROC feldzeichen :
+ fzeichen
+END PROC feldzeichen;
+
+TEXT PROC feldkommando :
+ kommando
+END PROC feldkommando;
+
+PROC feldkommando (TEXT CONST t) :
+ kommando := t
+END PROC feldkommando;
+
+PROC feldtab (TEXT VAR t) :
+ t := tabulator
+END PROC feldtab;
+
+PROC feldtabulator (TEXT CONST t) :
+ tabulator := t
+END PROC feldtabulator;
+
+TEXT PROC feldseparator :
+ separator
+END PROC feldseparator;
+
+PROC feldseparator (TEXT CONST t) :
+ separator := t; blankseparator := t = blank
+END PROC feldseparator;
+
+TEXT PROC feldaudit :
+ audit
+END PROC feldaudit;
+
+PROC feldaudit (TEXT CONST a) :
+ audit := a
+END PROC feldaudit;
+
+BOOL PROC feldlernmodus :
+ lernmodus
+END PROC feldlernmodus;
+
+PROC feldlernmodus (BOOL CONST b) :
+ lernmodus := b
+END PROC feldlernmodus;
+
+BOOL PROC feldeinfuegen :
+ feinfuegen
+END PROC feldeinfuegen;
+
+PROC feldeinfuegen (BOOL CONST b):
+ feinfuegen := b
+END PROC feldeinfuegen;
+
+BOOL PROC feldwortweise :
+ wortweise
+END PROC feldwortweise;
+
+PROC feldwortweise (BOOL CONST b) :
+ wortweise := b
+END PROC feldwortweise;
+
+INT PROC feldmarke :
+ fmarke
+END PROC feldmarke;
+
+PROC feldmarke (INT CONST i) :
+ fmarke := i MOD 256
+END PROC feldmarke;
+
+INT PROC feldstelle :
+ fstelle
+END PROC feldstelle;
+
+PROC feldstelle (INT CONST i) :
+ fstelle := i MOD 256
+END PROC feldstelle;
+
+INT PROC feldanfang :
+ fanfang
+END PROC feldanfang;
+
+PROC feldanfang (INT CONST i) :
+ fanfang := i MOD 256; dyn fanfang := fanfang
+END PROC feldanfang;
+
+INT PROC feldende :
+ fende
+END PROC feldende;
+
+PROC feldende (INT CONST i) :
+ fende := i MOD 256; dyn fende := fende
+END PROC feldende;
+
+INT PROC feldrand :
+ frand
+END PROC feldrand;
+
+PROC feldrand (INT CONST i) :
+ frand := i MOD 256
+END PROC feldrand;
+
+INT PROC feldlimit :
+ limit
+END PROC feldlimit;
+
+PROC feldlimit (INT CONST i) :
+ limit := i MOD 256
+END PROC feldlimit;
+
+PROC feldposition :
+ INT VAR x, y;
+ IF fstelle <= fende
+ THEN IF fstelle < fanfang
+ THEN fstelle := fanfang;
+ IF fanfang > fende
+ THEN fende := fanfang; dyn fende := fanfang
+ FI
+ FI
+ ELSE fstelle := fende;
+ IF fanfang > fende
+ THEN fanfang := fende; dyn fanfang := fende
+ FI
+ FI;
+ get cursor(x,y); cursor(1+frand+fstelle-fanfang+fmarke oder fstelle, y).
+
+fmarke oder fstelle :
+ IF fmarke > 0 THEN 1 ELSE 0 FI .
+
+END PROC feldposition;
+
+PROC feldposition (INT CONST i) :
+ fstelle := i; feldposition
+END PROC feldposition;
+
+BOOL PROC absatzmarke noetig (TEXT CONST satz) :
+
+ IF wortweise
+ THEN (satz SUB LENGTH satz) = blank
+ ELSE FALSE
+ FI
+END PROC absatzmarke noetig;
+
+PROC zeile neu schreiben (TEXT CONST satz) :
+ INT VAR x,y; get cursor (x,y);
+ flaenge := min (dyn fende, LENGTH satz);
+ cursor (1+frand, y);
+ feldrest loeschen (dyn fanfang);
+ outsubtext (satz, dyn fanfang, flaenge);
+ cursor (x,y)
+END PROC zeile neu schreiben;
+
+PROC feldrest loeschen (INT CONST fstelle):
+ INT VAR x,y;
+ IF frand + fende <= 76
+ THEN get cursor (x,y); (1 + dyn fende - fstelle) TIMESOUT blank;
+ cursor (x,y)
+ ELSE out (clear eol); war absatz := FALSE
+ FI
+END PROC feldrest loeschen;
+
+TEXT OP SUBB (TEXT CONST t, INT CONST i) :
+ IF i <= LENGTH t THEN t SUB i ELSE blank FI
+END OP SUBB;
+
+INT PROC min (INT CONST a, b):
+ IF a < b THEN a ELSE b FI
+END PROC min;
+
+BOOL PROC is incharety (TEXT CONST muster) :
+
+ fzeichen := incharety;
+ IF fzeichen = ""
+ THEN FALSE
+ ELSE IF lernmodus
+ THEN audit CAT fzeichen;
+ IF fzeichen = """" THEN audit CAT fzeichen
+ FI FI ;
+ IF fzeichen = muster
+ THEN kommando := ""; TRUE
+ ELSE kommando CAT fzeichen; FALSE
+ FI FI
+END PROC is incharety;
+
+PROC getchar (TEXT VAR fzeichen) :
+
+ IF kommando = ""
+ THEN inchar (fzeichen)
+ ELSE fzeichen := kommando SUB 1;
+ delete char (kommando, 1);
+ kommando CAT incharety
+ FI;
+ IF lernmodus
+ THEN audit CAT fzeichen;
+ IF fzeichen = """"
+ THEN audit CAT fzeichen
+ FI
+ FI .
+END PROC getchar;
+
+
+(************************** f e l d e d i t o r **************************)
+
+PROC feldeditor (TEXT VAR satz) :
+
+ enable stop ; (* J. Liedtke 10.02.82 *)
+
+ INT VAR x, y;
+ BOOL VAR inkompetent :: FALSE; war absatz := absatzmarke noetig (satz);
+ IF fstelle <= fende
+ THEN IF fstelle < fanfang THEN feldposition FI
+ ELSE feldposition
+ FI;
+ flaenge := min (fende, LENGTH satz);
+
+ REP e i n g a b e UNTIL inkompetent PER;
+
+ blanks abschneiden;
+ IF dyn fanfang <> fanfang THEN zurechtruecken FI;
+ IF NOT war absatz AND absatzmarke noetig (satz)
+ THEN absatzmarke schreiben
+ ELIF war absatz AND NOT absatzmarke noetig (satz)
+ THEN absatzmarke loeschen
+ FI .
+
+absatzmarke schreiben :
+ get cursor (x,y); cursor (frand+fende-fanfang+2, y); out (absatzmarke);
+ cursor (x,y) .
+
+absatzmarke loeschen :
+ get cursor (x,y); cursor (frand+fende-fanfang+2, y); out (" ");
+ cursor (x,y) .
+
+zurechtruecken :
+ fstelle DECR (dyn fanfang - fanfang);
+ dyn fanfang := fanfang; dyn fende := fende;
+ zeile neu schreiben (satz) .
+
+blanks abschneiden :
+ flaenge := LENGTH satz;
+ FOR fj FROM flaenge DOWNTO 0 WHILE (satz SUB fj) = blank
+ REP delete char (satz, fj) PER;
+ IF fj < flaenge THEN satz CAT blank FI .
+
+eingabe :
+ IF fmarke <= 0
+ THEN s c h r e i b e d i t o r;
+ IF ueberlaufbedingung
+ THEN ueberlauf
+ ELSE a u s f u e h r e n
+ FI
+ ELSE m a r k e d i t o r
+ FI .
+
+ueberlaufbedingung :
+ IF fstelle <= dyn fende
+ THEN IF fstelle <= limit
+ THEN FALSE
+ ELSE fzeichen > hoechstes steuerzeichen
+ FI
+ ELSE TRUE
+ FI .
+
+ueberlauf :
+ IF fstelle > limit
+ THEN IF wortweise OR fstelle > LENGTH satz
+ THEN ueberlauf in naechste zeile; LEAVE ueberlauf
+ FI
+ FI;
+ IF fstelle > dyn fende
+ THEN fstelle := dyn fende; out (left);
+ zeile um eins nach links verschieben
+ FI .
+
+ueberlauf in naechste zeile :
+ IF wortweise
+ THEN umbrechen
+ ELSE out (bell); kommando := cr
+ FI;
+ inkompetent := TRUE .
+
+umbrechen :
+ IF LENGTH satz > limit
+ THEN kommando CAT subtext (satz, limit+1);
+ FOR fj FROM LENGTH satz DOWNTO fstelle
+ REP kommando CAT left PER;
+ satz := subtext (satz, 1, limit)
+ FI;
+ fj := limit;
+ zeichen zuruecknehmen;
+ (fstelle-fj) TIMESOUT left; fstelle := fj; feldrest loeschen (fstelle);
+ IF kommando = "" THEN kommando := blank left rubout FI;
+ blanks loeschen.
+
+blanks loeschen:
+ REP fj DECR 1;
+ IF (satz SUB fj) <> blank THEN LEAVE blanks loeschen FI;
+ delete char (satz, fj)
+ PER .
+
+zeichen zuruecknehmen:
+ REP fzeichen := satz SUB fj; delete char (satz, fj);
+ IF fzeichen = blank THEN LEAVE zeichen zuruecknehmen FI;
+ insert char (kommando, fzeichen, 1);
+ IF fj = fanfang THEN LEAVE zeichen zuruecknehmen FI;
+ fj DECR1
+ PER.
+
+ausfuehren :
+ dezimalen := 0;
+ SELECT pos (hop esc right left tab rubin rubout cr, fzeichen) OF
+ CASE 1 : getchar (fzeichen);
+ SELECT pos (right left tab rubout escape, fzeichen) OF
+ CASE 1 : zum rechten frand
+ CASE 2 : zum linken frand
+ CASE 3 : tabulator setzen
+ CASE 4 : zeile loeschen
+ CASE 5 : bei lernmodus ein zeichen lesen
+ OTHERWISE hop return
+ END SELECT
+ CASE 2 : escape aktion
+ CASE 3 : nach rechts
+ CASE 4 : nach links
+ CASE 5 : nach tabulator
+ CASE 6 : feinfuegen umschalten
+ CASE 7 : ausfuegen
+ CASE 8 : ggf absatz erzeugen; return
+ OTHERWISE return
+ END SELECT .
+
+ggf absatz erzeugen :
+ IF wortweise
+ THEN IF fstelle > LENGTH satz
+ THEN IF (satz SUB LENGTH satz) <> blank
+ THEN satz CAT blank; fstelle INCR 1
+ FI
+ FI
+ FI .
+
+nach rechts :
+ IF fstelle < dyn fende AND (fstelle < limit OR fstelle < flaenge)
+ THEN out (right); fstelle INCR1
+ ELIF LENGTH satz > dyn fende
+ THEN zeile um eins nach links verschieben
+ ELSE return
+ FI .
+
+nach links :
+ IF fstelle > dyn fanfang
+ THEN out (left); fstelle DECR1
+ ELIF dyn fanfang = fanfang
+ THEN out (bell)
+ ELSE zeile um eins nach rechts verschieben
+ FI .
+
+bei lernmodus ein zeichen lesen :
+ IF lernmodus
+ THEN getchar (fzeichen); return;
+ fzeichen := escape
+ FI;
+ hop return; fzeichen := hop escape .
+
+zeile um eins nach links verschieben :
+ dyn fanfang INCR 1; dyn fende INCR 1;
+ fstelle := dyn fende; zeile neu schreiben (satz) .
+
+zeile um eins nach rechts verschieben :
+ dyn fanfang DECR 1; dyn fende DECR 1;
+ fstelle := dyn fanfang; zeile neu schreiben (satz) .
+
+feinfuegen umschalten :
+ IF feinfuegen
+ THEN feinfuegen := FALSE
+ ELSE feinfuegen := TRUE; get cursor (x,y); out (dach);
+ outsubtext (satz, fstelle, flaenge);
+ cursor (x,y); pause (1);
+ feldrest loeschen (fstelle);
+ outsubtext (satz, fstelle, flaenge);
+ cursor (x,y)
+ FI;
+ return .
+
+ausfuegen :
+ IF flaenge < dyn fanfang OR fstelle > flaenge
+ THEN IF fstelle = flaenge + 1 AND fstelle > dyn fanfang
+ THEN fstelle := flaenge; out (left)
+ ELSE out (bell);
+ LEAVE ausfuegen
+ FI
+ FI;
+ ausfuegeoperation; delete char (satz, fstelle);
+ flaenge := min (dyn fende, LENGTH satz) .
+
+ausfuegeoperation :
+ get cursor (x,y); outsubtext (satz, fstelle+1, flaenge+1);
+ out (blank); cursor (x,y) .
+
+zum linken frand :
+ IF fstelle > fanfang
+ THEN get cursor (x,y); cursor (1+frand, y);
+ IF dyn fanfang = fanfang
+ THEN fstelle := fanfang
+ ELSE verschieben an linken frand
+ FI
+ FI .
+
+zum rechten frand :
+ fj := min (dyn fende, limit); get cursor (x,y);
+ IF LENGTH satz > fj
+ THEN IF fstelle >= LENGTH satz
+ THEN out (bell)
+ ELIF LENGTH satz > dyn fende
+ THEN verschieben an rechten frand
+ ELSE cursor (x + LENGTH satz - fstelle, y);
+ fstelle := LENGTH satz
+ FI
+ ELIF fstelle < fj
+ THEN cursor (x + fj-fstelle, y); fstelle := fj
+ FI .
+
+verschieben an linken frand :
+ dyn fanfang := fanfang; dyn fende := fende;
+ fstelle := fanfang; zeile neu schreiben (satz).
+
+verschieben an rechten frand :
+ (dyn fende - fstelle) TIMESOUT right;
+ dyn fanfang INCR (LENGTH satz - dyn fende); dyn fende := LENGTH satz;
+ fstelle := dyn fende; zeile neu schreiben (satz).
+
+nach tabulator :
+ fj := pos (tabulator, "^", fstelle+1);
+ IF fj = 0
+ THEN IF (satz SUB fstelle) = blank AND fstelle = fanfang
+ THEN IF satz = blank
+ THEN fstelle INCR 1; out (right)
+ ELSE out (blank left); feld einruecken (satz);
+ FI;
+ LEAVE nach tabulator
+ ELIF flaenge < dyn fende AND fstelle <= flaenge
+ THEN fj := flaenge + 1
+ FI
+ ELSE dezimalen := 1
+ FI;
+ IF fj > 0 AND fj <= dyn fende
+ THEN outsubtext (satz, fstelle, fj-1); fstelle := fj
+ ELSE (fstelle-dyn fanfang) TIMESOUT left;
+ fstelle := dyn fanfang; insert char (kommando, down, 1)
+ FI .
+
+tabulator setzen :
+ IF (tabulator SUB fstelle) = "^"
+ THEN fzeichen := right
+ ELSE fzeichen := "^"
+ FI;
+ WHILE fstelle > LENGTH tabulator
+ REP tabulator CAT right PER;
+ replace (tabulator, fstelle, fzeichen);
+ insert char (kommando, tab, 1);
+ insert char (kommando, hop, 1);
+ inkompetent := TRUE .
+
+zeile loeschen :
+ IF fstelle = 1
+ THEN satz := ""; feldrest loeschen (fstelle); hop return
+ ELIF fstelle <= flaenge
+ THEN REP delete char (satz, LENGTH satz)
+ UNTIL fstelle > LENGTH satz
+ PER;
+ flaenge := fstelle - 1; feldrest loeschen (fstelle)
+ ELSE hop return
+ FI .
+
+(*********************** s c h r e i b e d i t o r ***********************)
+
+schreibeditor :
+ REP getchar (fzeichen);
+ IF fzeichen <= hoechstes steuerzeichen THEN LEAVE schreibeditor
+ ELIF separator bedingung THEN LEAVE schreibeditor
+ ELSE f o r t s c h r e i b e n FI
+ PER .
+
+separatorbedingung :
+ IF blankseparator
+ THEN IF flaenge + 2 <= fstelle
+ THEN insert char (kommando, fzeichen, 1);
+ fzeichen := blank
+ FI
+ FI;
+ fzeichen = separator .
+
+fortschreiben :
+ IF dezimalen > 0 THEN dezimaltabulator FI;
+ out (fzeichen);
+ IF fstelle > flaenge
+ THEN anhaengen
+ ELIF dezimalen = 0 AND feinfuegen
+ THEN insert char (satz, fzeichen, fstelle)
+ ELSE replace (satz, fstelle, fzeichen)
+ FI;
+ flaenge := min (dyn fende, LENGTH satz);
+ fstelle INCR 1;
+ IF feinfuegen AND dezimalen = 0 AND fstelle <= flaenge
+ THEN zeilenrest neu schreiben
+ FI;
+ IF fstelle > dyn fende
+ OR fstelle > limit AND (wortweise OR fstelle > flaenge)
+ THEN LEAVE schreibeditor
+ FI .
+
+zeilenrest neu schreiben :
+ get cursor (x,y); outsubtext (satz, fstelle, flaenge); cursor (x,y) .
+
+dezimaltabulator :
+ IF fzeichen < "0" OR fzeichen > "9"
+ THEN dezimalen := 0
+ ELIF dezimalen = 1
+ THEN IF (satz SUB fstelle) = blank OR fstelle > flaenge
+ THEN dezimalen := 2
+ ELSE dezimalen := 0
+ FI
+ ELIF (satz SUB fstelle-dezimalen) = blank
+ THEN replace (satz, fstelle-dezimalen,
+ subtext (satz, fstelle-dezimalen+1, fstelle-1)) ;
+ dezimalen TIMESOUT left;
+ outsubtext (satz, fstelle-dezimalen, fstelle-2);
+ dezimalen INCR 1; fstelle DECR 1
+ ELSE dezimalen := 0
+ FI .
+
+anhaengen :
+ FOR fj FROM flaenge+2 UPTO fstelle
+ REP satz CAT blank PER;
+ satz CAT fzeichen .
+
+
+(************************** m a r k e d i t o r **************************)
+
+markeditor :
+ getchar (fzeichen);
+ SELECT pos (hop esc right left tab down cr, fzeichen) OF
+ CASE 1 : getchar (fzeichen);
+ IF fzeichen = right THEN markierung maximal
+ ELIF fzeichen = left THEN markierung minimal
+ ELSE hop return
+ FI
+ CASE 2 : escape aktion
+ CASE 3 : markierung verlaengern
+ CASE 4 : markierung verkuerzen
+ CASE 5 : markierung bis tab verlaengern
+ CASE 6,7 : zeilenrest markieren
+ OTHERWISE IF fzeichen <= hoechstes steuerzeichen
+ THEN return
+ ELSE out (bell)
+ FI
+ END SELECT .
+
+markierung verlaengern :
+ IF fstelle <= flaenge
+ THEN out (satz SUB fstelle, end mark left); fstelle INCR 1
+ ELSE return
+ FI .
+
+markierung maximal :
+ IF fstelle <= flaenge
+ THEN outsubtext (satz, fstelle, flaenge); out (end mark left);
+ fstelle := flaenge + 1
+ FI .
+
+zeilenrest markieren :
+ IF fstelle <= flaenge
+ THEN outsubtext (satz, fstelle, flaenge);
+ out (end mark left);
+ (flaenge-fstelle+2) TIMESOUT left
+ FI;
+ return .
+
+markierung verkuerzen :
+ IF fstelle > fmarke
+ THEN fstelle DECR 1;
+ out (left end mark, satz SUBB fstelle, left left)
+ ELSE out (bell)
+ FI .
+
+markierung minimal :
+ IF fstelle > fmarke
+ THEN (fstelle-fmarke) TIMESOUT left; out (end mark);
+ outsubtext (satz, fmarke, fstelle-1);
+ (fstelle-fmarke+1) TIMESOUT left; fstelle := fmarke
+ FI .
+
+markierung bis tab verlaengern :
+ fj := pos (tabulator, "^", fstelle + 1);
+ IF fj = 0
+ THEN fj := flaenge - fstelle + 1; IF fj <= 0 THEN return FI
+ ELSE fj DECR fstelle
+ FI;
+ IF fj > 0
+ THEN outsubtext (satz, fstelle, min (fstelle+fj-1, flaenge));
+ out (end mark left)
+ FI;
+ fstelle INCR fj;
+ IF fstelle > (dyn fende+1) THEN return FI .
+
+
+(******************* allgemein verwendete refinements *********************)
+
+return :
+ insert char (kommando, fzeichen, 1);
+ inkompetent := TRUE .
+
+hop return :
+ return; insert char (kommando, hop, 1) .
+
+escape aktion :
+ getchar (fzeichen); return;
+ insert char (kommando, escape, 1);
+ insert char (fzeichen, escape, 1) .
+
+END PROC feldeditor;
+
+END PACKET feldeditor;
diff --git a/system/base/unknown/src/file b/system/base/unknown/src/file new file mode 100644 index 0000000..e556bec --- /dev/null +++ b/system/base/unknown/src/file @@ -0,0 +1,810 @@ +
+PACKET file DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.04.82 *)
+ FILE ,
+ := ,
+ input ,
+ output ,
+ modify ,
+ sequential file ,
+ getline ,
+ putline ,
+ line ,
+ reset ,
+ eof ,
+ put ,
+ get ,
+ page ,
+ out ,
+ eop ,
+ close ,
+ max line length ,
+ max page length ,
+ read record ,
+ write record ,
+ forward ,
+ backward ,
+ delete record ,
+ insert record ,
+ to first record ,
+ to eof ,
+ is first record ,
+ headline ,
+ copy attributes ,
+ reorganize ,
+ feldeditor ,
+ feldout ,
+ feldeinruecken ,
+ pos ,
+ change ,
+ subtext ,
+ sort :
+
+
+
+TYPE FILE = STRUCT ( BOUND DATEI f ,
+ INT index, pointer, line counter,
+ mode, max line length, max page length,
+ BOOL edit status unchanged) ;
+
+TYPE TRANSPUTDIRECTION = INT ;
+
+LET closed = 1 ,
+ in = 2 ,
+ outp = 3 ,
+ mod = 4 ,
+ end = 5 ,
+ escape = ""27"" ,
+
+ nullzustand = " 0 1 1" ,
+
+ max length = 15 000 ; (* < maxint/2 because 2 * maxlength possible*)
+
+
+TRANSPUTDIRECTION PROC input :
+ TRANSPUTDIRECTION : ( in )
+ENDPROC input ;
+
+TRANSPUTDIRECTION PROC output :
+ TRANSPUTDIRECTION : ( outp )
+ENDPROC output ;
+
+TRANSPUTDIRECTION PROC modify :
+ TRANSPUTDIRECTION : ( mod )
+ENDPROC modify ;
+
+LET DATEI = ROW 4075 STRUCT (
+ INT nachfolger, vorgaenger, index, fortsetzung,
+ TEXT inhalt ) ;
+
+LET anker = 2 ,
+ freianker = 1 ;
+
+TEXT VAR number word ;
+
+FILE VAR result file ;
+
+DATASPACE VAR scratch space ;
+close ;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode) :
+
+ IF CONCR (mode) = outp
+ THEN close
+ FI ;
+ sequential file (mode, scratch space)
+
+ENDPROC sequential file ;
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ DATASPACE VAR ds) :
+
+ IF type (ds) = 1002
+ THEN result file.f := ds
+ ELIF type (ds) < 0
+ THEN result file.f := ds ;
+ type (ds, 1002) ;
+ datei initialisieren (CONCR (result file.f))
+ ELSE errorstop ("dataspace has wrong type") ;
+ result file.f := scratch space
+ FI ;
+ result file.mode := CONCR (mode) ;
+ reset (result file) ;
+ result file.max line length := max line length (result file) ;
+ result file.max page length := 0 ;
+
+ result file .
+
+ENDPROC sequential file ;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ TEXT CONST name ) :
+
+ IF exists (name)
+ THEN get dataspace if file
+ ELIF CONCR (mode) <> in
+ THEN get new file space
+ ELSE errorstop ("input file not existing") ;
+ result file.f := scratch space
+ FI ;
+ IF CONCR (mode) <> in
+ THEN status (name, "") ;
+ headline (result file, name)
+ FI ;
+ result file.mode := CONCR (mode) ;
+ reset (result file) ;
+ result file.max line length := max line length (result file) ;
+ result file.max page length := 0 ;
+
+ result file .
+
+get new file space :
+ result file.f := new (name) ;
+ IF NOT is error
+ THEN type (old (name), 1002) ;
+ datei initialisieren ( CONCR (result file.f) )
+ FI .
+
+get dataspace if file :
+ result file.f := old (name, 1002) .
+
+ENDPROC sequential file ;
+
+INT PROC max line length (FILE CONST file) :
+
+ int (subtext (zustand, 16, 20)) .
+
+zustand :
+ CONCR (file.f) (freianker).inhalt .
+
+ENDPROC max line length ;
+
+PROC max line length (FILE VAR file, INT CONST length) :
+
+ replace (zustand, 16, text (length,5)) .
+
+zustand :
+ CONCR (file.f) (freianker).inhalt .
+
+ENDPROC max line length ;
+
+PROC headline (FILE VAR file, TEXT CONST head) :
+
+ CONCR (file.f)(anker).inhalt := head
+
+ENDPROC headline ;
+
+TEXT PROC headline (FILE VAR file) :
+
+ CONCR (file.f)(anker).inhalt
+
+ENDPROC headline ;
+
+PROC copy attributes (FILE CONST source, FILE VAR dest) :
+
+ dest attributes := source attributes ;
+ reset edit status (dest) ;
+ dest headline := source headline .
+
+dest attributes : CONCR (dest.f) (freianker).inhalt .
+source attributes : CONCR (source.f) (freianker).inhalt .
+
+dest headline : CONCR (dest.f) (anker).inhalt .
+source headline : CONCR (source.f) (anker).inhalt .
+
+ENDPROC copy attributes ;
+
+
+PROC input (FILE VAR file) :
+
+ file.mode := in ;
+ reset (file)
+
+ENDPROC input ;
+
+PROC output (FILE VAR file) :
+
+ file.mode := outp ;
+ reset (file)
+
+ENDPROC output ;
+
+PROC modify (FILE VAR file) :
+
+ file.mode := mod ;
+ reset (file)
+
+ENDPROC modify ;
+
+
+PROC putline (FILE VAR file, TEXT CONST record) :
+
+ check mode (file, outp) ;
+ line (file) ;
+ CONCR (file.f)(file.index).inhalt := record ;
+ file.pointer := max length
+
+ENDPROC putline ;
+
+
+PROC getline (FILE VAR file, TEXT VAR record) :
+
+ check mode (file, in) ;
+ line (file) ;
+ record := CONCR (file.f)(file.index).inhalt ;
+ file.pointer := max length
+
+ENDPROC getline ;
+
+
+PROC line (FILE VAR file) :
+
+ file.index := CONCR (file.f) (file.index).nachfolger ;
+ file.pointer := 0 ;
+ IF file.mode = in
+ THEN check eof
+ ELIF file.mode = outp
+ THEN satz erzeugen (CONCR (file.f), file.index) ;
+ CONCR (file.f)(file.index).inhalt := "" ;
+ perhaps implicit page feed
+ FI .
+
+check eof :
+ IF eof
+ THEN file.mode := end
+ FI .
+
+eof : CONCR (file.f)(file.index).nachfolger = anker .
+
+perhaps implicit page feed :
+ file.line counter INCR 1 ;
+ IF file.line counter = file.max page length
+ THEN page (file)
+ FI .
+
+ENDPROC line ;
+
+PROC check mode (FILE CONST file, INT CONST mode) :
+
+ IF file.mode = mode
+ THEN LEAVE check mode
+ ELIF file.mode = closed
+ THEN errorstop ("file not open")
+ ELIF file.mode = mod
+ THEN errorstop ("operation not in transputdirection 'modify'")
+ ELIF mode = mod
+ THEN errorstop ("operation only in transputdirection 'modify'")
+ ELIF file.mode = end
+ THEN IF eof (file) THEN errorstop ("input after end of file") FI
+ ELIF mode = in
+ THEN errorstop ("input access to output file")
+ ELIF mode = outp
+ THEN errorstop ("output access to input file")
+ FI
+
+ENDPROC check mode ;
+
+PROC reset (FILE VAR file) :
+
+ file.pointer := max length ;
+ file.line counter := 0 ;
+ file.edit status unchanged := TRUE ;
+ initialize file index ;
+ set correct file mode .
+
+initialize file index :
+ IF file.mode = outp
+ THEN file.index := last record
+ ELSE file.index := anker
+ FI .
+
+set correct file mode :
+ IF file.mode = end
+ THEN file.mode := in
+ FI ;
+ IF file.mode = in AND empty file
+ THEN file.mode := end
+ FI .
+
+last record : CONCR (file.f) (anker).vorgaenger .
+
+empty file : CONCR (file.f) (anker).nachfolger = anker .
+
+ENDPROC reset ;
+
+BOOL PROC eof (FILE CONST file) :
+
+ IF file.mode = end
+ THEN end of record
+ ELIF file.mode = mod
+ THEN file.index = anker
+ ELSE FALSE
+ FI .
+
+end of record :
+ file.pointer >= length (CONCR (file.f)(file.index).inhalt) .
+
+ENDPROC eof ;
+
+PROC line (FILE VAR file, INT CONST lines) :
+
+ check mode (file, outp) ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO lines REP
+ line (file)
+ PER
+
+ENDPROC line ;
+
+PROC page (FILE VAR file) :
+
+ file.line counter := 0 ;
+ putline (file, "#page")
+
+ENDPROC page ;
+
+BOOL PROC eop (FILE CONST file) :
+
+ CONCR (file.f)(file.index).inhalt = "#page"
+
+ENDPROC eop ;
+
+PROC put (FILE VAR file, TEXT CONST word) :
+
+ check mode (file, outp) ;
+ IF file.pointer + LENGTH word >= file.max line length
+ THEN line (file)
+ FI ;
+ put word (CONCR (file.f)(file.index).inhalt, word, file.pointer)
+
+ENDPROC put ;
+
+PROC put word (TEXT VAR record, TEXT CONST word, INT VAR pointer) :
+
+ IF pointer > 0
+ THEN record CAT " " ;
+ FI ;
+ record CAT word ;
+ pointer := LENGTH record
+
+ENDPROC put word ;
+
+PROC put (FILE VAR f, INT CONST value) :
+
+ put (f, text (value) )
+
+ENDPROC put ;
+
+PROC put (FILE VAR f, REAL CONST real) :
+
+ put (f, text (real) )
+
+ENDPROC put ;
+
+PROC out (FILE VAR file, TEXT CONST word) :
+
+ check mode (file, outp) ;
+ IF file.pointer + LENGTH word >= file.max line length
+ THEN line (file)
+ FI ;
+ record CAT word ;
+ file.pointer INCR LENGTH word .
+
+record : CONCR (file.f)(file.index).inhalt .
+
+ENDPROC out ;
+
+PROC get (FILE VAR file, TEXT VAR word, TEXT CONST separator) :
+
+ check mode (file, in) ;
+ get word (CONCR (file.f)(file.index).inhalt, word,
+ file.pointer, max length, separator)
+
+ENDPROC get ;
+
+PROC get (FILE VAR file, TEXT VAR word, INT CONST max length) :
+
+ check mode (file, in) ;
+ get word (CONCR (file.f)(file.index).inhalt, word,
+ file.pointer, max length, "")
+
+ENDPROC get ;
+
+PROC get (FILE VAR file, TEXT VAR word) :
+
+ check mode (file, in) ;
+ next word (file, CONCR (file.f)(file.index).inhalt, word)
+
+ENDPROC get ;
+
+PROC next word (FILE VAR file, TEXT CONST record, TEXT VAR word) :
+
+ get next non blank char ;
+ IF char found
+ THEN get word (record, word, file.pointer, max length, " ")
+ ELIF last line of file
+ THEN word := "" ;
+ file.pointer := max length
+ ELSE line (file) ;
+ get (file, word)
+ FI .
+
+get next non blank char :
+ TEXT VAR char ;
+ REP
+ file.pointer INCR 1 ;
+ char := record SUB file.pointer
+ UNTIL char <> " " PER ;
+ file.pointer DECR 1 .
+
+char found : char <> "" .
+
+last line of file :
+ CONCR (file.f) (anker).nachfolger = anker .
+
+ENDPROC next word ;
+
+PROC get (FILE VAR f, INT VAR number) :
+
+ get (f, number word) ;
+ number := int (number word)
+
+ENDPROC get ;
+
+PROC get (FILE VAR f, REAL VAR number) :
+
+ get (f, number word) ;
+ number := real (number word)
+
+ENDPROC get ;
+
+PROC get word (TEXT CONST record, TEXT VAR word, INT VAR pointer,
+ INT CONST max length, TEXT CONST separator) :
+
+ INT VAR end of word := pos (record, separator, pointer+1) - 1 ;
+ IF end of word < 0
+ THEN end of word := pointer + max length
+ FI ;
+ word := subtext (record, pointer+1, end of word) ;
+ pointer := end of word + 1
+
+ENDPROC get word ;
+
+PROC close (FILE VAR file) :
+
+ file.mode := closed
+
+ENDPROC close ;
+
+PROC close :
+
+ disable stop ;
+ forget (scratch space) ;
+ scratch space := nilspace
+
+ENDPROC close ;
+
+INT PROC max page length (FILE CONST file) :
+ file.max page length
+ENDPROC max page length ;
+
+PROC max page length (FILE VAR file, INT CONST length) :
+ file.max page length := length
+ENDPROC max page length
+
+
+PROC read record (FILE CONST file, TEXT VAR record) :
+
+ check mode (file, mod) ;
+ record := CONCR (file.f) (file.index).inhalt
+
+ENDPROC read record ;
+
+PROC write record (FILE VAR file, TEXT CONST record) :
+
+ check mode (file, mod) ;
+ CONCR (file.f) (file.index).inhalt := record
+
+ENDPROC write record ;
+
+PROC forward (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.index <> anker
+ THEN file.index := CONCR (file.f) (file.index).nachfolger
+ ELSE errorstop ("forward at eof")
+ FI
+
+ENDPROC forward ;
+
+PROC backward (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := CONCR (file.f) (file.index).vorgaenger ;
+ IF file.index = anker
+ THEN to first record (file) ;
+ errorstop ("backward at first record")
+ FI
+
+ENDPROC backward ;
+
+PROC delete record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.edit status unchanged
+ THEN reset edit status (file)
+ FI ;
+ satz loeschen (CONCR (file.f), file.index)
+
+ENDPROC delete record ;
+
+PROC insert record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.edit status unchanged
+ THEN reset edit status (file)
+ FI ;
+ satz erzeugen (CONCR (file.f), file.index)
+
+ENDPROC insert record ;
+
+PROC to first record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := CONCR (file.f) (anker).nachfolger
+
+ENDPROC to first record ;
+
+PROC to eof (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := anker
+
+ENDPROC to eof ;
+
+BOOL PROC is first record (FILE CONST file) :
+
+ file.index = CONCR (file.f) (anker).nachfolger
+
+ENDPROC is first record ;
+
+PROC reset edit status (FILE VAR file) :
+
+ replace (zustand, 1, nullzustand) ;
+ file.edit status unchanged := FALSE .
+
+zustand : CONCR (file.f)(freianker).inhalt .
+
+ENDPROC reset edit status ;
+
+
+FILE VAR scratch , file ;
+TEXT VAR record ;
+
+LET esc = ""27"" ;
+
+PROC reorganize (TEXT CONST file name) :
+
+ IF exists (file name)
+ THEN last param (file name) ;
+ reorganize file
+ ELSE errorstop ("file does not exist")
+ FI .
+
+reorganize file :
+ scratch := sequential file (output) ;
+ headline (scratch, file name) ;
+ IF format 15
+ THEN set to 16 file type ;
+ file := sequential file (input, file name)
+ ELSE file := sequential file (input, file name) ;
+ copy attributes (file, scratch)
+ FI ;
+
+ disable stop ;
+
+ INT VAR counter := 0 ;
+ WHILE NOT eof (file) REP
+ getline (file, record) ;
+ putline (scratch, record) ;
+ counter INCR 1 ;
+ cout (counter) ;
+ IF is incharety (escape) OR is error
+ THEN close ;
+ LEAVE reorganize
+ FI
+ PER ;
+ forget file ;
+ copy (scratch space, file name) ;
+ close .
+
+forget file :
+ BOOL CONST old status := command dialogue ;
+ command dialogue (FALSE) ;
+ forget (file name) ;
+ command dialogue (old status) .
+
+format 15 : type (old (file name)) = 1001 .
+
+set to 16 file type :
+ type (old (file name), 1002) .
+
+ENDPROC reorganize ;
+
+PROC reorganize :
+
+ reorganize (last param)
+
+ENDPROC reorganize ;
+
+PROC feldout (FILE CONST file, TEXT CONST satz) :
+
+ feldout ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldout ;
+
+PROC feldeinruecken (FILE CONST file, TEXT CONST satz) :
+
+ feldeinruecken ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldeinruecken ;
+
+PROC feldeditor (FILE VAR file, TEXT CONST satz) :
+
+ feldeditor ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldeditor ;
+
+INT PROC pos (FILE CONST file, TEXT CONST pattern, INT CONST from) :
+
+ pos ( CONCR (file.f) (file.index).inhalt, pattern, from )
+
+ENDPROC pos ;
+
+PROC change (FILE VAR file, INT CONST from, to, TEXT CONST new) :
+
+ change ( CONCR (file.f) (file.index).inhalt, from, to, new )
+
+ENDPROC change ;
+
+TEXT PROC subtext (FILE CONST file, INT CONST from) :
+
+ record := subtext ( CONCR (file.f) (file.index).inhalt, from ) ;
+ record
+
+ENDPROC subtext ;
+
+TEXT PROC subtext (FILE CONST file, INT CONST from, to) :
+
+ record := subtext ( CONCR (file.f) (file.index).inhalt, from, to ) ;
+ record
+
+ENDPROC subtext ;
+
+(* sortieren sequentieller Dateien Autor: P.Heyderhoff *)
+ (* Stand: 14.11.80 *)
+
+BOUND DATEI VAR datei;
+INT VAR sortierstelle, sortanker, byte;
+TEXT VAR median, tausch ;
+
+PROC sort (TEXT CONST dateiname) :
+ sortierstelle := feldanfang; sort (dateiname, "")
+ END PROC sort;
+
+PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ sortierstelle := sortieranfang; sort (dateiname, "")
+ END PROC sort;
+
+PROC sort (TEXT CONST dateiname, feldname) :
+ IF exists (dateiname)
+ THEN datei := old (dateiname);
+ IF CONCR(datei) (freianker).nachfolger <> freianker
+ THEN reorganize (dateiname)
+ FI ;
+ sortanker := 3;
+ IF feldname = ""
+ THEN byte := 0
+ ELSE feldname in feldnummer uebersetzen
+ FI;
+ quicksort(sortanker, CONCR(datei)(freianker).fortsetzung-1)
+ FI .
+feldname in feldnummer uebersetzen :
+ byte := pos (CONCR(datei) (sortanker).inhalt, feldname);
+ IF byte > 0
+ THEN byte := pos (CONCR(datei) (sortanker).inhalt, code(255-byte))
+ FI;
+ IF byte = 0
+ THEN errorstop ("sort: feldname"); LEAVE sort
+ FI ; sortanker INCR 1 .
+ END PROC sort;
+
+PROC quicksort ( INT CONST anfang, ende ) :
+ IF anfang < ende
+ THEN INT VAR p,q;
+ spalte (anfang, ende, p, q);
+ quicksort (anfang, q);
+ quicksort (p, ende) FI
+ END PROC quicksort;
+
+PROC spalte (INT CONST anfang, ende, INT VAR p, q):
+ fange an der seite an und waehle den median;
+ ruecke p und q so dicht wie moeglich zusammen;
+ hole ggf median in die mitte .
+
+ fange an der seite an und waehle den median :
+ p := anfang; q := ende ;
+ INT CONST m :: (p + q) DIV 2 ;
+ median := subtext(datei m, merkmal m) .
+
+ ruecke p und q so dicht wie moeglich zusammen :
+ REP schiebe p und q so weit wie moeglich auf bzw ab;
+ IF p < q THEN vertausche die beiden FI
+ UNTIL p > q END REP .
+
+ vertausche die beiden :
+ tausch := datei p; datei p := datei q; datei q := tausch;
+ p INCR 1; q DECR 1 .
+
+ schiebe p und q so weit wie moeglich auf bzw ab :
+ WHILE p kann groesser werden REP p INCR 1 END REP;
+ WHILE q kann kleiner werden REP q DECR 1 END REP .
+
+ p kann groesser werden :
+ IF p <= ende THEN subtext (datei p, merkmal p) <= median ELSE FALSE FI .
+
+ q kann kleiner werden :
+ IF q >= anfang THEN subtext(datei q,merkmal q) >= median ELSE FALSE FI .
+
+ hole ggf median in die mitte :
+ IF m < q THEN vertausche m und q
+ ELIF m > p THEN vertausche m und p FI .
+
+ vertausche m und q :
+ tausch := datei m; datei m := datei q; datei q := tausch; q DECR 1 .
+
+ vertausche m und p :
+ tausch := datei m; datei m := datei p; datei p := tausch; p INCR 1 .
+
+ merkmal m :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei m SUB byte) FI .
+
+ merkmal p :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei p SUB byte) FI .
+
+ merkmal q :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei q SUB byte) FI .
+
+ datei m : CONCR(datei)(m).inhalt .
+ datei p : CONCR(datei)(p).inhalt .
+ datei q : CONCR(datei)(q).inhalt .
+
+END PROC spalte;
+
+
+(*********** schrott ************)
+
+OP := (FILE VAR a, FILE CONST b) :
+ EXTERNAL 294
+ENDOP := ;
+
+PROC becomes (ROW 8 INT VAR a, b) :
+ INTERNAL 294 ;
+ a := b
+ENDPROC becomes ;
+
+PROC datei initialisieren (DATEI VAR datei) :
+ EXTERNAL 290 ;
+END PROC datei initialisieren;
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+ENDPACKET file ;
diff --git a/system/base/unknown/src/init b/system/base/unknown/src/init new file mode 100644 index 0000000..02b8e74 --- /dev/null +++ b/system/base/unknown/src/init @@ -0,0 +1,250 @@ + " Compiler Error : "
+" "
+" |"
+" Fehler entdeckt "
+"Keine Fehler gefunden, "
+" Sekunden CPU-Zeit verbraucht"
+" ******* ENDE DER UEBERSETZUNG *******"
+"FEHLER bei >> "
+" << "
+"weiter bei "
+" (" ") "
+"EOF im Programm"
+"EOF beim Skippen"
+"EOF im TEXT Denoter"
+"EOF im Kommentar"
+"' nach Bold fehlt"
+"das MAIN PACKET muss das letzte sein"
+"ungueltiger Name fuer ein Interface Objekt"
+"':' fehlt"
+"nach ENDPACKET folgt nicht der Paketname"
+"ENDPACKET fehlt"
+"CONST oder VAR fehlt"
+"ungueltiger Name"
+" ',' in Deklarationsliste fehlt"
+"ist nicht der PROC Name"
+"fehlerhaftes Endes des MAIN PACKET"
+"ENDPROC fehlt"
+"PROC/OP Schachtelung unzulaessig"
+"OP darf kein Parameter sein"
+"steht mehrfach im PACKET Interface"
+"Mehrfachdeklaration"
+"ist schon als Datenobjekt deklariert"
+"ist schon als PROC/OP deklariert"
+"')' nach Parameterliste erwartet"
+"Standard-Schluesselwort kann nicht redefiniert werden"
+"ungueltig als BOLD"
+"'(' fehlt"
+"CONST bzw VAR nicht bei Strukturfeldern"
+"'=' fehlt"
+"Schluesselwort wird im Paket schon andersartig verwandt"
+"Dieser Typ ist schon definiert"
+"ungueltiger Deklarierer"
+"ungueltiger OP Name"
+"OP muss monadisch oder dyadisch sein"
+"ist nicht der OP Name"
+"ENDOP fehlt"
+"Name nach ENDPROC fehlt"
+"Name nach ENDOP fehlt"
+"END END ist Unsinn"
+"Diese END... kenne ich nicht"
+"ROW Groesse ist kein INT"
+"ROW Groesse ist kein Denoter"
+"Ein ROW muss mindestens ein Element haben"
+"ROW Groesse fehlt"
+"Parameter kann man nicht initialisieren"
+"Konstanten muessen initialisert werden"
+"'::' verwenden"
+"')' fehlt"
+"Nachkommastellen fehlen"
+"Exponent fehlt"
+"Undefinierter Typ"
+"Rekursiv definierter Typ"
+"Mehrfach definierter Selektor"
+"VARs koennen aus dem Paket nicht herausgereicht werden"
+"NO SHORTHAND DECLARATION IN THIS SCOPE FOR ROW SIZE DENOTER."
+"Typ Deklarationen nur im Paketrumpf"
+"CONST bzw. VAR ohne Zusammenhang"
+"ist nicht deklariert, steht aber in der Paket-Schnittstelle"
+"ist nicht deklariert"
+"Typ ist schon deklariert"
+"THIS IS NO CORRECT EXTERNAL NUMBER."
+" EXTERNAL und INTERNAL unzulaessig"
+"Name erwartet"
+"Denoter erwartet"
+"ENDPROC ohne Zusammenhang"
+"ENDOP ohne Zusammenhang"
+"Refinement ohne Zusammenhang"
+"Delimiter zwischen Paket-Refinement und Deklaration fehlt"
+"unzulaessiges Selektor-Symbol (kein Name)"
+"BOUND Schachtelungen unzulaessig"
+"Textende fehlt"
+
+"Denoter-Wert wird fuer diese Maschine zu gross"
+"NOBODY SHOULD EVER WRITE THAT, Uli ! "
+"ist ein zusammenhangloses Schluesselwort"
+"'::' nur fuer Initialisierungen, sonst ':='"
+"welches Objekt soll verlassen werden?"
+"du bist gar nicht innerhalb dieses Refinements"
+"nur die eigene PROC / OP kann verlassen werden"
+"THEN fehlt"
+"FI fehlt"
+"BOOL - Ausdruck erwartet"
+"ELSE - Teil ist notwendig, da ein Wert geliefert wird"
+"Mit ELIF kann kein IF-Statement beginnen"
+"INT - Ausdruck erwartet"
+"OF fehlt"
+"Keine Typanpassung moeglich"
+"CASE - Label fehlt"
+"CASE - Label ist zu gross (skipped)"
+"mehrfach definiertes CASE-Label"
+"ungueltiges Zeichen nach CASE-Label"
+" OTHERWISE PART fehlt"
+"END SELECT fehlt"
+"DEAR USER, PLEASE BE REMINDED OF NOT CALLING REFINEMENTS RECURSIVLY !"
+"Dieses Refinement wird nicht benutzt"
+"Zwischen diesen Symbolen fehlt ein Operator oder ein ';'"
+"undefinierter monadischer Operator"
+"undefinierter dyadischer Operator"
+"Operator vor '(' fehlt"
+"kann nicht redefiniert werden"
+"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen"
+"fuer diesen Typ nicht definierter Selektor"
+"Primitive Typen koennen nicht selektiert werden"
+"bei ROWs nur Subscription"
+"ungueltiger Selectand"
+"unzulaessiger Index fuer Subscription"
+"'[' ohne Zusammenhang"
+"']' ohne Zusammenhang"
+"']' nach Subscription fehlt"
+"',' ungueltig zwischen UNITs"
+"':' ungueltig zwischen UNITs"
+"';' fehlt"
+"nur die letzte UNIT einer SECTION darf einen Wert liefern"
+"Der Paketrumpf kann keinen Wert liefern"
+"anstelle des letzten Symbols wurde ein Operand erwartet"
+"Der Schleifenrumpf darf keinen Wert liefern"
+"INT VAR erwartet"
+"wird schon in einer aeusseren Schleife als Laufvariable benutzt"
+"FROM erwartet"
+"UPTO bzw DOWNTO fehlt"
+"REPEAT fehlt"
+"END REP fehlt"
+"UNTIL ohne Zusammenhang"
+"Die Konstante darf nicht mit ':=' veraendert werden"
+"In einer FOR-Schleife darf die Laufvariable nicht veraendert werden"
+"falscher Typ des Resultats"
+"ist CONST, es wird aber ein VAR Parameter verlangt"
+"unbekannte Prozedur"
+"Parameter-Prozedur liefert falsches Resultat"
+"Es gibt keine Prozedur mit diesen Parametern"
+"unbekannte Parameter-Prozedur"
+"VIRTUAL PARAM MODE INCONSISTENCE"
+"INCONSISTENCE BETWEEN THE PARAMETERS OF THE ACTUAL AND THE FORMAL PARAM PROC
+EDURE "
+"nicht deklariertes Objekt"
+"THIS OBJECT IS USED OUTSIDE IT'S RANGE"
+"Kein TYPE DISPLAY moeglich, da die Feinstruktur hier unbekannt ist"
+"zu wenig Felder angegeben"
+"zu viele Felder angegeben"
+"unzulaessiger Trenner zwischen Feldern"
+"Dies Feld hat einen falschen Typ"
+"THIS ROW DISPLAY DOES NOT HAVE THE CORRECT NUMBER OF ELEMENTS."
+"Dieser Typ kann nicht noch mehr konkretisiert werden"
+
+"Warnung in Zeile"
+" Zeile "
+"in Zeile "
+"<----+--->"
+" TYPE undefiniert "
+" MODE undefiniert "
+"Parameter spezifiziert "
+"Parameter Typ(en) sind "
+" B Code, "
+" B Paketdaten generiert"
+"Operandentyp"
+"Typ des linken Operanden "
+"Typ des rechten Operanden "
+"erwartet "
+"gefunden "
+ "NULL 1TEST 1NOT 2INCR 1DECR
+ 1MOV2 2MOV8 2MOVS 2EQI 2LSEQI
+ 2EQR 2LSEQR 2COMPLI 2COMPLR 2ADDI
+ 3SUBI 3MULTI 3DIVI 3ADDR 3SUBR
+ 3MULTR 3DIVR 3AND 2OR 2BRANCH
+8BTRUE 8BFALSE 8ACCDS 2ALIAS 5RETURN
+0MOVE 3CASE 3SUBS 5SUBS2 4SUBS8
+ 4SUBS16 4SEL 3BSTL 6ESTL 7HEAD
+ 1PACKET 1BOOL 1NBOOL 1"
+
+(*000 *) END INTERNAL BOUND
+(*001 *) PACKET
+(*002 *) ENDPACKET
+(*003 *) DEFINES
+(*003 A*) LET
+(*004 *) PROCEDURE
+(*005 *) PROC
+(*006 *) ENDPROC
+(*006A *) ENDPROCEDURE
+(*007 *) OPERATOR
+(*008 *) OP
+(*009 *) ENDOP
+(*009A *) ENDOPERATOR
+(*010 *) TYPE
+(*011 *) INT
+(*012 *) REAL
+(*013 *) DATASPACE
+(*015 *) TEXT
+(*016 *) BOOL
+(*017 *) CONST
+(*018 *) VAR
+(* INIT CONTROL *) INTERNAL
+(*019 *) ROW
+(*0191 *) STRUCT CONCR
+(*0193*) ACTUAL
+(*020 *) REP
+(*020A *) REPEAT
+(*021 *) ENDREP
+(*021A *) ENDREPEAT PER
+(*022 *) SELECT
+(*023 *) ENDSELECT
+(*0235 *) EXTERNAL
+(*024 *) IF (*024A *) ENDIF
+(*021 *) THEN
+(*022 *) ELIF
+(*023 *) ELSE
+(*024 *) FI
+(*026 *) OF
+(*026A *) CASE
+(*027 *) OTHERWISE
+(*029 *) FOR
+(*030 *) FROM
+(*031 *) UPTO
+(*032 *) DOWNTO
+(*034 *) UNTIL
+(*035 *) WHILE
+(*036 *) LEAVE WITH
+(*0361 *) TRUE
+(*362 *) FALSE
+(*038 *) :: SBL = := INCR DECR
+(*039 *) + - * / DIV MOD ** AND CAND OR COR NOT <> > >= < <=
+(*040 *) MAIN
+(*043*) ENDOFFILE
+
+PACKET a :
+
+PROC out (TEXT CONST t) :
+ EXTERNAL 60
+ENDPROC out ;
+
+PROC out text (TEXT CONST t, INT CONST typ) :
+ INTERNAL 257 ;
+ out (t)
+ENDPROC out text ;
+
+PROC out line (INT CONST typ) :
+ INTERNAL 258 ;
+ out (""13""10"")
+ENDPROC out line ;
+
+ENDPACKET a ;
diff --git a/system/base/unknown/src/integer b/system/base/unknown/src/integer new file mode 100644 index 0000000..0e1d19d --- /dev/null +++ b/system/base/unknown/src/integer @@ -0,0 +1,134 @@ +
+PACKET integer DEFINES
+ sign, SIGN, abs, ABS, **, min, max, maxint,
+ get, random, initialize random :
+
+INT PROC maxint : 32767 ENDPROC maxint ;
+
+INT PROC sign (INT CONST argument) :
+
+ IF argument < 0 THEN -1
+ ELIF argument > 0 THEN 1
+ ELSE 0
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (INT CONST argument) :
+ sign (argument)
+ENDOP SIGN ;
+
+INT PROC abs (INT CONST argument) :
+
+ IF argument > 0 THEN argument
+ ELSE - argument
+ FI
+
+ENDPROC abs ;
+
+INT OP ABS (INT CONST argument) :
+ abs (argument)
+ENDOP ABS ;
+
+INT OP ** (INT CONST arg, exp) :
+
+ INT VAR x := arg , z := 1 ,
+ counter := exp ;
+
+ IF exp < 0 THEN errorstop ("INT OP ** : negative exponent") FI ;
+ IF arg = 0 AND exp = 0
+ THEN errorstop (" 0 ** 0 is not defined")
+ FI ;
+ IF exp = 0 THEN x := 1 FI ;
+
+ WHILE counter >= 2 REP
+ calculate new x and z ;
+ counter := counter DIV 2 ;
+ ENDREP ;
+ z * x .
+
+calculate new x and z :
+ IF counter is not even
+ THEN z := z * x
+ FI ;
+ x := x * x .
+
+counter is not even :
+ counter MOD 2 = 1 .
+
+ENDOP ** ;
+
+INT PROC min (INT CONST first, second) :
+
+ IF first < second THEN first ELSE second FI
+
+ENDPROC min ;
+
+INT PROC max (INT CONST first, second) :
+
+ IF first > second THEN first ELSE second FI
+
+ENDPROC max ;
+
+
+PROC get (INT VAR number) :
+
+ get (word) ;
+ number := int (word)
+
+ENDPROC get ;
+
+TEXT VAR word := "" ;
+
+
+
+(************************************************)
+(*** ***)
+(*** generator 32 650 ***)
+(*** ***)
+(************************************************)
+
+(* INT-Zufallsgenerator mit Periode 32650 *) (*Autor: Bake *)
+ (*Gymnasium Aspe *)
+
+INT VAR z1 :: 14, (* fuer den generator mit periode 25 *)
+ z2 :: 345; (* fuer den generator mit periode 1306 *)
+
+
+ INT PROCEDURE random (INT CONST ugrenze, ogrenze) :
+ (*******************************************************)
+
+generator 25;
+generator 1306;
+(zufallszahl MOD intervallgroesse) + ugrenze.
+
+(* Durch MOD wird bei grosser 'intervallgroesse' der vordere
+ Bereich doppelt ueberdeckt, also keine Gleichverteilung. heinrichs
+ 24.04.81 *)
+
+
+ generator 25 :
+z1 := (11 * z1 + 18) MOD 25
+(* erster generator. liefert alle zahlen zwischen 0 und 24. *).
+
+ generator 1306 :
+z2 := (24 * z2 + 23) MOD 1307
+(* zweiter generator. liefert alle zahlen zwischen 0 und 1305. *).
+
+ zufallszahl :
+z1 + z2 * 25 (* diese zahl liegt zwischen 0 und 32 649 *).
+
+ intervallgroesse : ogrenze - ugrenze + 1
+
+END PROC random ;
+
+
+ PROCEDURE initialize random (INT CONST wert) :
+(**************************************************)
+
+z1 := wert MOD 25;
+z2 := wert MOD 1306
+
+END PROC initialize random ;
+
+ENDPACKET integer ;
diff --git a/system/base/unknown/src/mathlib b/system/base/unknown/src/mathlib new file mode 100644 index 0000000..be44ff6 --- /dev/null +++ b/system/base/unknown/src/mathlib @@ -0,0 +1,359 @@ +
+PACKET mathlib DEFINES sqrt,**,exp,ln,log2,log10,sin,cos,
+ tan,arctan,sind,cosd,tand,arctand,e,pi,
+ random,initializerandom :
+
+
+REAL VAR rdg::0.4711;
+
+REAL PROC pi:
+ 3.141592653589793.
+END PROC pi;
+
+REAL PROC e:
+ 2.718281828459045.
+END PROC e;
+
+REAL PROC ln(REAL CONST x):
+LET ln2= 0.6931471805599453;
+log2(x)*ln2.
+END PROC ln;
+
+REAL PROC log2(REAL CONST z):
+INT VAR k::0,p::0;
+REAL VAR m::0.0,x::z,t::0.0,summe::0.0;
+IF x>0.0
+THEN normal
+ELSE errorstop("log2 mit negativer zahl");4711.4711
+FI.
+normal:
+ IF x>=0.5
+ THEN normalise downwards
+ ELSE normalise upwards
+ FI;
+ IF x>=0.1 AND x< 0.7071067811865475 THEN
+ t:=(x-0.5946035575013605)/(x+0.5946035575013605);
+ summe:=reihenentwicklung (t) - 0.75
+ FI;
+ IF x>=0.7071067811865475 AND x < 1.0 THEN
+ t:=(x - 0.8408964152537145)/(x+0.8408964152537145);
+ summe:= reihenentwicklung(t)-0.25
+ FI;
+ summe-real(p - 4*k).
+
+ normalise downwards:
+ WHILE x>= 16.0 REP
+ x:=x/16.0;k:=k+1;
+ END REP;
+ WHILE x>=0.5 REP
+ x:=x/2.0;p:=p-1;
+ END REP.
+
+ normalise upwards:
+ WHILE x<=0.0625 REP
+ x:=x*16.0;k:=k-1;
+ END REP;
+ WHILE x<= 0.5 REP
+ x:=x*2.0;p:=p+1;
+ END REP.
+
+END PROC log2;
+
+REAL PROC reihenentwicklung(REAL CONST x):
+ REAL VAR i::39.0,s::1.0/39.0;
+ LET ln2=0.6931471805599453;
+ WHILE i>1.0 REP
+ i:=i-2.0;s:=s*x*x + 1.0/i;
+ END REP;
+ s*2.0*x/ln2.
+END PROC reihenentwicklung;
+
+REAL PROC log10(REAL CONST x):
+ LET lg2=0.301029995664;
+ log2(x)*lg2.
+END PROC log10;
+
+REAL PROC sqrt(REAL CONST z):
+ REAL VAR y0,y1,x::z;
+ INT VAR p::0;
+ BOOL VAR q::FALSE;
+ IF x<0.0
+ THEN errorstop("sqrt von negativer zahl");0.0
+ ELSE correct
+ FI.
+
+ correct:
+ IF x=0.0
+ THEN 0.0
+ ELSE nontrivial
+ FI.
+
+ nontrivial:
+ IF x<0.01
+ THEN small
+ ELSE notsmall
+ FI.
+
+
+ notsmall:
+ IF x>1.0
+ THEN big
+ ELSE normal
+ FI.
+
+ small:
+ WHILE x<0.01 REP
+ p:=p-1;x:=x*100.0;
+ END REP;
+ normal.
+
+ big:
+ WHILE x>=1.0 REP
+ p:=p+1;x:=x/100.0;
+ END REP;
+ normal.
+
+ normal:
+ IF x<0.1
+ THEN x:=x*10.0;q:=TRUE
+ FI;
+ y0:=10.0**p*(1.681595-1.288973/(0.8408065+x));
+ IF q
+ THEN y0:=y0/3.162278
+ FI;
+ y1:=(y0+z/y0)/2.0;
+ y0:=(y1+z/y1)/2.0;
+ y1:=(y0+z/y0)/2.0;
+ (y1-z/y1)/2.0+z/y1.
+
+END PROC sqrt;
+
+REAL PROC exp(REAL CONST z):
+ REAL VAR c,d,x::z, a, b ;
+ IF x<-180.2187
+ THEN 0.0
+ ELIF x<0.0
+ THEN 1.0/exp(-x)
+ ELIF x=0.0
+ THEN 1.0
+ ELSE x:=x/0.6931471805599453;approx
+ FI.
+
+ approx:
+ a:=floor(x/4.0)+1.0;
+ b:=floor(4.0*a-x);
+ c:=(4.0*a-b-x)*16.0;
+ d:=(c -floor(c))/16.0;
+ d:=d*0.6931471805599453;
+ ( (16.0 POWER a) / (2.0 POWER b) / (1.044273782427419 POWER c ))*
+ ((((((0.135910788320380e-2*d-0.8331563191293753e-2)*d
+ +0.4166661437490328e-1)*d-0.1666666658727157)*d+0.4999999999942539)*d
+ - 0.9999999999999844)*d+1.0).
+
+ENDPROC exp ;
+
+REAL OP POWER (REAL CONST basis, exponent) :
+
+ IF floor (exponent) = 0.0
+ THEN 1.0
+ ELSE power
+ FI .
+
+power :
+ REAL VAR counter := floor (abs (exponent)) - 1.0 ,
+ result := basis ;
+ WHILE counter > 0.0 REP
+ result := result * basis ;
+ counter := counter - 1.0
+ PER ;
+ IF exponent > 0.0
+ THEN result
+ ELSE 1.0 / result
+ FI .
+
+ENDOP POWER ;
+
+REAL PROC tan (REAL CONST x):
+ REAL VAR p;
+ p:=1.273239544735168*ABSx;
+ tg(p)*sign(x).
+END PROC tan;
+
+REAL PROC tand(REAL CONST x):
+ REAL VAR p;
+ p:=0.02222222222222222*ABSx;
+ tg(p)*sign(x).
+END PROC tand;
+
+REAL PROC tg(REAL CONST x):
+ REAL VAR r,s,u,q;
+ q:=floor(x);r:=x-q;
+ IF q = floor(q/2.0) * 2.0
+ THEN s:=r
+ ELSE s:=(1.0-r)
+ FI;
+ q:= q - floor(q/4.0) * 4.0 ;
+ u:=s*s;
+ s:=s*0.785398163397448;
+ s:=s/(((((((((-0.4018243865271481e-10*u-0.4404768172667185e-9)*u-
+ 0.748183650813680e-8)*u-0.119216115119129e-6)*u-0.1909255769212821e-5)*u-
+0.3064200638849133e-4)*u-0.4967495424202482e-3)*u-0.8455650263333471e-2)*u-
+ 0.2056167583560294)*u+1.0);
+ IF q=0.0
+ THEN s
+ ELIF q=3.0
+ THEN -s
+ ELIF q=1.0
+ THEN 1.0/s
+ ELSE -1.0/s
+ FI .
+
+END PROC tg;
+
+REAL PROC sin(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x*1.273239544735168;
+ q:=int(y);
+ r:=y-real(q);
+ IF x<0.0
+ THEN q:=q+4
+ FI;
+ sincos(q,r).
+END PROC sin;
+
+REAL PROC sind(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABSx/45.0;
+ q:=int(y);
+ r:=y-real(q);
+ IF x<0.0
+ THEN q:=q+4
+ FI;
+ sincos(q,r).
+END PROC sind;
+
+
+REAL PROC cos(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x*1.273239544735168;
+ q:=int(y);
+ r:=y-real(q);
+ q:=q+2;
+ sincos(q,r).
+END PROC cos;
+
+REAL PROC cosd(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x/45.0;
+ q:=int(y);
+ r:=y-real(q);
+ q:=q+2;
+ sincos(q,r).
+END PROC cosd;
+
+
+REAL PROC sincos(INT VAR q,REAL VAR r):
+ SELECT q MOD 8 + 1 OF
+ CASE 1 : sin approx(r)
+ CASE 2 : cos approx (1.0-r)
+ CASE 3 : cos approx(r)
+ CASE 4 : sin approx(1.0-r)
+ CASE 5 : - sin approx(r)
+ CASE 6 : - cos approx(1.0-r)
+ CASE 7 : - cos approx(r)
+ CASE 8 : - sin approx(1.0-r)
+ OTHERWISE 0.0
+ END SELECT
+END PROC sincos;
+
+REAL PROC sin approx(REAL CONST x):
+ REAL VAR z::x*x;
+ x*((((((0.6877101540593035e-11*z-0.1757149296873372e-8)*z+0.313361621667256
+8
+e-6)*z-0.3657620415845891e-4)*z+0.2490394570188737e-2)*z-0.807455121882e-1
+)*z+0.7853981633974483).
+END PROC sin approx;
+
+REAL PROC cos approx(REAL CONST x):
+ REAL VAR z::x*x;
+ (((((( -0.3857761864560276e-12*z+0.115004970178141e-9)*z-0.246113638267419e
+-7)*z+0.3590860445885748e-5)*z-0.3259918869266875e-3)*z+0.1585434424381541e-1
+)*z-0.3084251375340425)*z+1.0.
+END PROC cos approx;
+
+REAL PROC arctan(REAL CONST x):
+REAL VAR z::x*x;
+IF x<0.0 THEN -arctan(-x)
+ELIF x>1.0 THEN 3.141592653589792/2.0-arctan(1.0/x)
+ELIF x*1.0e16>2.67949192431e15 THEN pi/6.0+arctan(1.732050807568877-4.0
+/(x+1.732050807568877))
+ELSE x/(((((((0.0107090276046822*z-0.01647757182108040)*z
+ +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z
+ -0.0888888888888888)*z+0.3333333333333333)*z+1.0)FI.
+END PROC arctan;
+
+REAL PROC arctand(REAL CONST x):
+ arctan(x)/3.1415926589793*180.0.
+END PROC arctand;
+
+
+BOOL PROC even(INT CONST number):
+ (number DIV 2)*2=number.
+END PROC even;
+
+REAL OP **(REAL CONST base,exponent):
+ IF base<0.0
+ THEN errorstop("hoch mit negativer basis")
+ FI;
+ IF base=0.0
+ THEN test exponent
+ ELSE
+ exp(exponent*ln(base))
+ FI.
+
+ test exponent:
+ IF exponent=0.0
+ THEN errorstop("0**0 geht nicht");4711.4711
+ ELSE 0.0
+ FI.
+
+END OP **;
+
+
+REAL PROC sign(REAL CONST number):
+ IF number >0.0 THEN 1.0
+ ELIF number <0.0 THEN -1.0
+ ELSE 0.0
+ FI.
+END PROC sign ;
+
+REAL OP **(REAL CONST a,INT CONST b):
+REAL VAR p::1.0,r::a;INT VAR n::ABS b;
+WHILE n>0 REP
+ IF n MOD 2=0
+ THEN n:=n DIV 2;r:=r*r
+ ELSE n DECR 1;p:=p*r
+ FI;
+END REP;
+IF b>0
+THEN p
+ELSE 1.0/p
+FI.
+END OP **;
+
+
+
+REAL PROC random:
+rdg:=rdg+pi;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg.
+END PROC random;
+
+
+PROC initializerandom(REAL CONST z):
+ rdg:=z;
+END PROC initializerandom;
+
+END PACKET mathlib;
diff --git a/system/base/unknown/src/real b/system/base/unknown/src/real new file mode 100644 index 0000000..a2ab9c3 --- /dev/null +++ b/system/base/unknown/src/real @@ -0,0 +1,378 @@ +
+PACKET real DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.04.80 *)
+ text ,
+ int ,
+ real ,
+ round ,
+ floor ,
+ frac ,
+ INCR ,
+ DECR ,
+ abs ,
+ ABS ,
+ sign ,
+ SIGN ,
+ MOD ,
+ min ,
+ max ,
+ put ,
+ get ,
+ max real ,
+ small real :
+
+LET mantissa length = 13 ;
+
+TEXT VAR mantissa ;
+
+ROW 10 REAL VAR real digit ;
+
+INT VAR i ; REAL VAR d := 0.0 ;
+FOR i FROM 1 UPTO 10 REP
+ real digit (i) := d ;
+ d := d + 1.0
+PER ;
+
+REAL PROC max real : 9.999999999999e126 ENDPROC max real ;
+
+REAL PROC small real : 1.0e-12 ENDPROC small real ;
+
+PROC sld (INT CONST in, REAL VAR real, INT VAR out) :
+ EXTERNAL 96
+ENDPROC sld ;
+
+INT PROC decimal exponent (REAL CONST mantissa) :
+ EXTERNAL 97
+ENDPROC decimal exponent ;
+
+PROC set exp (INT CONST exponent, REAL VAR number) :
+ EXTERNAL 98
+ENDPROC set exp ;
+
+REAL PROC tenpower (INT CONST exponent) :
+ REAL VAR result := 1.0 ;
+ set exp (exponent, result) ;
+ result
+ENDPROC tenpower ;
+
+REAL PROC floor (REAL CONST real) :
+ EXTERNAL 99
+ENDPROC floor ;
+
+REAL PROC round (REAL CONST real, INT CONST digits) :
+
+ REAL VAR result := real ;
+ IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length)
+ THEN round result ;
+ FI ;
+ result .
+
+round result :
+ set exp (decimal exponent (result) + digits, result) ;
+ IF result >= 0.0
+ THEN result := floor (result + 0.5)
+ ELSE result := floor (result - 0.5)
+ FI ;
+ set exp (decimal exponent (result) - digits, result) .
+
+ENDPROC round ;
+
+TEXT VAR result ;
+
+TEXT PROC text (REAL CONST real) :
+
+ REAL VAR value := rounded to seven digits ;
+ IF value = 0.0
+ THEN "0.0"
+ ELSE
+ process sign ;
+ get mantissa (value) ;
+ INT CONST exponent := decimal exponent (value) ;
+ get short mantissa ;
+ IF exponent > 7 OR exponent < LENGTH short mantissa - 7
+ THEN scientific notation
+ ELSE short notation
+ FI
+ FI .
+
+rounded to seven digits :
+ round ( real * tenpower( -decimal exponent(real) ) , 6 )
+ * tenpower ( decimal exponent(real) ) .
+
+process sign :
+ IF value < 0.0
+ THEN result := "-" ;
+ value := - value
+ ELSE result := ""
+ FI .
+
+get short mantissa :
+ INT VAR i := 7 ;
+ WHILE (mantissa SUB i) = "0" REP
+ i DECR 1
+ UNTIL i=1 END REP ;
+ TEXT CONST short mantissa := subtext (mantissa, 1, i) .
+
+scientific notation :
+ result CAT (mantissa SUB 1) ;
+ result CAT "." ;
+ result CAT subtext (mantissa, 2, 7) ;
+ result + "e" + text (exponent) .
+
+short notation :
+ result CAT subtext (short mantissa, 1, exponent+1) ;
+ result CAT (exponent+1 - LENGTH short mantissa) * "0" ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result + (-exponent-1) * "0" + short mantissa
+ ELSE result + subtext (short mantissa, exponent+2)
+ FI .
+
+ENDPROC text ;
+
+PROC get mantissa (REAL CONST number) :
+
+ REAL VAR real mantissa := number ;
+ mantissa := "" ;
+ INT VAR i , digit ;
+ FOR i FROM 1 UPTO mantissa length REP
+ sld (0, real mantissa, digit) ;
+ mantissa CAT code (digit + 48)
+ PER ;
+
+ENDPROC get mantissa ;
+
+PROC put (REAL CONST real) :
+
+ put (text (real) )
+
+ENDPROC put ;
+
+TEXT PROC text (REAL CONST real, INT CONST length, fracs) :
+
+ REAL VAR value := round (real, fracs) ;
+ INT VAR exponent := decimal exponent (value) ;
+ IF value = 0.0 THEN exponent := 0 FI ;
+ INT VAR floors := exponent + 1 ,
+ floor length := length - fracs - 1 ;
+ IF value < 0.0 THEN floor length DECR 1 FI ;
+
+ IF value too big
+ THEN length * "*"
+ ELSE transformed value
+ FI .
+
+transformed value :
+ process leading blanks and sign ;
+ get mantissa (value) ;
+ result CAT subtext (mantissa, 1, floors) ;
+ IF LENGTH mantissa < floors
+ THEN result CAT (floors - LENGTH mantissa) * "0"
+ FI ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result CAT (-floors) * "0" ;
+ result CAT subtext (mantissa, 1, length - LENGTH result)
+ ELSE result CAT subtext (mantissa, floors+1, floors + fracs)
+ FI ;
+ IF LENGTH result < length
+ THEN result CAT (length - LENGTH result) * "0"
+ FI ;
+ result .
+
+process leading blanks and sign :
+ result := (floor length - max(floors,0)) * " " ;
+ IF value < 0.0
+ THEN result CAT "-" ;
+ value := - value
+ FI .
+
+value too big :
+ floors > floor length .
+
+ENDPROC text ;
+
+REAL PROC real (TEXT CONST text) :
+
+ skip leading blanks ;
+ sign ;
+ mantissa part ;
+ exponent ;
+ check correct conversion ;
+ result .
+
+skip leading blanks :
+ INT VAR pos := 1 ;
+ skip blanks .
+
+skip blanks :
+ WHILE (text SUB pos) = " " REP
+ pos INCR 1
+ PER .
+
+sign :
+ BOOL VAR negative ;
+ IF (text SUB pos) = "-"
+ THEN negative := TRUE ;
+ pos INCR 1
+ ELIF (text SUB pos) = "+"
+ THEN negative := FALSE ;
+ pos INCR 1
+ ELSE negative := FALSE
+ FI .
+
+mantissa part:
+ REAL VAR value := 0.0 ;
+ INT VAR exponent pos := 0 ;
+ WHILE pos <= LENGTH text REP
+ TEXT VAR digit := text SUB pos ;
+ IF digit <= "9" AND digit >= "0"
+ THEN value := value * 10.0 + real digit (code (digit) - 47) ;
+ pos INCR 1
+ ELIF digit = "."
+ THEN pos INCR 1 ;
+ exponent pos := pos
+ ELSE LEAVE mantissa part
+ FI
+ END REP .
+
+exponent :
+ INT VAR exp ;
+ IF exponent pos > 0
+ THEN exp := exponent pos - pos
+ ELSE exp := 0
+ FI ;
+ IF (text SUB pos) = "e"
+ THEN exp INCR int (subtext(text,pos+1))
+ FI .
+
+check correct conversion :
+ skip blanks ;
+ IF pos > LENGTH text
+ THEN set conversion (TRUE)
+ ELSE set conversion (FALSE)
+ FI .
+
+result :
+ value := value * tenpower (exp) ;
+ IF negative
+ THEN - value
+ ELSE value
+ FI .
+
+ENDPROC real ;
+
+TEXT VAR word ;
+
+PROC get (REAL VAR value) :
+
+ get (word) ;
+ value := real (word)
+
+ENDPROC get ;
+
+REAL PROC abs (REAL CONST value) :
+
+ IF value >= 0.0
+ THEN value
+ ELSE -value
+ FI
+
+ENDPROC abs ;
+
+REAL OP ABS (REAL CONST value) :
+
+ abs (value)
+
+ENDOP ABS ;
+
+INT PROC sign (REAL CONST value) :
+
+ IF value < 0.0 THEN -1
+ ELIF value = 0.0 THEN 0
+ ELSE 1
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (REAL CONST value) :
+
+ sign (value)
+
+ENDOP SIGN ;
+
+REAL OP MOD (REAL CONST left, right) :
+
+ REAL VAR result := left - floor (left/right) * right ;
+ IF left < 0.0
+ THEN result + abs (right)
+ ELSE result
+ FI
+
+ENDOP MOD ;
+
+REAL PROC frac (REAL CONST value) :
+
+ value - floor (value)
+
+ENDPROC frac ;
+
+REAL PROC max (REAL CONST a, b) :
+
+ IF a > b THEN a ELSE b FI
+
+ENDPROC max ;
+
+REAL PROC min (REAL CONST a, b) :
+
+ IF a < b THEN a ELSE b FI
+
+ENDPROC min ;
+
+OP INCR (REAL VAR dest, REAL CONST increment) :
+
+ dest := dest + increment
+
+ENDOP INCR ;
+
+OP DECR (REAL VAR dest, REAL CONST decrement) :
+
+ dest := dest - decrement
+
+ENDOP DECR ;
+
+INT PROC int (REAL CONST value) :
+
+ INT VAR result := 0, digit ,i ;
+ REAL VAR mantissa := value ;
+
+ FOR i FROM 0 UPTO decimal exponent (value) REP
+ sld (0, mantissa, digit) ;
+ result := result * 10 + digit
+ PER ;
+
+ IF value < 0.0
+ THEN - result
+ ELSE result
+ FI
+
+ENDPROC int ;
+
+REAL PROC real (INT CONST value) :
+
+ IF value < 0
+ THEN - real (-value)
+ ELIF value < 10
+ THEN real digit (value+1)
+ ELSE split value into head and last digit ;
+ real (head) * 10.0 + real digit (last digit+1)
+ FI .
+
+split value into head and last digit :
+ INT CONST
+ head := value DIV 10 ,
+ last digit := value - head * 10 .
+
+ENDPROC real ;
+
+ENDPACKET real ;
diff --git a/system/base/unknown/src/scanner b/system/base/unknown/src/scanner new file mode 100644 index 0000000..ed04699 --- /dev/null +++ b/system/base/unknown/src/scanner @@ -0,0 +1,255 @@ +
+PACKET scanner DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.12.81 *)
+ scan ,
+ continue scan ,
+ next symbol ,
+ fix scanner ,
+ reset scanner :
+
+
+LET tag = 1 ,
+ bold = 2 ,
+ integer = 3 ,
+ text = 4 ,
+ operator= 5 ,
+ delimiter = 6 ,
+ end of file = 7 ,
+ within comment = 8 ,
+ within text = 9 ;
+
+
+TEXT VAR line := "" ,
+ char := "" ;
+
+INT VAR position := 0 ,
+ reset position ,
+ comment depth ;
+BOOL VAR continue text ;
+
+
+PROC scan (TEXT CONST scan text) :
+
+ comment depth := 0 ;
+ continue text := FALSE ;
+ continue scan (scan text)
+
+ENDPROC scan ;
+
+PROC continue scan (TEXT CONST scan text) :
+
+ line := scan text ;
+ position := 0 ;
+ next non blank char ;
+ reset position := position
+
+ENDPROC continue scan ;
+
+PROC fix scanner :
+
+ reset position := position
+
+ENDPROC fix scanner ;
+
+PROC reset scanner :
+
+ position := reset position ;
+ char := line SUB position
+
+ENDPROC reset scanner ;
+
+PROC next symbol (TEXT VAR symbol) :
+
+ INT VAR type ;
+ next symbol (symbol, type)
+
+ENDPROC next symbol ;
+
+PROC next symbol (TEXT VAR symbol, INT VAR type) :
+
+ skip blanks ;
+ symbol := "" ;
+ IF is niltext THEN eof
+ ELIF is comment THEN process comment
+ ELIF is text THEN process text
+ ELIF is lower case letter THEN process tag
+ ELIF is upper case letter THEN process bold
+ ELIF is digit THEN process integer
+ ELIF is delimiter THEN process delimiter
+ ELSE process operator
+ FI .
+
+skip blanks :
+ IF char = " "
+ THEN next non blank char
+ FI .
+
+
+process comment :
+ read comment ;
+ IF comment depth = 0
+ THEN next symbol (symbol, type)
+ ELSE type := within comment
+ FI .
+
+process tag :
+ type := tag ;
+ REP
+ symbol CAT char ;
+ next non blank char
+ UNTIL NOT (is lower case letter OR is digit) ENDREP .
+
+process bold :
+ type := bold ;
+ REP
+ symbol CAT char ;
+ next char
+ UNTIL NOT is upper case letter ENDREP .
+
+process integer :
+ type := integer ;
+ REP
+ symbol CAT char ;
+ next non blank char
+ UNTIL NOT (is digit OR char = ".") ENDREP .
+
+process text :
+ type := text ;
+ IF continue text
+ THEN continue text := FALSE
+ ELSE next char
+ FI ;
+ WHILE not end of text REP
+ symbol CAT char ;
+ next char
+ ENDREP .
+
+not end of text :
+ IF is niltext
+ THEN continue text := TRUE ; type := within text ; FALSE
+ ELIF is quote
+ THEN end of text or exception
+ ELSE TRUE
+ FI .
+
+end of text or exception :
+ next char ;
+ IF is quote
+ THEN TRUE
+ ELIF is digit
+ THEN get special char ; TRUE
+ ELSE FALSE
+ FI .
+
+get special char :
+ TEXT VAR special symbol ;
+ next symbol (special symbol) ;
+ char := code ( int (special symbol ) ) .
+
+process delimiter :
+ type := delimiter ;
+ symbol := char ;
+ next non blank char .
+
+process operator :
+ type := operator ;
+ symbol := char ;
+ nextchar ;
+ IF symbol = ":"
+ THEN IF char = "=" OR char = ":"
+ THEN symbol := ":=" ;
+ nextchar
+ ELSE type := delimiter
+ FI
+ ELIF is relational double char
+ THEN symbol CAT char ;
+ nextchar
+ ELIF symbol = "*" AND char = "*"
+ THEN symbol := "**" ;
+ next char
+ FI .
+
+eof :
+ type := end of file ;
+ symbol := "" .
+
+is lower case letter : char lies in (97, 122) .
+
+is upper case letter : char lies in (65, 90) .
+
+is digit : char lies in (48, 57) .
+
+is delimiter : pos ( "()[].,;" , char ) > 0 AND char <> "" .
+
+is relational double char :
+ TEXT VAR double := symbol + char ;
+ double = "<>" OR double = "<=" OR double = ">=" .
+
+is text : is quote OR continue text .
+
+is quote : char = """" .
+
+is niltext : char = "" .
+
+is comment :
+ IF comment depth = 0
+ THEN char = "{" OR char = "(" AND ahead char = "*"
+ ELSE comment depth DECR 1 ; TRUE
+ FI .
+
+ENDPROC next symbol ;
+
+PROC next char :
+
+ position INCR 1 ;
+ char := line SUB position
+
+ENDPROC next char ;
+
+PROC next non blank char :
+
+ REP
+ position INCR 1
+ UNTIL (line SUB position) <> " " ENDREP ;
+ char := line SUB position
+
+ENDPROC next non blank char ;
+
+TEXT PROC ahead char :
+
+ line SUB position+1
+
+ENDPROC ahead char ;
+
+BOOL PROC char lies in (INT CONST lower bound, upper bound) :
+
+ lower bound <= code(char) AND code(char) <= upper bound
+
+ENDPROC char lies in ;
+
+PROC read comment :
+
+ TEXT VAR last char ;
+ comment depth INCR 1 ;
+ REP
+ last char := char ;
+ nextchar ;
+ IF is begin comment
+ THEN read comment
+ FI ;
+ IF char = ""
+ THEN LEAVE read comment
+ FI
+ UNTIL is end comment PER ;
+ comment depth DECR 1 ;
+ next nonblank char .
+
+is end comment :
+ char = "}" OR char = ")" AND last char = "*" .
+
+is begin comment :
+ char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC read comment ;
+
+ENDPACKET scanner ;
diff --git a/system/base/unknown/src/stdescapeset b/system/base/unknown/src/stdescapeset new file mode 100644 index 0000000..0c69ea7 --- /dev/null +++ b/system/base/unknown/src/stdescapeset @@ -0,0 +1,31 @@ +PACKET std escape set (* Autor: P.Heyderhoff *)
+ (************) (* Stand: 20.01.1981 *)
+ (* Vers.: 1.5.5 *)
+DEFINES std escape set :
+
+PROC std escape set :
+
+ define escape ("p", "IFmark>0THEN PUT"""";W""""12""""FI") ;
+ define escape ("g", "GET"""";M0") ;
+ define escape ("d", "IFmark>0THEN PUT"""";M0ELSE GET"""";M0FI");
+ define escape ("B", "W""""194""""") ;
+ define escape ("A", "W""""193""""") ;
+ define escape ("O", "W""""207""""") ;
+ define escape ("U", "W""""213""""") ;
+ define escape ("a", "W""""225""""") ;
+ define escape ("o", "W""""239""""") ;
+ define escape ("u", "W""""245""""") ;
+ define escape ("z", "C1;""""C(((limit-len)/2)*"" "")") ;
+ define escape ("l", "i:=col;C1;M1;Ci;W""""12""""") ;
+ define escape ("h", "S11") ;
+ define escape ("v", "S23") ;
+ define escape ("1", "1;C1");
+ define escape ("9", "9999;C(len+1)");
+ define escape (""2"", """ """);
+ define escape (""10"","+1;R Clen;"" ""Ucol>lenE");
+ define escape (""3"", "R-1;Hrow;Clen;"" ""Ucol>lenE");
+ define escape (""8"", "COL(col-10)");
+
+ENDPROC std escape set ;
+
+ENDPACKET std escape set ;
|