summaryrefslogtreecommitdiff
path: root/system/base
diff options
context:
space:
mode:
Diffstat (limited to 'system/base')
-rw-r--r--system/base/1.7.5/source-disk1
-rw-r--r--system/base/1.7.5/src/advertising35
-rw-r--r--system/base/1.7.5/src/basic transput177
-rw-r--r--system/base/1.7.5/src/bits78
-rw-r--r--system/base/1.7.5/src/bool16
-rw-r--r--system/base/1.7.5/src/command dialogue123
-rw-r--r--system/base/1.7.5/src/command handler290
-rw-r--r--system/base/1.7.5/src/dataspace74
-rw-r--r--system/base/1.7.5/src/date handling303
-rw-r--r--system/base/1.7.5/src/editor2959
-rw-r--r--system/base/1.7.5/src/elan do interface57
-rw-r--r--system/base/1.7.5/src/error handling142
-rw-r--r--system/base/1.7.5/src/eumel coder part 1866
-rw-r--r--system/base/1.7.5/src/file2122
-rw-r--r--system/base/1.7.5/src/functions760
-rw-r--r--system/base/1.7.5/src/init251
-rw-r--r--system/base/1.7.5/src/integer265
-rw-r--r--system/base/1.7.5/src/local manager373
-rw-r--r--system/base/1.7.5/src/local manager 241
-rw-r--r--system/base/1.7.5/src/mathlib268
-rw-r--r--system/base/1.7.5/src/pattern match768
-rw-r--r--system/base/1.7.5/src/pcb control79
-rw-r--r--system/base/1.7.5/src/real442
-rw-r--r--system/base/1.7.5/src/scanner325
-rw-r--r--system/base/1.7.5/src/screen33
-rw-r--r--system/base/1.7.5/src/std transput264
-rw-r--r--system/base/1.7.5/src/tasten113
-rw-r--r--system/base/1.7.5/src/text391
-rw-r--r--system/base/1.7.5/src/texter errors284
-rw-r--r--system/base/1.7.5/src/thesaurus332
30 files changed, 12232 insertions, 0 deletions
diff --git a/system/base/1.7.5/source-disk b/system/base/1.7.5/source-disk
new file mode 100644
index 0000000..5708023
--- /dev/null
+++ b/system/base/1.7.5/source-disk
@@ -0,0 +1 @@
+175_src/source-code-1.7.5.img
diff --git a/system/base/1.7.5/src/advertising b/system/base/1.7.5/src/advertising
new file mode 100644
index 0000000..45f73ef
--- /dev/null
+++ b/system/base/1.7.5/src/advertising
@@ -0,0 +1,35 @@
+(* ------------------- VERSION 1 06.03.86 ------------------- *)
+PACKET advertising DEFINES (* Autor: J.Liedtke *)
+
+ eumel must advertise :
+
+
+LET myself id field = 9 ;
+
+
+PROC eumel must advertise :
+
+ IF online AND channel <= 15
+ THEN out (""1""4"") ;
+ IF station is not zero
+ THEN out (""15"Station: ") ;
+ out (text (station number)) ;
+ out (" "14"")
+ FI ;
+ cursor (60,1) ;
+ out (""15"Terminal: ") ;
+ out (text (channel)) ;
+ out (" "14"") ;
+ cursor (22,5) ;
+ (* out ("E U M E L Pilot-Version /M"13""10""10""10"") *)
+ out ("E U M E L Version 1.7.5.10 /M+ "13""10""10""10"")
+ FI .
+
+station is not zero : pcb (myself id field) >= 256 .
+
+station number : pcb (myself id field) DIV 256 .
+
+ENDPROC eumel must advertise ;
+
+ENDPACKET advertising ;
+
diff --git a/system/base/1.7.5/src/basic transput b/system/base/1.7.5/src/basic transput
new file mode 100644
index 0000000..5608bb1
--- /dev/null
+++ b/system/base/1.7.5/src/basic transput
@@ -0,0 +1,177 @@
+
+PACKET basic transput DEFINES
+ out ,
+ outsubtext ,
+ outtext ,
+ TIMESOUT ,
+ cout ,
+ display ,
+ inchar ,
+ incharety ,
+ cat input ,
+ pause ,
+ cursor ,
+ get cursor ,
+ channel ,
+ online ,
+ control ,
+ blockout ,
+ blockin :
+
+
+
+LET channel field = 4 ,
+ blank times 64 =
+ " " ;
+
+LET BLOCKIO = STRUCT (ALIGN page align, ROW 256 INT buffer) ,
+ buffer page = 2 ;
+
+BOUND BLOCKIO VAR block io ;
+DATASPACE VAR block io ds ;
+INITFLAG VAR this packet := FALSE ;
+
+
+PROC out (TEXT CONST text ) :
+ EXTERNAL 60
+ENDPROC out ;
+
+PROC outsubtext ( TEXT CONST source, INT CONST from ) :
+ EXTERNAL 62
+END PROC outsubtext;
+
+PROC outsubtext (TEXT CONST source, INT CONST from, to) :
+ EXTERNAL 63
+END PROC outsubtext;
+
+PROC outtext ( TEXT CONST source, INT CONST from, to ) :
+ out subtext (source, from, to) ;
+ INT VAR trailing ;
+ IF from <= LENGTH source
+ THEN trailing := to - LENGTH source
+ ELSE trailing := to + 1 - from
+ FI ;
+ IF trailing > 0
+ THEN trailing TIMESOUT " "
+ FI
+ENDPROC outtext ;
+
+OP TIMESOUT (INT CONST times, TEXT CONST text) :
+
+ IF text = " "
+ THEN fast timesout blank
+ ELSE timesout
+ FI .
+
+fast timesout blank :
+ INT VAR i := 0 ;
+ WHILE i + 64 < times REP
+ out (blank times 64) ;
+ i INCR 64
+ PER ;
+ outsubtext (blank times 64, 1, times - i) .
+
+timesout :
+ FOR i FROM 1 UPTO times REP
+ out(text)
+ ENDREP .
+
+ENDOP TIMESOUT ;
+
+PROC display (TEXT CONST text) :
+ IF online
+ THEN out (text)
+ FI
+ENDPROC display ;
+
+PROC inchar (TEXT VAR character ) :
+ EXTERNAL 64
+ENDPROC inchar ;
+
+TEXT PROC incharety :
+ EXTERNAL 65
+END PROC incharety ;
+
+TEXT PROC incharety (INT CONST time limit) :
+ internal pause (time limit) ;
+ incharety
+ENDPROC incharety ;
+
+PROC pause (INT CONST time limit) :
+ internal pause (time limit) ;
+ TEXT CONST dummy := incharety
+ENDPROC pause ;
+
+PROC pause :
+ TEXT VAR dummy; inchar (dummy)
+ENDPROC pause ;
+
+PROC internal pause (INT CONST time limit) :
+ EXTERNAL 66
+ENDPROC internal pause ;
+
+PROC cat input (TEXT VAR t, esc char) :
+ EXTERNAL 68
+ENDPROC cat input ;
+
+
+PROC cursor (INT CONST x, y) :
+ out (""6"") ;
+ out (code(y-1)) ;
+ out (code(x-1)) ;
+ENDPROC cursor ;
+
+PROC get cursor (INT VAR x, y) :
+ EXTERNAL 67
+ENDPROC get cursor ;
+
+PROC cout (INT CONST number) :
+ EXTERNAL 61
+ENDPROC cout ;
+
+
+INT PROC channel :
+ pcb (channel field)
+ENDPROC channel ;
+
+BOOL PROC online :
+ pcb (channel field) <> 0
+ENDPROC online ;
+
+
+PROC control (INT CONST code1, code2, code3, INT VAR return code) :
+ EXTERNAL 84
+ENDPROC control ;
+
+PROC blockout (ROW 256 INT CONST block, INT CONST code1, code2,
+ INT VAR return code) :
+
+ access block io ds ;
+ block io.buffer := block ;
+ blockout (block io ds, buffer page, code1, code2, return code) .
+
+access block io ds :
+ IF NOT initialized (this packet)
+ THEN block io ds := nilspace
+ FI ;
+ block io := block io ds .
+
+ENDPROC blockout ;
+
+PROC blockin (ROW 256 INT VAR block, INT CONST code1, code2,
+ INT VAR return code) :
+
+ access block io ds ;
+ blockin (block io ds, buffer page, code1, code2, return code) ;
+ block := block io.buffer .
+
+access block io ds :
+ IF NOT initialized (this packet)
+ THEN block io ds := nilspace
+ FI ;
+ block io := block io ds .
+
+ENDPROC blockin ;
+
+ENDPACKET basic transput ;
+
diff --git a/system/base/1.7.5/src/bits b/system/base/1.7.5/src/bits
new file mode 100644
index 0000000..e9e84e7
--- /dev/null
+++ b/system/base/1.7.5/src/bits
@@ -0,0 +1,78 @@
+
+PACKET bits DEFINES
+
+ AND ,
+ OR ,
+ XOR ,
+ bit ,
+ lowest reset ,
+ lowest set ,
+ reset bit ,
+ rotate ,
+ set bit :
+
+LET bits per int = 16 ;
+
+ROW bits per int INT VAR bit mask := ROW bits per int INT:
+ (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,-32767-1) ;
+
+PROC rotate (INT VAR bits, INT CONST number of bits) :
+ EXTERNAL 83
+ENDPROC rotate ;
+
+INT OP AND (INT CONST left, right) :
+ EXTERNAL 124
+ENDOP AND ;
+
+INT OP OR (INT CONST left, right) :
+ EXTERNAL 125
+ENDOP OR ;
+
+INT OP XOR (INT CONST left, right) :
+ EXTERNAL 121
+ENDOP XOR ;
+
+BOOL PROC bit (INT CONST bits, bit no) :
+
+ (bits AND bit mask (bit no+1)) <> 0
+
+ENDPROC bit ;
+
+PROC set bit (INT VAR bits, INT CONST bit no) :
+
+ bits := bits OR bit mask (bit no+1)
+
+ENDPROC set bit ;
+
+PROC reset bit (INT VAR bits,INT CONST bit no) :
+
+ bits := bits XOR (bits AND bit mask (bit no+1))
+
+ENDPROC reset bit ;
+
+INT PROC lowest set (INT CONST bits) :
+
+ INT VAR mask index ;
+ FOR mask index FROM 1 UPTO 16 REP
+ IF (bits AND bit mask (mask index)) <> 0
+ THEN LEAVE lowest set WITH mask index - 1
+ FI
+ PER ;
+ -1
+
+ENDPROC lowest set ;
+
+INT PROC lowest reset (INT CONST bits) :
+
+ INT VAR mask index ;
+ FOR mask index FROM 1 UPTO bits per int REP
+ IF (bits AND bit mask (mask index)) = 0
+ THEN LEAVE lowest reset WITH mask index - 1
+ FI
+ PER ;
+ -1
+
+ENDPROC lowest reset ;
+
+ENDPACKET bits ;
+
diff --git a/system/base/1.7.5/src/bool b/system/base/1.7.5/src/bool
new file mode 100644
index 0000000..5bf1e65
--- /dev/null
+++ b/system/base/1.7.5/src/bool
@@ -0,0 +1,16 @@
+
+PACKET bool DEFINES XOR, true, false :
+
+BOOL CONST true := TRUE ,
+ false:= FALSE ;
+
+BOOL OP XOR (BOOL CONST left, right) :
+
+ IF left THEN NOT right
+ ELSE right
+ FI
+
+ENDOP XOR ;
+
+ENDPACKET bool ;
+
diff --git a/system/base/1.7.5/src/command dialogue b/system/base/1.7.5/src/command dialogue
new file mode 100644
index 0000000..3011187
--- /dev/null
+++ b/system/base/1.7.5/src/command dialogue
@@ -0,0 +1,123 @@
+
+PACKET command dialogue DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 25.11.83 *)
+ command dialogue ,
+ say ,
+ yes ,
+ no ,
+ param position ,
+ last param ,
+ std ,
+ QUIET ,
+ quiet :
+
+
+LET up = ""3"" ,
+ right = ""2"" ,
+ cr lf = ""13""10"" ,
+ param pre = " (""" ,
+ param post = """)"13""10"" ;
+
+
+TEXT VAR std param := "" ;
+
+BOOL VAR dialogue flag := TRUE ;
+
+INT VAR param x := 0 ;
+
+
+TYPE QUIET = INT ;
+
+QUIET PROC quiet :
+ QUIET:(0)
+ENDPROC quiet ;
+
+
+BOOL PROC command dialogue :
+ dialogue flag
+ENDPROC command dialogue ;
+
+PROC command dialogue (BOOL CONST status) :
+ dialogue flag := status
+ENDPROC command dialogue ;
+
+
+BOOL PROC yes (TEXT CONST question) :
+
+ IF dialogue flag
+ THEN ask question
+ ELSE TRUE
+ FI .
+
+ask question :
+ out (question) ;
+ skip previous input chars ;
+ out (" (j/n) ? ") ;
+ get answer ;
+ IF correct answer
+ THEN out (answer) ;
+ out (cr lf) ;
+ positive answer
+ ELSE out (""7"") ;
+ LENGTH question + 9 TIMESOUT ""8"" ;
+ yes (question)
+ FI .
+
+get answer :
+ TEXT VAR answer ;
+ inchar (answer) .
+
+correct answer :
+ pos ("jnyJNY", answer) > 0 .
+
+positive answer :
+ pos ("jyJY", answer) > 0 .
+
+skip previous input chars :
+ REP UNTIL incharety = "" PER .
+
+ENDPROC yes ;
+
+BOOL PROC no (TEXT CONST question) :
+
+ NOT yes (question)
+
+ENDPROC no ;
+
+PROC say (TEXT CONST message) :
+
+ IF dialogue flag
+ THEN out (message)
+ FI
+
+ENDPROC say ;
+
+PROC param position (INT CONST x) :
+
+ param x := x
+
+ENDPROC param position ;
+
+TEXT PROC last param :
+
+ IF param x > 0 AND online
+ THEN out (up) ;
+ param x TIMESOUT right ;
+ out (param pre) ;
+ out (std param) ;
+ out (param post)
+ FI ;
+ std param .
+
+ENDPROC last param ;
+
+PROC last param (TEXT CONST new) :
+ std param := new
+ENDPROC last param ;
+
+TEXT PROC std :
+ std param
+ENDPROC std ;
+
+ENDPACKET command dialogue ;
+
diff --git a/system/base/1.7.5/src/command handler b/system/base/1.7.5/src/command handler
new file mode 100644
index 0000000..756382b
--- /dev/null
+++ b/system/base/1.7.5/src/command handler
@@ -0,0 +1,290 @@
+(* ------------------- VERSION 2 05.05.86 ------------------- *)
+PACKET command handler DEFINES (* Autor: J.Liedtke *)
+
+ get command ,
+ analyze command ,
+ do command ,
+ command error ,
+ cover tracks :
+
+
+LET cr lf = ""4""13""10"" ,
+ esc k = ""27"k" ,
+ command pre = ""4""13" " ,
+ command post = ""13""10" " ,
+
+ max command length = 2010 ,
+
+ tag type = 1 ,
+ texttype = 4 ,
+ eof type = 7 ;
+
+
+TEXT VAR command handlers own command line := "" ,
+ previous command line := "" ,
+ symbol ,
+ procedure ,
+ pattern ,
+ error note := "" ;
+
+INT VAR symbol type ;
+
+
+PROC get command (TEXT CONST command text) :
+
+ get command (command text, command handlers own command line)
+
+ENDPROC get command ;
+
+PROC get command (TEXT CONST command text, TEXT VAR command line) :
+
+ set line nr (0) ;
+ error protocoll ;
+ get command from console .
+
+error protocoll :
+ IF is error
+ THEN put error ;
+ clear error
+ ELSE command line := "" ;
+ FI .
+
+get command from console :
+ normalize cursor ;
+ REP
+ out (command pre) ;
+ out (command text) ;
+ out (command post) ;
+ editget command
+ UNTIL command line <> "" PER ;
+ param position (LENGTH command line) ;
+ out (command post) .
+
+editget command :
+ TEXT VAR exit char ;
+ REP
+ get cursor (x, y) ;
+ editget (command line, max command length, x size - x,
+ "", "k", exit char) ;
+ ignore halt errors during editget ;
+ break quiet if command line is too long ;
+ IF exit char = esc k
+ THEN cursor to begin of command input ;
+ command line := previous command line
+ ELIF LENGTH command line > 1
+ THEN previous command line := command line ;
+ LEAVE editget command
+ ELSE LEAVE editget command
+ FI
+ PER .
+
+normalize cursor :
+ INT VAR x, y;
+ out (crlf) ;
+ get cursor (x, y) ;
+ cursor (x, y) .
+
+ignore halt errors during editget :
+ IF is error
+ THEN clear error
+ FI .
+
+break quiet if command line is too long :
+ IF command line is too long
+ THEN command line := "break (quiet)"
+ FI .
+
+command line is too long :
+ LENGTH command line = max command length .
+
+cursor to begin of command input :
+ out (command pre) .
+
+ENDPROC get command ;
+
+
+PROC analyze command ( TEXT CONST command list,
+ INT CONST permitted type,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ analyze command (command list, command handlers own command line,
+ permitted type, command index,
+ number of params, param 1, param 2)
+
+ENDPROC analyze command ;
+
+PROC analyze command ( TEXT CONST command list, command line,
+ INT CONST permitted type,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ error note := "" ;
+ scan (command line) ;
+ next symbol ;
+ IF symbol type <> tag type AND symbol <> "?"
+ THEN error ("Name ungueltig") ;
+ impossible command
+ ELIF pos (command list, symbol) > 0
+ THEN procedure name ;
+ parameter list pack option ;
+ nothing else in command line ;
+ decode command
+ ELSE impossible command
+ FI .
+
+procedure name :
+ procedure := symbol ;
+ next symbol .
+
+parameter list pack option :
+ number of params := 0 ;
+ param 1 := "" ;
+ param 2 := "" ;
+ IF symbol = "("
+ THEN next symbol ;
+ parameter list ;
+ IF symbol <> ")" AND error note = ""
+ THEN error (") fehlt")
+ FI
+ ELIF symbol type <> eof type
+ THEN error ("( fehlt")
+ FI .
+
+parameter list :
+ parameter (param 1, number of params, permitted type) ;
+ IF symbol = ","
+ THEN next symbol ;
+ parameter (param 2, number of params, permitted type) ;
+ FI .
+
+nothing else in command line :
+ next symbol ;
+ IF symbol <> ""
+ THEN error ("Kommando zu schwierig")
+ FI .
+
+decode command :
+ command index := index (command list, procedure, number of params) .
+
+impossible command :
+ command index := 0 .
+
+ENDPROC analyze command ;
+
+PROC parameter (TEXT VAR param, INT VAR number of params,
+ INT CONST permitted type) :
+
+ IF symbol type = text type OR symbol type = permitted type
+ THEN param := symbol ;
+ number of params INCR 1 ;
+ next symbol
+ ELSE error ("Parameter ist kein TEXT ("" fehlt)")
+ FI
+
+ENDPROC parameter ;
+
+INT PROC index (TEXT CONST list, procedure, INT CONST params) :
+
+ pattern := procedure ;
+ pattern CAT ":" ;
+ IF procedure name found
+ THEN get colon pos ;
+ get dot pos ;
+ get end pos ;
+ get command index ;
+ get param index ;
+ IF param index >= 0
+ THEN command index + param index
+ ELSE - command index
+ FI
+ ELSE 0
+ FI .
+
+procedure name found :
+ INT VAR index pos := pos (list, pattern) ;
+ WHILE index pos > 0 REP
+ IF index pos = 1 COR (list SUB index pos - 1) <= "9"
+ THEN LEAVE procedure name found WITH TRUE
+ FI ;
+ index pos := pos (list, pattern, index pos + 1)
+ PER ;
+ FALSE .
+
+get param index :
+ INT CONST param index :=
+ pos (list, text (params), dot pos, end pos) - dot pos - 1 .
+
+get command index :
+ INT CONST command index :=
+ int ( subtext (list, colon pos + 1, dot pos - 1) ) .
+
+get colon pos :
+ INT CONST colon pos := pos (list, ":", index pos) .
+
+get dot pos :
+ INT CONST dot pos := pos (list, ".", index pos) .
+
+get end pos :
+ INT CONST end pos := dot pos + 4 .
+
+ENDPROC index ;
+
+PROC do command :
+
+ do (command handlers own command line)
+
+ENDPROC do command ;
+
+PROC error (TEXT CONST message) :
+
+ error note := message ;
+ scan ("") ;
+ procedure := "-"
+
+ENDPROC error ;
+
+PROC command error :
+
+ disable stop ;
+ IF error note <> ""
+ THEN errorstop (error note) ;
+ error note := ""
+ FI ;
+ enable stop
+
+ENDPROC command error ;
+
+
+PROC next symbol :
+
+ next symbol (symbol, symbol type)
+
+ENDPROC next symbol ;
+
+
+PROC cover tracks :
+
+ cover tracks (command handlers own command line) ;
+ cover tracks (previous command line) ;
+ erase buffers of compiler and do packet .
+
+erase buffers of compiler and do packet :
+ do (command handlers own command line) .
+
+ENDPROC cover tracks ;
+
+PROC cover tracks (TEXT VAR secret) :
+
+ INT VAR i ;
+ FOR i FROM 1 UPTO LENGTH secret REP
+ replace (secret, i, " ")
+ PER ;
+ WHILE LENGTH secret < 13 REP
+ secret CAT " "
+ PER
+
+ENDPROC cover tracks ;
+
+ENDPACKET command handler ;
+
diff --git a/system/base/1.7.5/src/dataspace b/system/base/1.7.5/src/dataspace
new file mode 100644
index 0000000..3045a53
--- /dev/null
+++ b/system/base/1.7.5/src/dataspace
@@ -0,0 +1,74 @@
+(* ------------------- VERSION 3 22.04.86 ------------------- *)
+PACKET dataspace DEFINES
+
+ := ,
+ nilspace ,
+ forget ,
+ type ,
+ heap size ,
+ storage ,
+ ds pages ,
+ next ds page ,
+ blockout ,
+ blockin ,
+ ALIGN :
+
+
+LET myself id field = 9 ,
+ lowest ds number = 4 ,
+ highest ds number = 255 ;
+
+TYPE ALIGN = ROW 252 INT ;
+
+OP := (DATASPACE VAR dest, DATASPACE CONST source ) :
+ EXTERNAL 70
+ENDOP := ;
+
+DATASPACE PROC nilspace :
+ EXTERNAL 69
+ENDPROC nilspace ;
+
+PROC forget (DATASPACE CONST dataspace ) :
+ EXTERNAL 71
+ENDPROC forget ;
+
+PROC type (DATASPACE CONST ds, INT CONST type) :
+ EXTERNAL 72
+ENDPROC type ;
+
+INT PROC type (DATASPACE CONST ds) :
+ EXTERNAL 73
+ENDPROC type ;
+
+INT PROC heap size (DATASPACE CONST ds) :
+ EXTERNAL 74
+ENDPROC heap size ;
+
+INT PROC storage (DATASPACE CONST ds) :
+ (ds pages (ds) + 1) DIV 2
+ENDPROC storage ;
+
+INT PROC ds pages (DATASPACE CONST ds) :
+ pages (ds, pcb (myself id field))
+ENDPROC ds pages ;
+
+INT PROC pages (DATASPACE CONST ds, INT CONST task nr) :
+ EXTERNAL 88
+ENDPROC pages ;
+
+INT PROC next ds page (DATASPACE CONST ds, INT CONST page nr) :
+ EXTERNAL 87
+ENDPROC next ds page ;
+
+PROC blockout (DATASPACE CONST ds, INT CONST page nr, code1, code2,
+ INT VAR return code) :
+ EXTERNAL 85
+ENDPROC blockout ;
+
+PROC blockin (DATASPACE VAR ds, INT CONST page nr, code1, code2,
+ INT VAR return code) :
+ EXTERNAL 86
+ENDPROC blockin ;
+
+ENDPACKET dataspace ;
+
diff --git a/system/base/1.7.5/src/date handling b/system/base/1.7.5/src/date handling
new file mode 100644
index 0000000..66da110
--- /dev/null
+++ b/system/base/1.7.5/src/date handling
@@ -0,0 +1,303 @@
+PACKET date handling DEFINES date, time, (* Autor: H. Indenbirken *)
+ time of day, (* Stand: 02.06.1986 (wk)*)
+ month, day , year ,
+ hour ,
+ minute,
+ second :
+
+LET middle yearlength = 31557380.0,
+ weeklength = 604800.0,
+ daylength = 86400.0,
+ hours = 3600.0,
+ minutes = 60.0,
+ seconds = 1.0;
+
+
+(* Tage bis zum Jahr 01.01.1900: 693970.25 5.995903e10 Sekunden *)
+(* Dieser Tag ist ein Montag *)
+
+REAL VAR begin of today := 0.0 , end of today := 0.0 ;
+
+TEXT VAR today , result ;
+
+
+ROW 12 REAL CONST previous days :: ROW 12 REAL : (0.0, 2678400.0, 5097600.0,
+ 7776000.0, 10368000.0, 13046400.0,
+ 15638400.0, 18316800.0, 20995200.0,
+ 23587200.0, 26265600.0, 28857600.0);
+
+REAL PROC day: day length END PROC day;
+REAL PROC hour: hours END PROC hour;
+REAL PROC minute: minutes END PROC minute;
+REAL PROC second: seconds END PROC second;
+
+TEXT PROC date :
+
+ IF clock (1) < begin of today OR end of today <= clock (1)
+ THEN begin of today := clock (1) ;
+ end of today := floor (begin of today/daylength)*daylength+daylength;
+ today := date (begin of today)
+ FI ;
+ today
+
+ENDPROC date ;
+
+TEXT PROC date (REAL CONST datum):
+ INT VAR year :: int (datum/middle yearlength),
+ day :: int (((datum - datum MOD daylength) MOD middle yearlength) / daylength) + 1;
+
+correct kalendary day;
+
+ calculate month and correct day;
+ result := daytext;
+ result CAT monthtext;
+ result CAT yeartext;
+ change all (result, " ", "0") ;
+ result .
+
+correct kalendary day:
+ IF day >= 60 AND NOT leapyear
+ THEN day INCR 1 FI .
+
+leapyear:
+ IF year MOD 100 = 0
+ THEN year MOD 400 = 0
+ ELSE year MOD 4 = 0
+ FI.
+
+calculate month and correct day:
+ INT VAR month;
+ IF day > 182
+ THEN IF day > 274
+ THEN IF day > 305
+ THEN IF day > 335
+ THEN month := 12;
+ day DECR 335
+ ELSE month := 11;
+ day DECR 305
+ FI
+ ELSE month := 10;
+ day DECR 274
+ FI
+ ELSE IF day > 213
+ THEN IF day > 244
+ THEN month := 9;
+ day DECR 244
+ ELSE month := 8;
+ day DECR 213
+ FI
+ ELSE month := 7;
+ day DECR 182
+ FI
+ FI
+ ELSE IF day > 91
+ THEN IF day > 121
+ THEN IF day > 152
+ THEN month := 6;
+ day DECR 152
+ ELSE month := 5;
+ day DECR 121
+ FI
+ ELSE month := 4;
+ day DECR 91
+ FI
+ ELSE IF day > 31
+ THEN IF day > 60
+ THEN month := 3;
+ day DECR 60
+ ELSE month := 2;
+ day DECR 31
+ FI
+ ELSE month := 1 FI
+ FI
+ FI .
+
+daytext :
+ text (day, 2) + "." .
+
+monthtext :
+ text (month,2) + "." .
+
+yeartext:
+ IF 1900 <= year AND year < 2000
+ THEN text (year - 1900, 2)
+ ELSE text (year, 4)
+ FI .
+
+END PROC date;
+
+TEXT PROC day (REAL CONST datum):
+ SELECT int ((datum MOD weeklength)/daylength) OF
+ CASE 1: "Donnerstag"
+ CASE 2: "Freitag"
+ CASE 3: "Samstag"
+ CASE 4: "Sonntag"
+ CASE 5: "Montag"
+ CASE 6: "Dienstag"
+ OTHERWISE "Mittwoch" ENDSELECT .
+END PROC day;
+
+TEXT PROC month (REAL CONST datum):
+ SELECT int (subtext (date (datum), 4, 5)) OF
+ CASE 1: "Januar"
+ CASE 2: "Februar"
+ CASE 3: "März"
+ CASE 4: "April"
+ CASE 5: "Mai"
+ CASE 6: "Juni"
+ CASE 7: "Juli"
+ CASE 8: "August"
+ CASE 9: "September"
+ CASE 10: "Oktober"
+ CASE 11: "November"
+ OTHERWISE "Dezember" ENDSELECT .
+
+END PROC month;
+
+TEXT PROC year (REAL CONST datum) :
+
+ TEXT VAR buffer := subtext (date (datum), 7) ;
+ IF LENGTH buffer = 2
+ THEN "19" + buffer
+ ELSE buffer
+ FI .
+
+ENDPROC year ;
+
+TEXT PROC time of day :
+ time of day (clock (1))
+ENDPROC time of day ;
+
+TEXT PROC time of day (REAL CONST value) :
+ subtext (time (value MOD daylength), 1, 5)
+ENDPROC time of day ;
+
+TEXT PROC time (REAL CONST value) :
+ time (value,10)
+ENDPROC time ;
+
+TEXT PROC time (REAL CONST value, INT CONST length) :
+ result := "" ;
+ IF length > 7
+ THEN result CAT hour ;
+ result CAT ":"
+ FI ;
+ result CAT minute ;
+ result CAT ":" ;
+ result CAT rest ;
+ change all (result, " ", "0") ;
+ result .
+
+hour :
+ text (int (value/hours), length-8) .
+
+minute :
+ text (int (value/minutes MOD 60.0), 2) .
+
+rest :
+ text (value MOD minutes, 4, 1) .
+
+END PROC time ;
+
+REAL PROC date (TEXT CONST datum) :
+ split and check datum;
+ real (day no)*daylength +
+ previous days [month no] + calendary day +
+ floor (real (year no)*middleyearlength / daylength)*daylength .
+
+split and check datum:
+ INT CONST day no :: first no;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI;
+
+ INT CONST month no :: second no;
+ IF NOT last conversion ok OR month no < 1 OR month no > 12
+ THEN errorstop ("inkorrekte Datumsangabe (Monat) : " + datum) FI;
+
+ INT CONST year no :: third no + century;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Jahr) : " + datum) FI;
+
+ IF day no < 1 OR day no > size of month
+ THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI .
+
+century:
+ IF (length (datum) - second pos) <= 2
+ THEN 1900
+ ELSE 0 FI .
+
+size of month:
+ SELECT month no OF
+ CASE 1, 3, 5, 7, 8, 10, 12: 31
+ CASE 4, 6, 9, 11: 30
+ OTHERWISE february size ENDSELECT .
+
+february size:
+ IF leapyear
+ THEN 29
+ ELSE 28 FI .
+
+calendary day:
+ IF month no > 2 AND leapyear
+ THEN daylength
+ ELSE 0.0 FI .
+
+leapyear:
+ year no MOD 4 = 0 AND year no MOD 400 <> 0 .
+
+first no:
+ INT CONST first pos :: pos (datum, ".");
+ int (subtext (datum, 1, first pos-1)) .
+
+second no:
+ INT CONST second pos :: pos (datum, ".", first pos+1);
+ int (subtext (datum, first pos + 1, second pos-1)) .
+
+third no:
+ int (subtext (datum, second pos + 1)) .
+
+END PROC date;
+
+REAL PROC time (TEXT CONST time) :
+ split and check time;
+ hour + min + sec .
+
+split and check time:
+ REAL CONST hour :: hour no * hours;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Stunde) : " + time) FI;
+
+ REAL CONST min :: min no * minutes;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Minute) : " + time) FI;
+
+ REAL CONST sec :: sec no;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Sekunde) : " + time) FI;
+
+ set conversion (hour ok AND min ok AND sec ok) .
+
+hour no:
+ INT CONST hour pos :: pos (time, ":");
+ real (subtext (time, 1, hour pos-1)) .
+
+min no:
+ INT VAR min pos :: pos (time, ":", hour pos+1);
+ IF min pos = 0
+ THEN real (subtext (time, hour pos + 1, LENGTH time))
+ ELSE real (subtext (time, hour pos + 1, min pos-1))
+ FI .
+
+sec no:
+ IF min pos = 0
+ THEN 0.0
+ ELSE real (subtext (time, min pos + 1))
+ FI .
+
+hour ok: 0.0 <= hour AND hour < daylength .
+min ok: 0.0 <= min AND min < hours .
+sec ok: 0.0 <= sec AND sec < minutes .
+END PROC time;
+
+END PACKET datehandling
+
diff --git a/system/base/1.7.5/src/editor b/system/base/1.7.5/src/editor
new file mode 100644
index 0000000..62af2db
--- /dev/null
+++ b/system/base/1.7.5/src/editor
@@ -0,0 +1,2959 @@
+PACKET editor paket DEFINES (* EDITOR 121 *)
+ (**********) (* 19.07.85 -bk- *)
+ (* 10.09.85 -ws- *)
+ (* 25.04.86 -sh- *)
+ edit, editget, (* 06.06.86 -wk- *)
+ quit, quit last, (* 04.06.86 -jl- *)
+ push, type,
+ word wrap, margin,
+ write permission,
+ set busy indicator,
+ two bytes,
+ is kanji esc,
+ within kanji,
+ rubin mode,
+ is editget,
+ getchar, nichts neu,
+ getcharety, satznr neu,
+ is incharety, ueberschrift neu,
+ get window, zeile neu,
+ get editcursor, abschnitt neu,
+ get editline, bildabschnitt neu,
+ put editline, bild neu,
+ aktueller editor, alles neu,
+ groesster editor, satznr zeigen,
+ open editor, ueberschrift zeigen,
+ editfile, bild zeigen:
+
+
+LET hop = ""1"", right = ""2"",
+ up char = ""3"", clear eop = ""4"",
+ clear eol = ""5"", cursor pos = ""6"",
+ piep = ""7"", left = ""8"",
+ down char = ""10"", rubin = ""11"",
+ rubout = ""12"", cr = ""13"",
+ mark key = ""16"", abscr = ""17"",
+ inscr = ""18"", dezimal = ""19"",
+ backcr = ""20"", esc = ""27"",
+ dach = ""94"", blank = " ";
+
+
+LET no output = 0, out zeichen = 1,
+ out feldrest = 2, out feld = 3,
+ clear feldrest = 4;
+
+LET FELDSTATUS = STRUCT (INT stelle, alte stelle, rand, limit,
+ anfang, marke, laenge, verschoben,
+ BOOL einfuegen, fliesstext, write access,
+ TEXT tabulator);
+FELDSTATUS VAR feldstatus;
+
+TEXT VAR begin mark := ""15"",
+ end mark := ""14"";
+
+TEXT VAR separator := "", kommando := "", audit := "", zeichen := "",
+ satzrest := "", merksatz := "", alter editsatz := "";
+
+INT VAR kommando zeiger := 1, umbruchstelle, umbruch verschoben,
+ zeile, spalte, output mode := no output, postblanks := 0,
+ min schreibpos, max schreibpos, cpos, absatz ausgleich;
+
+BOOL VAR lernmodus := FALSE, separator eingestellt := FALSE,
+ invertierte darstellung := FALSE, absatzmarke steht,
+ cursor diff := FALSE, editget modus := FALSE,
+ two byte mode := FALSE, std fliesstext := TRUE;.
+
+schirmbreite : x size - 1 .
+schirmhoehe : y size .
+maxbreite : schirmbreite - 2 .
+maxlaenge : schirmhoehe - 1 .
+marklength : mark size .;
+
+initialisiere editor;
+
+.initialisiere editor :
+ anfang := 1; zeile := 0; verschoben := 0; tabulator := "";
+ einfuegen := FALSE; fliesstext := TRUE; zeileneinfuegen := FALSE;
+ marke := 0; bildmarke := 0; feldmarke := 0.;
+
+(******************************** editget ********************************)
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge,
+ TEXT CONST sep, res, TEXT VAR exit char) :
+ IF editlaenge < 1 THEN errorstop ("Fenster zu klein") FI;
+ separator := ""13""; separator CAT sep;
+ separator eingestellt := TRUE;
+ TEXT VAR reservierte editget tasten := ""11""12"" ;
+ reservierte editget tasten CAT res ;
+ disable stop;
+ absatz ausgleich := 0; exit char := ""; get cursor;
+ FELDSTATUS CONST alter feldstatus := feldstatus;
+ feldstatus := FELDSTATUS : (1, 1, spalte - 1, editlimit,
+ 1, 0, editlaenge, 0,
+ FALSE, FALSE, TRUE, "");
+ konstanten neu berechnen;
+ output mode := out feld;
+ feld editieren;
+ zeile verlassen;
+ feldstatus := alter feldstatus;
+ konstanten neu berechnen;
+ separator := "";
+ separator eingestellt := FALSE .
+
+feld editieren :
+ REP
+ feldeditor (editsatz, reservierte editget tasten);
+ IF is error
+ THEN kommando zeiger := 1; kommando := ""; LEAVE feld editieren
+ FI ;
+ TEXT VAR t, zeichen; getchar (zeichen);
+ IF zeichen ist separator
+ THEN exit char := zeichen; LEAVE feld editieren
+ ELIF zeichen = hop
+ THEN feldout (editsatz, stelle); getchar (zeichen)
+ ELIF zeichen = mark key
+ THEN output mode := out feld
+ ELIF zeichen = abscr
+ THEN exit char := cr; LEAVE feld editieren
+ ELIF zeichen = esc
+ THEN getchar (zeichen); auf exit pruefen;
+ IF zeichen = rubout (*sh*)
+ THEN IF marke > 0
+ THEN merksatz := subtext (editsatz, marke, stelle - 1);
+ change (editsatz, marke, stelle - 1, "");
+ stelle := marke; marke := 0; konstanten neu berechnen
+ FI
+ ELIF zeichen = rubin
+ THEN t := subtext (editsatz, 1, stelle - 1);
+ t CAT merksatz;
+ satzrest := subtext (editsatz, stelle);
+ t CAT satzrest;
+ stelle INCR LENGTH merksatz;
+ merksatz := ""; editsatz := t
+ ELIF zeichen ist kein esc kommando (*wk*)
+ AND
+ kommando auf taste (zeichen) <> ""
+ THEN editget kommando ausfuehren
+ FI ;
+ output mode := out feld
+ FI
+ PER .
+
+zeichen ist kein esc kommando : (*wk*)
+ pos (hop + left + right, zeichen) = 0 .
+
+zeile verlassen :
+ IF marke > 0 OR verschoben <> 0
+ THEN stelle DECR verschoben; verschoben := 0; feldout (editsatz, 0)
+ ELSE cursor (rand + 1 + min (LENGTH editsatz, editlaenge), zeile)
+ FI .
+
+zeichen ist separator : pos (separator, zeichen) > 0 .
+
+auf exit pruefen :
+ IF pos (res, zeichen) > 0
+ THEN exit char := esc + zeichen; LEAVE feld editieren
+ FI .
+
+editget kommando ausfuehren :
+ editget zustaende sichern ;
+ do (kommando auf taste (zeichen)) ;
+ alte editget zustaende wieder herstellen ;
+ IF stelle < marke THEN stelle := marke FI;
+ konstanten neu berechnen .
+
+editget zustaende sichern : (*wk*)
+ BOOL VAR alter editget modus := editget modus;
+ FELDSTATUS VAR feldstatus vor do kommando := feldstatus ;
+ INT VAR zeile vor do kommando := zeile ;
+ TEXT VAR separator vor do kommando := separator ;
+ BOOL VAR separator eingestellt vor do kommando := separator eingestellt ;
+ editget modus := TRUE ;
+ alter editsatz := editsatz .
+
+alte editget zustaende wieder herstellen :
+ editget modus := alter editget modus ;
+ editsatz := alter editsatz;
+ feldstatus := feldstatus vor do kommando ;
+ zeile := zeile vor do kommando ;
+ separator := separator vor do kommando ;
+ separator eingestellt := separator eingestellt vor do kommando .
+
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, TEXT VAR exit char) :
+ editget (editsatz, editlimit, x size - x cursor, "", "", exit char)
+END PROC editget; (* 05.07.84 -bk- *)
+
+PROC editget (TEXT VAR editsatz, TEXT CONST sep, res, TEXT VAR exit char) :
+ editget (editsatz, max text length, x size - x cursor, sep, res, exit char)
+END PROC editget; (* 05.07.84 -bk- *)
+
+PROC editget (TEXT VAR editsatz) :
+ TEXT VAR exit char; (* 05.07.84 -bk- *)
+ editget (editsatz, max text length, x size - x cursor, "", "", exit char)
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge) :
+ TEXT VAR exit char;
+ editget (editsatz, editlimit, editlaenge, "", "", exit char)
+ENDPROC editget;
+
+(******************************* feldeditor ******************************)
+
+TEXT VAR reservierte feldeditor tasten ; (*jl*)
+
+PROC feldeditor (TEXT VAR satz, TEXT CONST res) :
+ enable stop;
+ reservierte feldeditor tasten := ""1""2""8"" ;
+ reservierte feldeditor tasten CAT res;
+ absatzmarke steht := (satz SUB LENGTH satz) = blank;
+ alte stelle merken;
+ cursor diff bestimmen und ggf ausgleichen;
+ feld editieren;
+ absatzmarke updaten .
+
+alte stelle merken : alte stelle := stelle .
+
+cursor diff bestimmen und ggf ausgleichen :
+ IF cursor diff
+ THEN stelle INCR 1; cursor diff := FALSE
+ FI ;
+ IF stelle auf zweitem halbzeichen
+ THEN stelle DECR 1; cursor diff := TRUE
+ FI .
+
+feld editieren :
+ REP
+ feld optisch aufbereiten;
+ kommando annehmen und ausfuehren
+ PER .
+
+absatzmarke updaten :
+ IF absatzmarke soll stehen
+ THEN IF NOT absatzmarke steht THEN absatzmarke schreiben (TRUE) FI
+ ELSE IF absatzmarke steht THEN absatzmarke schreiben (FALSE) FI
+ FI .
+
+absatzmarke soll stehen : (satz SUB LENGTH satz) = blank .
+
+feld optisch aufbereiten :
+ stelle korrigieren;
+ verschieben wenn erforderlich;
+ randausgleich fuer doppelzeichen;
+ output mode behandeln;
+ ausgabe verhindern .
+
+randausgleich fuer doppelzeichen :
+ IF stelle = max schreibpos CAND stelle auf erstem halbzeichen
+ THEN verschiebe (1)
+ FI .
+
+stelle korrigieren :
+ IF stelle auf zweitem halbzeichen THEN stelle DECR 1 FI .
+
+stelle auf erstem halbzeichen : within kanji (satz, stelle + 1) .
+
+stelle auf zweitem halbzeichen : within kanji (satz, stelle) .
+
+output mode behandeln :
+ SELECT output mode OF
+ CASE no output : im markiermode markierung anpassen
+ CASE out zeichen : zeichen ausgeben; LEAVE output mode behandeln
+ CASE out feldrest : feldrest neu schreiben
+ CASE out feld : feldout (satz, stelle)
+ CASE clear feldrest : feldrest loeschen
+ END SELECT;
+ schreibmarke positionieren (stelle) .
+
+ausgabe verhindern : output mode := no output .
+
+im markiermode markierung anpassen :
+ IF markiert THEN markierung anpassen FI .
+
+markierung anpassen :
+ IF stelle > alte stelle
+ THEN markierung verlaengern
+ ELIF stelle < alte stelle
+ THEN markierung verkuerzen
+ FI .
+
+markierung verlaengern :
+ invers out (satz, alte stelle, stelle, "", end mark) .
+
+markierung verkuerzen :
+ invers out (satz, stelle, alte stelle, end mark, "") .
+
+zeichen ausgeben :
+ IF NOT markiert
+ THEN out (zeichen)
+ ELIF mark refresh line mode
+ THEN feldout (satz, stelle); schreibmarke positionieren (stelle)
+ ELSE out (begin mark); markleft; out (zeichen); out (end mark); markleft
+ FI .
+
+markleft :
+ marklength TIMESOUT left .
+
+feldrest neu schreiben :
+ IF NOT markiert
+ THEN feldrest unmarkiert neu schreiben
+ ELSE feldrest markiert neu schreiben
+ FI ;
+ WHILE postblanks > 0 CAND x cursor <= rand + laenge REP
+ out (blank); postblanks DECR 1
+ PER ; postblanks := 0 .
+
+feldrest unmarkiert neu schreiben :
+ schreibmarke positionieren (alte stelle);
+ out subtext mit randbehandlung (satz, alte stelle, stelle am ende) .
+
+feldrest markiert neu schreiben :
+ markierung verlaengern; out subtext mit randbehandlung
+ (satz, stelle, stelle am ende - 2 * marklength) .
+
+kommando annehmen und ausfuehren :
+ kommando annehmen; kommando ausfuehren .
+
+kommando annehmen :
+ getchar (zeichen); kommando zurueckweisen falls noetig .
+
+kommando zurueckweisen falls noetig :
+ IF NOT write access CAND zeichen ist druckbar
+ THEN benutzer warnen; kommando ignorieren
+ FI .
+
+benutzer warnen : out (piep) .
+
+kommando ignorieren :
+ zeichen := ""; LEAVE kommando annehmen und ausfuehren .
+
+kommando ausfuehren :
+ neue satzlaenge bestimmen;
+ alte stelle merken;
+ IF zeichen ist separator
+ THEN feldeditor verlassen
+ ELIF zeichen ist druckbar
+ THEN fortschreiben
+ ELSE funktionstasten behandeln
+ FI .
+
+neue satzlaenge bestimmen : INT VAR satzlaenge := LENGTH satz .
+
+feldeditor verlassen :
+ IF NOT absatzmarke steht THEN blanks abschneiden FI; (*sh*)
+ push (zeichen); LEAVE feld editieren .
+
+blanks abschneiden :
+ INT VAR letzte non blank pos := satzlaenge;
+ WHILE letzte non blank pos > 0 CAND (satz SUB letzte non blank pos) = blank REP
+ letzte non blank pos DECR 1
+ PER; satz := subtext (satz, 1, letzte non blank pos) .
+
+zeichen ist druckbar : zeichen >= blank .
+
+zeichen ist separator :
+ separator eingestellt CAND pos (separator, zeichen) > 0 .
+
+fortschreiben :
+ zeichen in satz eintragen;
+ IF is kanji esc (zeichen) THEN kanji zeichen schreiben FI;
+ bei erreichen von limit ueberlauf behandeln .
+
+zeichen in satz eintragen :
+ IF hinter dem satz
+ THEN satz mit leerzeichen auffuellen und zeichen anfuegen
+ ELIF einfuegen
+ THEN zeichen vor aktueller position einfuegen
+ ELSE altes zeichen ersetzen
+ FI .
+
+hinter dem satz : stelle > satzlaenge .
+
+satz mit leerzeichen auffuellen und zeichen anfuegen :
+ satz AUFFUELLENMIT blank;
+ zeichen anfuegen;
+ output mode := out zeichen .
+
+zeichen anfuegen : satz CAT zeichen; neue satzlaenge bestimmen .
+zeichen ignorieren : benutzer warnen; LEAVE kommando ausfuehren .
+
+zeichen vor aktueller position einfuegen :
+ insert char (satz, zeichen, stelle);
+ neue satzlaenge bestimmen;
+ output mode := out feldrest .
+
+altes zeichen ersetzen :
+ replace (satz, stelle, zeichen);
+ IF stelle auf erstem halbzeichen
+ THEN output mode := out feldrest; replace (satz, stelle + 1, blank)
+ ELSE output mode := out zeichen
+ FI .
+
+kanji zeichen schreiben :
+ alte stelle merken;
+ stelle INCR 1; getchar (zeichen);
+ IF zeichen < ""64"" THEN zeichen := ""64"" FI;
+ IF hinter dem satz
+ THEN zeichen anfuegen
+ ELIF einfuegen
+ THEN zeichen vor aktueller position einfuegen
+ ELSE replace (satz, stelle, zeichen)
+ FI ;
+ output mode := out feldrest .
+
+bei erreichen von limit ueberlauf behandeln : (*sh*)
+ IF satzlaenge kritisch
+ THEN in naechste zeile falls moeglich
+ ELSE stelle INCR 1
+ FI .
+
+satzlaenge kritisch :
+ IF stelle >= satzlaenge
+ THEN satzlaenge = limit
+ ELSE satzlaenge = limit + 1
+ FI .
+
+in naechste zeile falls moeglich :
+ IF fliesstext AND umbruch moeglich OR NOT fliesstext AND stelle >= satzlaenge
+ THEN in naechste zeile
+ ELSE stelle INCR 1
+ FI .
+
+umbruch moeglich :
+ INT CONST st := stelle; stelle := limit;
+ INT CONST ltzt wortanf := letzter wortanfang (satz);
+ stelle := st; einrueckposition (satz) < ltzt wortanf .
+
+in naechste zeile :
+ IF fliesstext
+ THEN ueberlauf und oder umbruch
+ ELSE ueberlauf ohne umbruch
+ FI .
+
+ueberlauf und oder umbruch :
+ INT VAR umbruchpos := 1;
+ umbruchposition bestimmen;
+ loeschposition bestimmen;
+ IF stelle = satzlaenge
+ THEN ueberlauf mit oder ohne umbruch
+ ELSE umbruch mit oder ohne ueberlauf
+ FI .
+
+umbruchposition bestimmen :
+ umbruchstelle := stelle;
+ stelle := satzlaenge;
+ umbruchpos := max (umbruchpos, letzter wortanfang (satz));
+ stelle := umbruchstelle .
+
+loeschposition bestimmen :
+ INT VAR loeschpos := umbruchpos;
+ WHILE davor noch blank REP loeschpos DECR 1 PER .
+
+davor noch blank :
+ loeschpos > ganz links CAND (satz SUB (loeschpos - 1)) = blank .
+
+ganz links : max (1, marke) .
+
+ueberlauf mit oder ohne umbruch :
+ IF zeichen = blank OR loeschpos = ganz links
+ THEN stelle := 1; ueberlauf ohne umbruch
+ ELSE ueberlauf mit umbruch
+ FI .
+
+ueberlauf ohne umbruch : push (cr) .
+
+ueberlauf mit umbruch :
+ ausgabe verhindern;
+ umbruchkommando aufbereiten;
+ auf loeschposition positionieren .
+
+umbruchkommando aufbereiten :
+ zeichen := hop + rubout + inscr;
+ satzrest := subtext (satz, umbruchpos);
+ zeichen CAT satzrest;
+ IF stelle ist im umgebrochenen teil
+ THEN insert char (zeichen, backcr, max (stelle - umbruchpos + 1, 0) + 4);
+ zeichen CAT backcr
+ FI ;
+ push (zeichen) .
+
+stelle ist im umgebrochenen teil : stelle >= loeschpos .
+
+auf loeschposition positionieren : stelle := loeschpos .
+
+umbruch mit oder ohne ueberlauf :
+ umbruchposition anpassen;
+ IF stelle ist im umgebrochenen teil
+ THEN umbruch mit ueberlauf
+ ELSE umbruch ohne ueberlauf
+ FI .
+
+umbruchposition anpassen :
+ IF zeichen = blank
+ THEN umbruchpos := stelle + 1;
+ umbruchposition bestimmen;
+ neue loeschposition bestimmen
+ FI .
+
+neue loeschposition bestimmen :
+ loeschpos := umbruchpos;
+ WHILE davor noch blank AND stelle noch nicht erreicht REP loeschpos DECR 1 PER .
+
+stelle noch nicht erreicht : loeschpos > stelle + 1 .
+
+umbruch mit ueberlauf : ueberlauf mit umbruch .
+
+umbruch ohne ueberlauf :
+ zeichen := inscr;
+ satzrest := subtext (satz, umbruchpos);
+ zeichen CAT satzrest;
+ zeichen CAT up char + backcr;
+ umbruchstelle INCR 1; umbruch verschoben := verschoben;
+ satz := subtext (satz, 1, loeschpos - 1);
+ schreibmarke positionieren (loeschpos); feldrest loeschen;
+ output mode := out feldrest;
+ push (zeichen) .
+
+funktionstasten behandeln :
+ SELECT pos (kommandos, zeichen) OF
+ CASE c hop : hop kommandos behandeln
+ CASE c esc : esc kommandos behandeln
+ CASE c right : nach rechts oder ueberlauf
+ CASE c left : wenn moeglich ein schritt nach links
+ CASE c tab : zur naechsten tabulator position
+ CASE c dezimal : dezimalen schreiben
+ CASE c rubin : einfuegen umschalten
+ CASE c rubout : ein zeichen loeschen
+ CASE c abscr, c inscr, c down : feldeditor verlassen
+ CASE c up : eine zeile nach oben (*sh*)
+ CASE c cr : ggf absatz erzeugen
+ CASE c mark : markieren umschalten
+ CASE c backcr : zurueck zur umbruchstelle
+ OTHERWISE : sondertaste behandeln
+ END SELECT .
+
+kommandos :
+ LET c hop = 1, c right = 2,
+ c up = 3, c left = 4,
+ c tab = 5, c down = 6,
+ c rubin = 7, c rubout = 8,
+ c cr = 9, c mark = 10,
+ c abscr = 11, c inscr = 12,
+ c dezimal = 13, c esc = 14,
+ c backcr = 15;
+
+ ""1""2""3""8""9""10""11""12""13""16""17""18""19""27""20"" .
+
+dezimalen schreiben : IF write access THEN dezimaleditor (satz) FI .
+
+zurueck zur umbruchstelle:
+ IF umbruch stelle > 0 THEN stelle := umbruch stelle FI;
+ IF verschoben <> umbruch verschoben
+ THEN verschoben := umbruch verschoben; output mode := out feld
+ FI .
+
+hop kommandos behandeln :
+ TEXT VAR zweites zeichen; getchar (zweites zeichen);
+ zeichen CAT zweites zeichen;
+ SELECT pos (hop kommandos, zweites zeichen) OF
+ CASE h hop : nach links oben
+ CASE h right : nach rechts blaettern
+ CASE h left : nach links blaettern
+ CASE h tab : tab position definieren oder loeschen
+ CASE h rubin : zeile splitten
+ CASE h rubout : loeschen oder rekombinieren
+ CASE h cr, h up, h down : feldeditor verlassen
+ OTHERWISE : zeichen ignorieren
+ END SELECT .
+
+hop kommandos :
+ LET h hop = 1, h right = 2,
+ h up = 3, h left = 4,
+ h tab = 5, h down = 6,
+ h rubin = 7, h rubout = 8,
+ h cr = 9;
+
+ ""1""2""3""8""9""10""11""12""13"" .
+
+nach links oben :
+ stelle := max (marke, anfang) + verschoben; feldeditor verlassen .
+
+nach rechts blaettern :
+ INT CONST rechter rand := stelle am ende - markierausgleich;
+ IF stelle ist am rechten rand
+ THEN stelle INCR laenge - 2 * markierausgleich + ausgleich fuer doppelzeichen
+ ELSE stelle := rechter rand
+ FI ;
+ IF satzlaenge <= limit THEN stelle := min (stelle, limit) FI;
+ alte einrueckposition mitziehen .
+
+stelle ist am rechten rand :
+ stelle auf erstem halbzeichen CAND stelle = rechter rand - 1
+ COR stelle = rechter rand .
+
+ausgleich fuer doppelzeichen : stelle - rechter rand .
+
+nach links blaettern :
+ INT CONST linker rand := stelle am anfang;
+ IF stelle = linker rand
+ THEN stelle DECR laenge - 2 * markierausgleich
+ ELSE stelle := linker rand
+ FI ;
+ stelle := max (ganz links, stelle);
+ alte einrueckposition mitziehen .
+
+tab position definieren oder loeschen :
+ IF stelle > LENGTH tabulator
+ THEN tabulator AUFFUELLENMIT right; tabulator CAT dach
+ ELSE replace (tabulator, stelle, neues tab zeichen)
+ FI ;
+ feldeditor verlassen .
+
+neues tab zeichen :
+ IF (tabulator SUB stelle) = right THEN dach ELSE right FI .
+
+zeile splitten :
+ IF write access THEN feldeditor verlassen ELSE zeichen ignorieren FI .
+
+loeschen oder rekombinieren :
+ IF NOT write access
+ THEN zeichen ignorieren
+ ELIF hinter dem satz
+ THEN zeilen rekombinieren
+ ELIF auf erstem zeichen
+ THEN ganze zeile loeschen
+ ELSE zeilenrest loeschen
+ FI .
+
+zeilen rekombinieren : feldeditor verlassen .
+auf erstem zeichen : stelle = 1 .
+ganze zeile loeschen : satz := ""; feldeditor verlassen .
+
+zeilenrest loeschen :
+ change (satz, stelle, satzlaenge, "");
+ output mode := clear feldrest .
+
+esc kommandos behandeln :
+ getchar (zweites zeichen);
+ zeichen CAT zweites zeichen;
+ auf exit pruefen;
+ SELECT pos (esc kommandos, zweites zeichen) OF
+ CASE e hop : lernmodus umschalten
+ CASE e right : zum naechsten wort
+ CASE e left : zum vorigen wort
+ OTHERWISE : belegte taste ausfuehren
+ END SELECT .
+
+auf exit pruefen :
+ IF pos (res, zweites zeichen) > 0 THEN feldeditor verlassen FI .
+
+esc kommandos :
+ LET e hop = 1,
+ e right = 2,
+ e left = 3;
+
+ ""1""2""8"" .
+
+lernmodus umschalten :
+ IF lernmodus THEN lernmodus ausschalten ELSE lernmodus einschalten FI;
+ feldeditor verlassen .
+
+lernmodus ausschalten :
+ lernmodus := FALSE;
+ belegbare taste erfragen;
+ audit := subtext (audit, 1, LENGTH audit - 2);
+ IF taste = hop
+ THEN (* lernsequenz nicht auf taste legen *) (* 16.08.85 -ws- *)
+ ELSE lernsequenz auf taste legen (taste, audit)
+ FI ;
+ audit := "" .
+
+belegbare taste erfragen :
+ TEXT VAR taste; getchar (taste);
+ WHILE taste ist reserviert REP
+ benutzer warnen; getchar (taste)
+ PER .
+
+taste ist reserviert : (* 16.08.85 -ws- *)
+ taste <> hop CAND pos (reservierte feldeditor tasten, taste) > 0 .
+
+lernmodus einschalten : audit := ""; lernmodus := TRUE .
+
+zum vorigen wort :
+ IF stelle > 1
+ THEN stelle DECR 1; stelle := letzter wortanfang (satz);
+ alte einrueckposition mitziehen;
+ IF (satz SUB stelle) <> blank THEN LEAVE zum vorigen wort FI
+ FI ;
+ feldeditor verlassen .
+
+zum naechsten wort :
+ IF kein naechstes wort THEN feldeditor verlassen FI .
+
+kein naechstes wort :
+ BOOL VAR im alten wort := TRUE;
+ INT VAR i;
+ FOR i FROM stelle UPTO satzlaenge REP
+ IF im alten wort
+ THEN im alten wort := (satz SUB i) <> blank
+ ELIF (satz SUB i) <> blank
+ THEN stelle := i; LEAVE kein naechstes wort WITH FALSE
+ FI
+ PER;
+ TRUE .
+
+belegte taste ausfuehren :
+ IF ist kommando taste
+ THEN feldeditor verlassen
+ ELSE gelerntes ausfuehren
+ FI .
+
+ist kommando taste : taste enthaelt kommando (zweites zeichen) .
+
+gelerntes ausfuehren :
+ push (lernsequenz auf taste (zweites zeichen)) . (*sh*)
+
+nach rechts oder ueberlauf :
+ IF fliesstext COR stelle < limit OR satzlaenge > limit
+ THEN nach rechts
+ ELSE auf anfang der naechsten zeile
+ FI .
+
+nach rechts :
+ IF stelle auf erstem halbzeichen THEN stelle INCR 2 ELSE stelle INCR 1 FI;
+ alte einrueckposition mitziehen .
+
+auf anfang der naechsten zeile : push (abscr) .
+
+nach links : stelle DECR 1; alte einrueckposition mitziehen .
+
+alte einrueckposition mitziehen :
+ IF satz ist leerzeile
+ THEN alte einrueckposition := stelle
+ ELSE alte einrueckposition := min (stelle, einrueckposition (satz))
+ FI .
+
+satz ist leerzeile :
+ satz = "" OR satz = blank .
+
+wenn moeglich ein schritt nach links :
+ IF stelle = ganz links
+ THEN zeichen ignorieren
+ ELSE nach links
+ FI .
+
+zur naechsten tabulator position :
+ bestimme naechste explizite tabulator position;
+ IF tabulator gefunden
+ THEN explizit tabulieren
+ ELIF stelle <= satzlaenge
+ THEN implizit tabulieren
+ ELSE auf anfang der naechsten zeile
+ FI .
+
+bestimme naechste explizite tabulator position :
+ INT VAR tab position := pos (tabulator, dach, stelle + 1);
+ IF tab position > limit AND satzlaenge <= limit
+ THEN tab position := 0
+ FI .
+
+tabulator gefunden : tab position <> 0 .
+
+explizit tabulieren : stelle := tab position; push (dezimal) .
+
+implizit tabulieren :
+ tab position := einrueckposition (satz);
+ IF stelle < tab position
+ THEN stelle := tab position
+ ELSE stelle := satzlaenge + 1
+ FI .
+
+einfuegen umschalten :
+ IF NOT write access THEN zeichen ignorieren FI; (*sh*)
+ einfuegen := NOT einfuegen;
+ IF einfuegen THEN einfuegen optisch anzeigen FI;
+ feldeditor verlassen .
+
+einfuegen optisch anzeigen :
+ IF markiert
+ THEN out (begin mark); markleft; out (dach left); warten;
+ out (end mark); markleft
+ ELSE out (dach left); warten;
+ IF stelle auf erstem halbzeichen
+ THEN out text (satz, stelle, stelle + 1)
+ ELSE out text (satz, stelle, stelle)
+ FI
+ FI .
+
+markiert : marke > 0 .
+dach left : ""94""8"" .
+
+warten :
+ TEXT VAR t := incharety (2);
+ kommando CAT t; IF lernmodus THEN audit CAT t FI .
+
+ein zeichen loeschen :
+ IF NOT write access THEN zeichen ignorieren FI; (*sh*)
+ IF zeichen davor soll geloescht werden
+ THEN nach links oder ignorieren
+ FI ;
+ IF NOT hinter dem satz THEN aktuelles zeichen loeschen FI .
+
+zeichen davor soll geloescht werden :
+ hinter dem satz COR markiert .
+
+nach links oder ignorieren :
+ IF stelle > ganz links
+ THEN nach links (*sh*)
+ ELSE zeichen ignorieren
+ FI .
+
+aktuelles zeichen loeschen :
+ stelle korrigieren; alte stelle merken;
+ IF stelle auf erstem halbzeichen
+ THEN delete char (satz, stelle);
+ postblanks INCR 1
+ FI ;
+ delete char (satz, stelle);
+ postblanks INCR 1;
+ neue satzlaenge bestimmen;
+ output mode := out feldrest .
+
+eine zeile nach oben : (*sh*)
+ IF NOT absatzmarke steht CAND NOT ist teil eines umbruchkommandos
+ THEN blanks abschneiden
+ FI ;
+ push (zeichen); LEAVE feld editieren .
+
+ist teil eines umbruchkommandos : (kommando SUB kommandozeiger) = backcr .
+
+ggf absatz erzeugen : (*sh*)
+ IF write access
+ THEN IF NOT absatzmarke steht THEN blanks abschneiden FI;
+ IF stelle > LENGTH satz AND fliesstext AND NOT absatzmarke steht
+ THEN satz CAT blank
+ FI
+ FI ; push (zeichen); LEAVE feld editieren .
+
+markieren umschalten :
+ IF markiert
+ THEN marke := 0; maxschreibpos INCR marklength; cpos DECR marklength
+ ELSE marke := stelle; maxschreibpos DECR marklength; cpos INCR marklength;
+ verschieben wenn erforderlich
+ FI ;
+ feldeditor verlassen .
+
+sondertaste behandeln : push (esc + zeichen) .
+END PROC feldeditor;
+
+PROC dezimaleditor (TEXT VAR satz) :
+ INT VAR dezimalanfang := stelle;
+ zeichen einlesen;
+ IF dezimalstartzeichen CAND ueberschreibbar THEN dezimalen schreiben FI;
+ push (zeichen) .
+
+zeichen einlesen : TEXT VAR zeichen; getchar (zeichen) .
+dezimalzeichen : pos (dezimalen, zeichen) > 0 AND nicht separator .
+dezimalstartzeichen : pos (startdezimalen, zeichen) > 0 AND nicht separator .
+dezimalen : "0123456789" .
+startdezimalen : "+-0123456789" .
+nicht separator : pos (separator, zeichen) = 0 .
+
+ueberschreibbar :
+ dezimalanfang > LENGTH satz OR
+ pos (ueberschreibbare zeichen, satz SUB dezimalanfang) > 0 .
+
+ueberschreibbare zeichen : " ,.+-0123456789" .
+
+dezimalen schreiben :
+ REP
+ dezimale in satz eintragen;
+ dezimalen zeigen;
+ zeichen einlesen;
+ dezimalanfang DECR 1
+ UNTIL dezimaleditor beendet PER;
+ stelle INCR 1 .
+
+dezimale in satz eintragen :
+ IF dezimalanfang > LENGTH satz
+ THEN satz AUFFUELLENMIT blank; satz CAT zeichen
+ ELSE delete char (satz, dezimalanfang); insert char (satz, zeichen, stelle)
+ FI .
+
+dezimalen zeigen :
+ INT VAR min dezimalschreibpos := max (min schreibpos, dezimalanfang);
+ IF markiert THEN markiert zeigen ELSE unmarkiert zeigen FI;
+ schreibmarke positionieren (stelle) .
+
+markiert : marke > 0 .
+
+markiert zeigen :
+ invers out (satz, min dezimalschreibpos, stelle, "", end mark);
+ out (zeichen) .
+
+unmarkiert zeigen :
+ schreibmarke positionieren (min dezimalschreibpos);
+ out subtext (satz, min dezimalschreibpos, stelle) .
+
+dezimaleditor beendet :
+ NOT dezimalzeichen OR
+ dezimalanfang < max (min schreibpos, marke) OR
+ NOT ueberschreibbar .
+END PROC dezimaleditor;
+
+BOOL PROC is editget :
+ editget modus
+END PROC is editget ;
+
+PROC get editline (TEXT VAR editline, INT VAR editpos, editmarke) :
+ IF editget modus
+ THEN editline := alter editsatz;
+ editpos := stelle
+ FI ;
+ editmarke := marke
+END PROC get editline;
+
+PROC put editline (TEXT CONST editline, INT CONST editpos, editmarke) :
+ IF editget modus
+ THEN alter editsatz := editline;
+ stelle := max (editpos, 1);
+ marke := max (editmarke, 0)
+ FI
+END PROC put editline;
+
+BOOL PROC within kanji (TEXT CONST satz, INT CONST stelle) :
+ count directly prefixing kanji esc bytes;
+ number of kanji esc bytes is odd .
+
+count directly prefixing kanji esc bytes :
+ INT VAR pos := stelle - 1, kanji esc bytes := 0;
+ WHILE pos > 0 CAND is kanji esc (satz SUB pos) REP
+ kanji esc bytes INCR 1; pos DECR 1
+ PER .
+
+number of kanji esc bytes is odd :
+ (kanji esc bytes AND 1) <> 0 .
+END PROC within kanji;
+
+BOOL PROC is kanji esc (TEXT CONST char) : (*sh*)
+ two byte mode CAND
+ (char >= ""129"" AND char <= ""159"" OR char >= ""224"" AND char <= ""239"")
+END PROC is kanji esc;
+
+BOOL PROC two bytes : two byte mode END PROC two bytes;
+
+PROC two bytes (BOOL CONST new mode) :
+ two byte mode := new mode
+END PROC two bytes;
+
+PROC outtext (TEXT CONST source, INT CONST from, to) :
+ out subtext mit randbehandlung (source, from, to);
+ INT VAR trailing;
+ IF from <= LENGTH source
+ THEN trailing := to - LENGTH source
+ ELSE trailing := to - from + 1
+ FI ; trailing TIMESOUT blank
+END PROC outtext;
+
+PROC out subtext mit randbehandlung (TEXT CONST satz, INT CONST von, bis) :
+ IF von > bis
+ THEN
+ ELIF bis >= LENGTH satz COR NOT within kanji (satz, bis + 1)
+ THEN out subtext mit anfangsbehandlung (satz, von, bis)
+ ELSE out subtext mit anfangsbehandlung (satz, von, bis - 1); out (blank)
+ FI
+END PROC out subtext mit randbehandlung;
+
+PROC out subtext mit anfangsbehandlung (TEXT CONST satz, INT CONST von, bis) :
+ IF von > bis
+ THEN
+ ELIF von = 1 COR NOT within kanji (satz, von)
+ THEN out subtext (satz, von, bis)
+ ELSE out (blank); out subtext (satz, von + 1, bis)
+ FI
+END PROC out subtext mit anfangsbehandlung;
+
+PROC get cursor : get cursor (spalte, zeile) END PROC get cursor;
+
+INT PROC x cursor : get cursor; spalte END PROC x cursor;
+
+BOOL PROC write permission : write access END PROC write permission;
+
+PROC push (TEXT CONST ausfuehrkommando) :
+ IF ausfuehrkommando = "" (*sh*)
+ THEN
+ ELIF kommando = ""
+ THEN kommando := ausfuehrkommando
+ ELIF (kommando SUB kommando zeiger - 1) = ausfuehrkommando
+ THEN kommando zeiger DECR 1
+ ELIF replace moeglich
+ THEN kommando zeiger DECR laenge des ausfuehrkommandos;
+ replace (kommando, kommando zeiger, ausfuehrkommando)
+ ELSE insert char (kommando, ausfuehrkommando, kommando zeiger)
+ FI .
+
+replace moeglich :
+ INT CONST laenge des ausfuehrkommandos := LENGTH ausfuehrkommando;
+ kommando zeiger > laenge des ausfuehrkommandos .
+END PROC push;
+
+PROC type (TEXT CONST ausfuehrkommando) :
+ kommando CAT ausfuehrkommando
+END PROC type;
+
+INT PROC stelle am anfang : anfang + verschoben END PROC stelle am anfang;
+
+INT PROC stelle am ende : stelle am anfang+laenge-1 END PROC stelle am ende;
+
+INT PROC markierausgleich : SIGN marke * marklength END PROC markierausgleich;
+
+PROC verschieben wenn erforderlich :
+ IF stelle > max schreibpos
+ THEN verschiebe (stelle - max schreibpos)
+ ELIF stelle < min schreibpos
+ THEN verschiebe (stelle - min schreibpos)
+ FI
+END PROC verschieben wenn erforderlich;
+
+PROC verschiebe (INT CONST i) :
+ verschoben INCR i;
+ min schreibpos INCR i;
+ max schreibpos INCR i;
+ cpos DECR i;
+ output mode := out feld;
+ schreibmarke positionieren (stelle) (* 11.05.85 -ws- *)
+END PROC verschiebe;
+
+PROC konstanten neu berechnen :
+ min schreibpos := anfang + verschoben;
+ IF min schreibpos < 0 (* 17.05.85 -ws- *)
+ THEN min schreibpos DECR verschoben; verschoben := 0
+ FI ;
+ max schreibpos := min schreibpos + laenge - 1 - markierausgleich;
+ cpos := rand + laenge - max schreibpos
+END PROC konstanten neu berechnen;
+
+PROC schreibmarke positionieren (INT CONST sstelle) :
+ cursor (cpos + sstelle, zeile)
+END PROC schreibmarke positionieren;
+
+PROC simple feldout (TEXT CONST satz, INT CONST dummy) :
+ (* PRECONDITION : NOT markiert AND verschoben = 0 *)
+ (* AND feldrest schon geloescht *)
+ schreibmarke an feldanfang positionieren;
+ out subtext mit randbehandlung (satz, anfang, anfang + laenge - 1);
+ IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI .
+
+schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) .
+END PROC simple feldout;
+
+PROC feldout (TEXT CONST satz, INT CONST sstelle) :
+ schreibmarke an feldanfang positionieren;
+ feld ausgeben;
+ feldrest loeschen;
+ IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI .
+
+schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) .
+
+feld ausgeben :
+ INT VAR von := anfang + verschoben, bis := von + laenge - 1;
+ IF nicht markiert
+ THEN unmarkiert ausgeben
+ ELIF markiertes nicht sichtbar
+ THEN unmarkiert ausgeben
+ ELSE markiert ausgeben
+ FI .
+
+nicht markiert : marke <= 0 .
+
+markiertes nicht sichtbar :
+ bis DECR marklength * (1 + SIGN sstelle); marke > bis + 1 .
+
+unmarkiert ausgeben :
+ out subtext mit randbehandlung (satz, von, bis) .
+
+markiert ausgeben :
+ INT VAR smarke := max (von, marke);
+ out text (satz, von, smarke - 1); out (begin mark);
+ verschiedene feldout modes behandeln .
+
+verschiedene feldout modes behandeln :
+ IF sstelle = 0
+ THEN out subtext mit randbehandlung (satz, smarke, bis); out (end mark)
+ ELSE out text (satz, smarke, zeilenrand); out (end mark); (*sh*)
+ out subtext mit randbehandlung (satz, sstelle, bis)
+ FI .
+
+zeilenrand : min (bis, sstelle - 1) .
+END PROC feldout;
+
+PROC absatzmarke schreiben (BOOL CONST schreiben) :
+ IF fliesstext AND nicht markiert
+ THEN cursor (rand + 1 + laenge, zeile);
+ out (absatzmarke) ;
+ absatzmarke steht := TRUE
+ FI .
+
+nicht markiert : marke <= 0 .
+
+absatzmarke :
+ IF NOT schreiben
+ THEN " "
+ ELIF marklength > 0
+ THEN ""15""14""
+ ELSE ""15" "14" "
+ FI .
+END PROC absatzmarke schreiben;
+
+PROC invers out (TEXT CONST satz, INT CONST von, bis, TEXT CONST pre, post) :
+ IF mark refresh line mode
+ THEN feldout (satz, stelle)
+ ELSE schreibmarke positionieren (von);
+ out (begin mark); markleft; out (pre);
+ out text (satz, von, bis - 1); out (post)
+ FI .
+
+markleft :
+ marklength TIMESOUT left .
+
+END PROC invers out;
+
+PROC feldrest loeschen :
+ IF rand + laenge < maxbreite COR invertierte darstellung
+ THEN INT VAR x; get cursor (x, zeile);
+ (rand + laenge - x + 1 + absatz ausgleich) TIMESOUT blank; (*sh*)
+ cursor (x, zeile)
+ ELSE out (clear eol); absatzmarke steht := FALSE
+ FI
+END PROC feldrest loeschen;
+
+OP AUFFUELLENMIT (TEXT VAR satz, TEXT CONST fuellzeichen) :
+ INT VAR i;
+ FOR i FROM stelle - LENGTH satz DOWNTO 2 REP
+ satz CAT fuellzeichen
+ PER
+END OP AUFFUELLENMIT;
+
+INT PROC einrueckposition (TEXT CONST satz) : (*sh*)
+ IF fliesstext AND satz = blank
+ THEN anfang
+ ELSE max (pos (satz, ""33"", ""254"", 1), 1)
+ FI
+END PROC einrueckposition;
+
+INT PROC letzter wortanfang (TEXT CONST satz) : (*sh*)
+ INT CONST ganz links := max (1, marke);
+ BOOL VAR noch nicht im neuen wort := TRUE;
+ INT VAR i;
+ FOR i FROM stelle DOWNTO ganz links REP
+ IF noch nicht im neuen wort
+ THEN noch nicht im neuen wort := char = blank
+ ELIF is kanji esc (char)
+ THEN LEAVE letzter wortanfang WITH i
+ ELIF nicht mehr im neuen wort
+ THEN LEAVE letzter wortanfang WITH i + 1
+ FI
+ PER ;
+ ganz links .
+
+char : satz SUB i .
+
+nicht mehr im neuen wort : char = blank COR within kanji (satz, i) .
+END PROC letzter wortanfang;
+
+PROC getchar (TEXT VAR zeichen) :
+ IF kommando = ""
+ THEN inchar (zeichen); IF lernmodus THEN audit CAT zeichen FI
+ ELSE zeichen := kommando SUB kommando zeiger;
+ kommando zeiger INCR 1;
+ IF kommando zeiger > LENGTH kommando
+ THEN kommando zeiger := 1; kommando := ""
+ FI ;
+ IF LENGTH kommando - kommando zeiger < 3
+ THEN kommando CAT inchety
+ FI
+ FI .
+END PROC getchar;
+
+TEXT PROC inchety :
+ IF lernmodus
+ THEN TEXT VAR t := incharety; audit CAT t; t
+ ELSE incharety
+ FI
+END PROC inchety;
+
+BOOL PROC is incharety (TEXT CONST muster) :
+ IF kommando = ""
+ THEN TEXT CONST t := inchety;
+ IF t = muster THEN TRUE ELSE kommando := t; FALSE FI
+ ELIF (kommando SUB kommando zeiger) = muster
+ THEN kommando zeiger INCR 1;
+ IF kommando zeiger > LENGTH kommando
+ THEN kommando zeiger := 1; kommando := ""
+ FI ;
+ TRUE
+ ELSE FALSE
+ FI
+END PROC is incharety;
+
+TEXT PROC getcharety :
+ IF kommando = ""
+ THEN inchety
+ ELSE TEXT CONST t := kommando SUB kommando zeiger;
+ kommando zeiger INCR 1;
+ IF kommando zeiger > LENGTH kommando
+ THEN kommando zeiger := 1; kommando := ""
+ FI ; t
+ FI
+END PROC getcharety;
+
+PROC get editcursor (INT VAR x, y) : (*sh*)
+ IF actual editor > 0 THEN aktualisiere bildparameter FI;
+ x := rand - (anfang + verschoben - 1 - markierausgleich) + stelle;
+ y := zeile .
+
+ aktualisiere bildparameter :
+ INT VAR old x, old y; get cursor (old x, old y);
+ dateizustand holen; bildausgabe steuern; satznr zeigen;
+ fenster zeigen; zeile := bildrand + zeilennr; cursor (old x, old y) .
+END PROC get editcursor;
+
+(************************* Zugriff auf Feldstatus *************************).
+
+stelle : feldstatus.stelle .
+alte stelle : feldstatus.alte stelle .
+rand : feldstatus.rand .
+limit : feldstatus.limit .
+anfang : feldstatus.anfang .
+marke : feldstatus.marke .
+laenge : feldstatus.laenge .
+verschoben : feldstatus.verschoben .
+einfuegen : feldstatus.einfuegen .
+fliesstext : feldstatus.fliesstext .
+write access : feldstatus.write access .
+tabulator : feldstatus.tabulator .
+
+(***************************************************************************)
+
+LET undefinierter bereich = 0, nix = 1,
+ bildzeile = 2, akt satznr = 2,
+ abschnitt = 3, ueberschrift = 3,
+ bild = 4, fehlermeldung = 4;
+
+LET BILDSTATUS = STRUCT (INT feldlaenge, kurze feldlaenge,
+ bildrand, bildlaenge, kurze bildlaenge,
+ ueberschriftbereich, bildbereich,
+ erster neusatz, letzter neusatz,
+ old zeilennr, old lineno, old mark lineno,
+ BOOL zeileneinfuegen, old line update,
+ TEXT satznr pre, ueberschrift pre,
+ ueberschrift text, ueberschrift post, old satz,
+ FRANGE old range,
+ FILE file),
+ EDITSTATUS = STRUCT (FELDSTATUS feldstatus, BILDSTATUS bildstatus),
+ max editor = 10,
+ EDITSTACK = ROW max editor EDITSTATUS;
+
+BILDSTATUS VAR bildstatus ;
+EDITSTACK VAR editstack;
+
+ROW max editor INT VAR einrueckstack;
+
+BOOL VAR markiert;
+TEXT VAR filename, tab, bildsatz, bildzeichen, fehlertext,
+ akt bildsatz ;
+INT VAR zeilennr, satznr, bildanfang, bildmarke, feldmarke,
+ actual editor := 0, max used editor := 0,
+ letzer editor auf dieser datei,
+ alte einrueckposition := 1;
+
+INT PROC aktueller editor : actual editor END PROC aktueller editor;
+
+INT PROC groesster editor : max used editor END PROC groesster editor;
+
+(****************************** bildeditor *******************************)
+
+PROC bildeditor (TEXT CONST res, PROC (TEXT CONST) kommando interpreter) :
+ evtl fehler behandeln;
+ enable stop;
+ TEXT VAR reservierte tasten := ""11""12""27"bf" ;
+ reservierte tasten CAT res ;
+ INT CONST my highest editor := max used editor;
+ laenge := feldlaenge;
+ konstanten neu berechnen;
+ REP
+ markierung justieren;
+ altes feld nachbereiten;
+ feldlaenge einstellen;
+ ueberschrift zeigen;
+ fenster zeigen ;
+ zeile bereitstellen;
+ zeile editieren;
+ kommando ausfuehren
+ PER .
+
+evtl fehler behandeln :
+ IF is error
+ THEN fehlertext := errormessage;
+ IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI;
+ clear error
+ ELSE fehlertext := ""
+ FI .
+
+markierung justieren :
+ IF bildmarke > 0
+ THEN IF satznr <= bildmarke
+ THEN bildmarke := satznr;
+ stelle := max (stelle, feldmarke);
+ marke := feldmarke
+ ELSE marke := 1
+ FI
+ FI .
+
+zeile bereitstellen : IF hinter letztem satz THEN insert record (file) FI .
+hinter letztem satz : lineno (file) > lines (file) .
+
+altes feld nachbereiten :
+ IF old line update AND lineno (file) <> old lineno
+ THEN IF verschoben <> 0
+ THEN verschoben := 0; konstanten neu berechnen;
+ FI ;
+ INT CONST alte zeilennr := old lineno - bildanfang + 1;
+ IF alte zeilennr > 0 AND alte zeilennr <= aktuelle bildlaenge
+ THEN INT CONST m := marke;
+ IF lineno (file) < old lineno
+ THEN marke := 0
+ ELIF old lineno = bildmarke
+ THEN marke := min (feldmarke, LENGTH old satz + 1)
+ ELSE marke := min (marke, LENGTH old satz + 1)
+ FI ;
+ zeile := bildrand + alte zeilennr;
+ feldout (old satz, 0); marke := m
+ FI
+ FI ;
+ old line update := FALSE; old satz := "" .
+
+feldlaenge einstellen :
+ INT CONST alte laenge := laenge;
+ IF zeilennr > kurze bildlaenge
+ THEN laenge := kurze feldlaenge
+ ELSE laenge := feldlaenge
+ FI ;
+ IF laenge <> alte laenge
+ THEN konstanten neu berechnen
+ FI .
+
+zeile editieren :
+ zeile := bildrand + zeilennr;
+ exec (PROC (TEXT VAR, TEXT CONST) feldeditor, file, reservierte tasten);
+ old lineno := satznr;
+ IF markiert oder verschoben
+ THEN old line update := TRUE; read record (file, old satz)
+ FI .
+
+markiert oder verschoben : markiert COR verschoben <> 0 .
+
+kommando ausfuehren :
+ getchar (bildzeichen);
+ SELECT pos (kommandos, bildzeichen) OF
+ CASE x hop : hop kommando verarbeiten
+ CASE x esc : esc kommando verarbeiten
+ CASE x up : zum vorigen satz
+ CASE x down : zum folgenden satz
+ CASE x rubin : zeicheneinfuegen umschalten
+ CASE x mark : markierung umschalten
+ CASE x cr : eingerueckt mit cr (* 08.06.85 -ws- *)
+ CASE x inscr : eingerueckt zum folgenden satz
+ CASE x abscr : zum anfang des folgenden satzes
+ END SELECT .
+
+kommandos :
+ LET x hop = 1, x up = 2,
+ x down = 3, x rubin = 4,
+ x cr = 5, x mark = 6,
+ x abscr = 7, x inscr = 8,
+ x esc = 9;
+
+ ""1""3""10""11""13""16""17""18""27"" .
+
+zeicheneinfuegen umschalten :
+ rubin segment in ueberschrift eintragen;
+ neu (ueberschrift, nix) .
+
+rubin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 9, rubin segment) .
+
+rubin segment :
+ IF einfuegen THEN "RUBIN" ELSE "....." FI .
+
+hop kommando verarbeiten :
+ getchar (bildzeichen);
+ read record (file, bildsatz);
+ SELECT pos (hop kommandos, bildzeichen) OF
+ CASE y hop : nach oben
+ CASE y cr : neue seite
+ CASE y up : zurueckblaettern
+ CASE y down : weiterblaettern
+ CASE y tab : put tabs (file, tabulator); neu (ueberschrift, nix)
+ CASE y rubout : zeile loeschen
+ CASE y rubin : zeileneinfuegen umschalten
+ END SELECT .
+
+hop kommandos :
+ LET y hop = 1, y up = 2,
+ y tab = 3, y down = 4,
+ y rubin = 5, y rubout = 6,
+ y cr = 7;
+
+ ""1""3""9""10""11""12""13"" .
+
+zeileneinfuegen umschalten :
+ zeileneinfuegen := NOT zeileneinfuegen;
+ IF zeileneinfuegen
+ THEN zeile aufspalten; logisches eof setzen
+ ELSE leere zeile am ende loeschen; logisches eof loeschen
+ FI ; restbild zeigen .
+
+zeile aufspalten :
+ IF stelle <= LENGTH bildsatz OR stelle = 1
+ THEN loesche ggf trennende blanks und spalte zeile
+ FI .
+
+loesche ggf trennende blanks und spalte zeile: (* 26.06.84 -bk- *)
+ INT VAR first non blank pos := stelle;
+ WHILE first non blank pos <= length (bildsatz) CAND
+ (bildsatz SUB first non blank pos) = blank REP
+ first non blank pos INCR 1
+ PER ;
+ split line and indentation; (*sh*)
+ first non blank pos := stelle - 1;
+ WHILE first non blank pos >= 1 CAND
+ (bildsatz SUB first non blank pos) = blank REP
+ first non blank pos DECR 1
+ PER;
+ bildsatz := subtext (bildsatz, 1, first non blank pos);
+ write record (file, bildsatz) .
+
+split line and indentation :
+ split line (file, first non blank pos, TRUE) .
+
+logisches eof setzen :
+ down (file); col (file, 1);
+ set range (file, 1, 1, old range); up (file) .
+
+leere zeile am ende loeschen :
+ to line (file, lines (file));
+ IF len (file) = 0 THEN delete record (file) FI;
+ to line (file, satznr) .
+
+logisches eof loeschen :
+ col (file, stelle); set range (file, old range) .
+
+restbild zeigen :
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ rest segment in ueberschrift eintragen;
+ neu (ueberschrift, abschnitt) .
+
+rest segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 25, rest segment) .
+
+rest segment :
+ IF zeileneinfuegen THEN "REST" ELSE "...." FI .
+
+esc kommando verarbeiten :
+ getchar (bildzeichen);
+ eventuell zeichen zurueckweisen; (* 04.05.85 -ws- *)
+ IF taste ist reserviert
+ THEN belegte taste ausfuehren
+ ELSE fest vordefinierte esc funktion
+ FI ; ende nach quit .
+
+eventuell zeichen zurueckweisen : (* 04.05.85 -ws- *)
+ IF NOT write access CAND NOT erlaubte taste
+ THEN benutzer warnen; LEAVE kommando ausfuehren
+ FI .
+
+erlaubte taste : pos (zulaessige zeichen, bildzeichen) > 0 .
+zulaessige zeichen : res + ""1""2""8""27"bfq" .
+benutzer warnen : out (piep) .
+
+ende nach quit :
+ IF max used editor < my highest editor THEN LEAVE bildeditor FI .
+
+taste ist reserviert : pos (res, bildzeichen) > 0 .
+
+fest vordefinierte esc funktion :
+ read record (file, bildsatz);
+ SELECT pos (esc kommandos, bildzeichen) OF
+ CASE z hop : lernmodus umschalten
+ CASE z esc : kommandodialog versuchen
+ CASE z left : zum vorigen wort
+ CASE z right : zum naechsten wort
+ CASE z b : bild an aktuelle zeile angleichen
+ CASE z f : belegte taste ausfuehren
+ CASE z rubout : markiertes vorsichtig loeschen
+ CASE z rubin : vorsichtig geloeschtes einfuegen
+ OTHERWISE : belegte taste ausfuehren
+ END SELECT .
+
+esc kommandos :
+ LET z hop = 1, z right = 2,
+ z left = 3, z rubin = 4,
+ z rubout = 5, z esc = 6,
+ z b = 7, z f = 8;
+
+ ""1""2""8""11""12""27"bf" .
+
+zum vorigen wort :
+ IF vorgaenger erlaubt
+ THEN vorgaenger; read record (file, bildsatz);
+ stelle := LENGTH bildsatz + 1; push (esc + left)
+ FI .
+
+vorgaenger erlaubt :
+ satznr > max (1, bildmarke) .
+
+zum naechsten wort :
+ IF nicht auf letztem satz THEN weitersuchen wenn nicht gefunden FI .
+
+nicht auf letztem satz : line no (file) < lines (file) .
+
+weitersuchen wenn nicht gefunden :
+ nachfolgenden satz holen;
+ IF (nachfolgender satz SUB anfang) = blank
+ THEN push (abscr + esc + right)
+ ELSE push (abscr)
+ FI .
+
+nachfolgenden satz holen :
+ down (file); read record (file, nachfolgender satz); up (file) .
+
+bild an aktuelle zeile angleichen :
+ anfang INCR verschoben; verschoben := 0;
+ margin segment in ueberschrift eintragen;
+ neu (ueberschrift, bild) .
+
+margin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 2, margin segment) .
+
+margin segment :
+ IF anfang <= 1
+ THEN "......"
+ ELSE TEXT VAR margin text := "M" + text (anfang);
+ (6 - LENGTH margin text) * "." + margin text
+ FI .
+
+belegte taste ausfuehren :
+ kommando analysieren (bildzeichen, PROC(TEXT CONST) kommando interpreter) .
+
+kommandodialog versuchen:
+ IF fenster ist zu schmal fuer dialog
+ THEN kommandodialog ablehnen
+ ELSE kommandodialog fuehren
+ FI .
+
+fenster ist zu schmal fuer dialog : laenge < 20 .
+
+kommandodialog ablehnen :
+ fehlertext := "zu schmal fuer ESC ESC"; neu (fehlermeldung, nix) .
+
+kommandodialog fuehren:
+ INT VAR x0, x1, x2, x3, y;
+ get cursor (x0, y);
+ cursor (rand + 1, bildrand + zeilennr);
+ get cursor (x1, y);
+ out (begin mark); out (monitor meldung);
+ get cursor (x2, y);
+ (laenge - LENGTH monitor meldung - marklength) TIMESOUT blank;
+ get cursor (x3, y);
+ out (end mark); out (blank);
+ kommandozeile editieren;
+ ueberschrift zeigen;
+ absatz ausgleich := 2; (*sh*)
+ IF kommandotext = "" THEN LEAVE kommandodialog fuehren FI;
+ kommando auf taste legen ("f", kommandotext);
+ kommando analysieren ("f", PROC(TEXT CONST) kommando interpreter);
+ IF fehlertext <> ""
+ THEN push (esc + esc + esc + "k")
+ ELIF markiert
+ THEN zeile neu
+ FI .
+
+kommandozeile editieren :
+ TEXT VAR kommandotext := "";
+ cursor (x1, y); out (begin mark);
+ disable stop;
+ darstellung invertieren;
+ editget schleife;
+ darstellung invertieren;
+ enable stop;
+ cursor (x3, y); out (end mark);
+ exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle);
+ cursor (x0, y) .
+
+darstellung invertieren :
+ TEXT VAR dummy := begin mark; begin mark := end mark; end mark := dummy;
+ invertierte darstellung := NOT invertierte darstellung .
+
+editget schleife :
+ TEXT VAR exit char;
+ REP
+ cursor (x2, y);
+ editget (kommandotext, max textlength, rand + laenge - x cursor,
+ "", "k?!", exit char);
+ neu (ueberschrift, nix);
+ IF exit char = ""27"k"
+ THEN kommando text := kommando auf taste ("f")
+ ELIF exit char = ""27"?"
+ THEN TEXT VAR taste; getchar (taste);
+ kommando text := kommando auf taste (taste)
+ ELIF exit char = ""27"!"
+ THEN getchar (taste);
+ IF ist reservierte taste
+ THEN set busy indicator; (*sh*)
+ out ("FEHLER: """ + taste + """ ist reserviert"7"")
+ ELSE kommando auf taste legen (taste, kommandotext);
+ kommandotext := ""; LEAVE editget schleife
+ FI
+ ELSE LEAVE editget schleife
+ FI
+ PER .
+
+ist reservierte taste : pos (res, taste) > 0 .
+monitor meldung : "gib kommando : " .
+
+neue seite : bildanfang := satznr; zeilennr := 1; neu (akt satznr, bild) .
+
+weiterblaettern :
+ INT CONST akt bildlaenge := aktuelle bildlaenge;
+ IF nicht auf letztem satz
+ THEN erster neusatz := satznr;
+ IF zeilennr >= akt bildlaenge
+ THEN bildanfang INCR akt bildlaenge; neu (akt satznr, bild)
+ FI ;
+ satznr := min (lines (file), bildanfang + akt bildlaenge - 1);
+ letzter neusatz := satznr;
+ toline (file, satznr);
+ stelle DECR verschoben;
+ neu (akt satznr, nix);
+ zeilennr := satznr - bildanfang + 1;
+ IF markiert THEN neu (nix, abschnitt) FI;
+ einrueckposition bestimmen
+ FI .
+
+zurueckblaettern :
+ IF vorgaenger erlaubt
+ THEN IF zeilennr <= 1
+ THEN bildanfang := max (1, bildanfang - aktuelle bildlaenge);
+ neu (akt satznr, bild)
+ FI ;
+ nach oben; einrueckposition bestimmen
+ FI .
+
+zeile loeschen :
+ IF stelle = 1
+ THEN delete record (file);
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ neu (nix, abschnitt)
+ ELSE zeilen rekombinieren
+ FI .
+
+zeilen rekombinieren :
+ IF nicht auf letztem satz
+ THEN aktuellen satz mit blanks auffuellen;
+ delete record (file);
+ nachfolgenden satz lesen;
+ bildsatz CAT nachfolgender satz ohne fuehrende blanks;
+ write record (file, bildsatz);
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ neu (nix, abschnitt)
+ FI .
+
+aktuellen satz mit blanks auffuellen :
+ bildsatz AUFFUELLENMIT blank .
+
+nachfolgenden satz lesen :
+ TEXT VAR nachfolgender satz;
+ read record (file, nachfolgender satz) .
+
+nachfolgender satz ohne fuehrende blanks :
+ satzrest := subtext (nachfolgender satz,
+ einrueckposition (nachfolgender satz)); satzrest .
+
+zeile aufsplitten :
+ nachfolgender satz := "";
+ INT VAR i;
+ FOR i FROM 2 UPTO min (stelle, einrueckposition (bildsatz)) REP
+ nachfolgender satz CAT blank
+ PER;
+ satzrest := subtext (bildsatz, naechste non blank position);
+ nachfolgender satz CAT satzrest;
+ bildsatz := subtext (bildsatz, 1, stelle - 1);
+ write record (file, bildsatz);
+ down (file); insert record (file);
+ write record (file, nachfolgender satz); up (file) .
+
+naechste non blank position :
+ INT VAR non blank pos := stelle;
+ WHILE (bildsatz SUB non blank pos) = blank REP
+ non blank pos INCR 1
+ PER; non blank pos .
+
+zum vorigen satz :
+ IF vorgaenger erlaubt THEN vorgaenger; einrueckposition bestimmen FI .
+
+zum folgenden satz : (* 12.09.85 -ws- *)
+ IF nachfolger erlaubt THEN nachfolger; einrueckposition bestimmen
+ ELSE col (file, len (file) + 1); neu (nix, nix)
+ FI .
+
+einrueckposition bestimmen : (* 27.08.85 -ws- *)
+ read record (file, akt bildsatz);
+ INT VAR neue einrueckposition := einrueckposition (akt bildsatz);
+ IF akt bildsatz ist leerzeile
+ THEN alte einrueckposition := max (stelle, neue einrueckposition)
+ ELSE alte einrueckposition := min (stelle, neue einrueckposition)
+ FI .
+
+akt bildsatz ist leerzeile :
+ akt bildsatz = "" OR akt bildsatz = blank .
+
+zum anfang des folgenden satzes :
+ IF nachfolger erlaubt THEN nachfolger; stelle := anfang FI .
+
+nachfolger erlaubt :
+ write access COR nicht auf letztem satz .
+
+eingerueckt mit cr :
+ IF NOT nachfolger erlaubt THEN LEAVE eingerueckt mit cr FI; (*sh*)
+ read record (file, bildsatz);
+ INT VAR epos := einrueckposition (bildsatz);
+ nachfolger; col (file, 1);
+ IF eof (file)
+ THEN IF LENGTH bildsatz <= epos
+ THEN stelle := alte einrueckposition
+ ELSE stelle := epos
+ FI
+ ELSE read record (file, bildsatz);
+ stelle := einrueckposition (bildsatz);
+ IF bildsatz ist leerzeile (* 29.08.85 -ws- *)
+ THEN stelle := alte einrueckposition;
+ aktuellen satz mit blanks auffuellen
+ FI
+ FI ;
+ alte einrueckposition := stelle .
+
+bildsatz ist leerzeile :
+ bildsatz = "" OR bildsatz = blank .
+
+eingerueckt zum folgenden satz : (*sh*)
+ IF NOT nachfolger erlaubt OR NOT write access
+ THEN LEAVE eingerueckt zum folgenden satz
+ FI;
+ alte einrueckposition merken;
+ naechsten satz holen;
+ neue einrueckposition bestimmen;
+ alte einrueckposition := stelle .
+
+alte einrueckposition merken :
+ read record (file, bildsatz);
+ epos := einrueckposition (bildsatz);
+ auf aufzaehlung pruefen;
+ IF epos > LENGTH bildsatz THEN epos := anfang FI.
+
+auf aufzaehlung pruefen :
+ BOOL CONST aufzaehlung gefunden :=
+ ist aufzaehlung CAND vorher absatzzeile CAND wort folgt;
+ IF aufzaehlung gefunden THEN epos := anfang des naechsten wortes FI .
+
+ist aufzaehlung :
+ INT CONST wortende := pos (bildsatz, blank, epos, epos + 20) - 1;
+ SELECT pos ("-*).:" , bildsatz SUB wortende) OF
+ CASE 1,2 : wortende = epos
+ CASE 3,4 : wortende <= epos + 7
+ CASE 5 : TRUE
+ OTHERWISE: FALSE
+ ENDSELECT .
+
+vorher absatzzeile :
+ IF satznr = 1
+ THEN TRUE
+ ELSE up (file);
+ INT CONST vorige satzlaenge := len (file);
+ BOOL CONST vorher war absatzzeile :=
+ subtext (file, vorige satzlaenge, vorige satzlaenge) = blank;
+ down (file); vorher war absatzzeile
+ FI .
+
+wort folgt :
+ INT CONST anfang des naechsten wortes :=
+ pos (bildsatz, ""33"", ""254"", wortende + 1);
+ anfang des naechsten wortes > wortende .
+
+naechsten satz holen :
+ nachfolger; col (file, 1);
+ IF eof (file)
+ THEN bildsatz := ""
+ ELSE IF neue zeile einfuegen erforderlich
+ THEN insert record (file); bildsatz := "";
+ letzter neusatz := bildanfang + bildlaenge - 1
+ ELSE read record (file, bildsatz);
+ letzter neusatz := satznr;
+ ggf trennungen zurueckwandeln und umbruch indikator einfuegen
+ FI ;
+ erster neusatz := satznr;
+ neu (nix, abschnitt)
+ FI .
+
+neue zeile einfuegen erforderlich :
+ BOOL CONST war absatz := war absatzzeile;
+ war absatz COR neuer satz ist zu lang .
+
+war absatzzeile :
+ INT VAR wl := pos (kommando, up backcr, kommando zeiger);
+ wl = 0 COR (kommando SUB (wl - 1)) = blank .
+
+neuer satz ist zu lang : laenge des neuen satzes >= limit .
+
+laenge des neuen satzes :
+ IF len (file) > 0
+ THEN len (file) + wl
+ ELSE wl + epos
+ FI .
+
+up backcr : ""3""20"" .
+
+ggf trennungen zurueckwandeln und umbruch indikator einfuegen :
+ LET trenn k = ""220"",
+ trenn strich = ""221"";
+ TEXT VAR umbruch indikator;
+ IF letztes zeichen ist trenn strich
+ THEN entferne trenn strich;
+ IF letztes zeichen = trenn k
+ THEN wandle trenn k um
+ FI ;
+ umbruch indikator := up backcr
+ ELIF letztes umgebrochenes zeichen ist kanji
+ THEN umbruch indikator := up backcr
+ ELSE umbruch indikator := blank + up backcr
+ FI ;
+ change (kommando, wl, wl+1, umbruch indikator) .
+
+letztes umgebrochenes zeichen ist kanji : within kanji (kommando, wl-1) .
+
+letztes zeichen ist trenn strich :
+ TEXT CONST last char := letztes zeichen;
+ last char = trenn strich COR
+ last char = "-" CAND wl > 2 CAND (kommando SUB (wl-2)) <> blank .
+
+letztes zeichen : kommando SUB (wl-1) .
+entferne trenn strich : delete char (kommando, wl-1); wl DECR 1 .
+wandle trenn k um : replace (kommando, wl-1, "c") .
+loesche indikator : delete char (kommando, wl) .
+
+neue einrueckposition bestimmen :
+ IF aufzaehlung gefunden CAND bildsatz ist leerzeile
+ THEN stelle := epos
+ ELIF NOT bildsatz ist leerzeile
+ THEN stelle := einrueckposition (bildsatz)
+ ELIF war absatz COR auf letztem satz
+ THEN stelle := epos
+ ELSE down (file); read record (file, nachfolgender satz);
+ up (file); stelle := einrueckposition (nachfolgender satz)
+ FI ;
+ IF ist einfuegender aber nicht induzierter umbruch
+ THEN loesche indikator;
+ umbruchstelle := stelle + wl - kommando zeiger - anzahl der stz;
+ umbruchverschoben := 0
+ FI .
+
+auf letztem satz : NOT nicht auf letztem satz .
+
+ist einfuegender aber nicht induzierter umbruch :
+ wl := pos (kommando, backcr, kommando zeiger);
+ wl > 0 CAND (kommando SUB (wl - 1)) <> up char .
+
+anzahl der stz :
+ TEXT CONST umgebrochener anfang := subtext (kommando, kommando zeiger, wl-1);
+ INT VAR anz := 0, anf := pos (umgebrochener anfang, ""1"", ""31"", 1);
+ WHILE anf > 0 REP
+ anz INCR 1; anf := pos (umgebrochener anfang, ""1"", ""31"", anf + 1)
+ PER; anz .
+
+markiertes vorsichtig loeschen :
+ IF write access CAND markiert
+ THEN clear removed (file);
+ IF nur im satz markiert
+ THEN behandle einen satz
+ ELSE behandle mehrere saetze
+ FI
+ FI .
+
+nur im satz markiert : line no (file) = bildmarke .
+
+behandle einen satz :
+ insert record (file);
+ satzrest := subtext (bildsatz, marke, stelle - 1);
+ write record (file, satzrest);
+ remove (file, 1);
+ change (bildsatz, marke, stelle - 1, "");
+ stelle := marke;
+ marke := 0; bildmarke := 0; feldmarke := 0;
+ markiert := FALSE; mark (file, 0, 0);
+ konstanten neu berechnen;
+ IF bildsatz = ""
+ THEN delete record (file);
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ neu (nix, abschnitt)
+ ELSE write record (file, bildsatz);
+ neu (nix, bildzeile)
+ FI .
+
+behandle mehrere saetze :
+ erster neusatz := bildmarke;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ zeile an aktueller stelle auftrennen;
+ ersten markierten satz an markieranfang aufspalten;
+ markierten bereich entfernen;
+ bild anpassen .
+
+zeile an aktueller stelle auftrennen :
+ INT VAR markierte saetze := line no (file) - bildmarke + 1;
+ IF nicht am ende der zeile
+ THEN IF nicht am anfang der zeile
+ THEN zeile aufsplitten
+ ELSE up (file); markierte saetze DECR 1
+ FI
+ FI .
+
+nicht am anfang der zeile : stelle > 1 .
+nicht am ende der zeile : stelle <= LENGTH bildsatz .
+
+ersten markierten satz an markieranfang aufspalten :
+ to line (file, line no (file) - (markierte saetze - 1));
+ read record (file, bildsatz);
+ stelle := feldmarke;
+ IF nicht am anfang der zeile
+ THEN IF nicht am ende der zeile
+ THEN zeile aufsplitten
+ ELSE markierte saetze DECR 1
+ FI ;
+ to line (file, line no (file) + markierte saetze)
+ ELSE to line (file, line no (file) + markierte saetze - 1)
+ FI ;
+ read record (file, bildsatz) .
+
+markierten bereich entfernen :
+ zeilen nr := line no (file) - markierte saetze - bildanfang + 2;
+ remove (file, markierte saetze);
+ marke := 0; bildmarke := 0; feldmarke := 0;
+ markiert := FALSE; mark (file, 0, 0);
+ konstanten neu berechnen;
+ stelle := 1 .
+
+bild anpassen :
+ satz nr := line no (file);
+ IF zeilen nr <= 1
+ THEN bildanfang := line no (file); zeilen nr := 1;
+ neu (akt satznr, bild)
+ ELSE neu (akt satznr, abschnitt)
+ FI .
+
+vorsichtig geloeschtes einfuegen :
+ IF NOT write access OR removed lines (file) = 0
+ THEN LEAVE vorsichtig geloeschtes einfuegen
+ FI ;
+ IF nur ein satz
+ THEN in aktuellen satz einfuegen
+ ELSE aktuellen satz aufbrechen und einfuegen
+ FI .
+
+nur ein satz : removed lines (file) = 1 .
+
+in aktuellen satz einfuegen :
+ reinsert (file);
+ read record (file, nachfolgender satz);
+ delete record (file);
+ TEXT VAR t := bildsatz;
+ bildsatz := subtext (t, 1, stelle - 1);
+ aktuellen satz mit blanks auffuellen; (*sh*)
+ bildsatz CAT nachfolgender satz;
+ satzrest := subtext (t, stelle);
+ bildsatz CAT satzrest;
+ write record (file, bildsatz);
+ stelle INCR LENGTH nachfolgender satz;
+ neu (nix, bildzeile) .
+
+aktuellen satz aufbrechen und einfuegen :
+ INT CONST alter bildanfang := bildanfang;
+ old lineno := satznr;
+ IF stelle = 1
+ THEN reinsert (file);
+ read record (file, bildsatz)
+ ELIF stelle > LENGTH bildsatz
+ THEN down (file);
+ reinsert (file);
+ read record (file, bildsatz)
+ ELSE INT VAR von := stelle;
+ WHILE (bildsatz SUB von) = blank REP von INCR 1 PER;
+ satzrest := subtext (bildsatz, von, LENGTH bildsatz);
+ INT VAR bis := stelle - 1;
+ WHILE (bildsatz SUB bis) = blank REP bis DECR 1 PER;
+ bildsatz := subtext (bildsatz, 1, bis);
+ write record (file, bildsatz);
+ down (file);
+ reinsert (file);
+ read record (file, bildsatz);
+ nachfolgender satz := einrueckposition (bildsatz) * blank;
+ nachfolgender satz CAT satzrest;
+ down (file); insert record (file);
+ write record (file, nachfolgender satz); up (file)
+ FI ;
+ stelle := max (1, LENGTH bildsatz); (* 22.06.84 -bk- *)
+ satz nr := line no (file);
+ zeilennr INCR satznr - old lineno;
+ zeilennr := min (zeilennr, aktuelle bildlaenge);
+ bildanfang := satznr - zeilennr + 1;
+ IF bildanfang veraendert
+ THEN abschnitt neu (bildanfang, 9999)
+ ELSE abschnitt neu (old lineno, 9999)
+ FI ;
+ neu (akt satznr, nix).
+
+bildanfang veraendert : bildanfang <> alter bildanfang .
+
+lernmodus umschalten :
+ learn segment in ueberschrift eintragen; neu (ueberschrift, nix) .
+
+learn segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 19, learn segment) .
+
+learn segment :
+ IF lernmodus THEN "LEARN" ELSE "....." FI .
+
+markierung umschalten :
+ IF markiert THEN markierung ausschalten ELSE markierung einschalten FI .
+
+markierung einschalten :
+ bildmarke := satznr; feldmarke := marke; markiert := TRUE;
+ mark (file, bildmarke, feldmarke);
+ neu (nix, bildzeile) .
+
+markierung ausschalten :
+ erster neusatz := max (bildmarke, bildanfang);
+ letzter neusatz := satznr;
+ bildmarke := 0; feldmarke := 0; markiert := FALSE;
+ mark (file, 0, 0);
+ IF erster neusatz = letzter neusatz
+ THEN neu (nix, bildzeile)
+ ELSE neu (nix, abschnitt)
+ FI .
+END PROC bildeditor;
+
+PROC neu (INT CONST ue bereich, b bereich) :
+ ueberschriftbereich := max (ueberschriftbereich, ue bereich);
+ bildbereich := max (bildbereich, b bereich)
+END PROC neu;
+
+
+PROC nach oben :
+ letzter neusatz := satznr;
+ satznr := max (bildanfang, bildmarke);
+ toline (file, satznr);
+ stelle DECR verschoben;
+ zeilennr := satznr - bildanfang + 1;
+ erster neusatz := satznr;
+ IF markiert
+ THEN neu (akt satznr, abschnitt)
+ ELSE neu (akt satznr, nix)
+ FI
+END PROC nach oben;
+
+INT PROC aktuelle bildlaenge :
+ IF stelle - stelle am anfang < kurze feldlaenge
+ AND feldlaenge > 0
+ THEN bildlaenge (*wk*)
+ ELSE kurze bildlaenge
+ FI
+END PROC aktuelle bildlaenge;
+
+PROC vorgaenger :
+ up (file); satznr DECR 1;
+ marke := 0; stelle DECR verschoben;
+ IF zeilennr = 1
+ THEN bildanfang DECR 1; neu (ueberschrift, bild)
+ ELSE zeilennr DECR 1; neu (akt satznr, nix); (*sh*)
+ IF markiert THEN neu (nix, bildzeile) FI
+ FI
+END PROC vorgaenger;
+
+PROC nachfolger :
+ down (file); satznr INCR 1;
+ stelle DECR verschoben;
+ IF zeilennr = aktuelle bildlaenge
+ THEN bildanfang INCR 1;
+ IF rollup erlaubt
+ THEN rollup
+ ELSE neu (ueberschrift, bild)
+ FI
+ ELSE neu (akt satznr, nix); zeilennr INCR 1 (*sh*)
+ FI ;
+ IF markiert THEN neu (nix, bildzeile) FI .
+
+rollup erlaubt :
+ kurze bildlaenge = maxlaenge AND kurze feldlaenge = maxbreite .
+
+rollup :
+ out (down char);
+ IF bildzeichen = inscr
+ THEN neu (ueberschrift, nix)
+ ELIF is cr or down CAND (write access COR nicht auf letztem satz) (*sh*)
+ THEN neu (nix, bildzeile)
+ ELSE neu (ueberschrift, bildzeile)
+ FI .
+
+is cr or down :
+ IF kommando = "" THEN kommando := inchety FI;
+ kommando char = down char COR kommando char = cr .
+
+kommando char : kommando SUB kommando zeiger .
+
+nicht auf letztem satz : line no (file) < lines (file) .
+END PROC nachfolger;
+
+BOOL PROC next incharety is (TEXT CONST muster) :
+ INT CONST klen := LENGTH kommando - kommando zeiger + 1,
+ mlen := LENGTH muster;
+ INT VAR i; FOR i FROM 1 UPTO mlen - klen REP kommando CAT inchety PER;
+ subtext (kommando, kommando zeiger, kommando zeiger + mlen - 1) = muster
+END PROC next incharety is;
+
+PROC quit last: (* 22.06.84 -bk- *)
+ IF actual editor > 0 AND actual editor < max used editor
+ THEN verlasse alle groesseren editoren
+ FI .
+
+verlasse alle groesseren editoren :
+ open editor (actual editor + 1); quit .
+END PROC quit last;
+
+PROC quit :
+ IF actual editor > 0 THEN verlasse aktuellen editor FI .
+
+verlasse aktuellen editor :
+ disable stop;
+ INT CONST aktueller editor := actual editor;
+ in innersten editor gehen;
+ REP
+ IF zeileneinfuegen THEN hop rubin simulieren FI;
+ ggf bildschirmdarstellung korrigieren;
+ innersten editor schliessen
+ UNTIL aktueller editor > max used editor PER;
+ actual editor := max used editor .
+
+in innersten editor gehen : open editor (max used editor) .
+
+hop rubin simulieren :
+ zeileneinfuegen := FALSE;
+ leere zeilen am dateiende loeschen; (*sh*)
+ ggf bildschirmdarstellung korrigieren;
+ logisches eof loeschen .
+
+innersten editor schliessen :
+ max used editor DECR 1;
+ IF max used editor > 0
+ THEN open editor (max used editor);
+ bildeinschraenkung aufheben
+ FI .
+
+logisches eof loeschen :
+ col (file, stelle); set range (file, old range) .
+
+leere zeilen am dateiende loeschen : (* 15.08.85 -ws- *)
+ satz nr := line no (file) ;
+ to line (file, lines (file)) ;
+ WHILE lines (file) > 1 AND bildsatz ist leerzeile REP
+ delete record (file);
+ to line (file, lines (file))
+ PER;
+ toline (file, satznr) .
+
+bildsatz ist leerzeile :
+ TEXT VAR bildsatz;
+ read record (file, bildsatz);
+ ist leerzeile .
+
+ist leerzeile :
+ bildsatz = "" OR bildsatz = blank .
+
+ggf bildschirmdarstellung korrigieren :
+ satz nr DECR 1; (* für Bildschirmkorrektur *)
+ IF satznr > lines (file)
+ THEN zeilen nr DECR satz nr - lines (file);
+ satz nr := lines (file);
+ dateizustand retten
+ FI .
+
+bildeinschraenkung aufheben :
+ laenge := feldlaenge;
+ kurze feldlaenge := feldlaenge;
+ kurze bildlaenge := bildlaenge;
+ neu (nix, bild) .
+END PROC quit;
+
+PROC nichts neu : neu (nix, nix) END PROC nichts neu;
+
+PROC satznr neu : neu (akt satznr, nix) END PROC satznr neu;
+
+PROC ueberschrift neu : neu (ueberschrift, nix) END PROC ueberschrift neu;
+
+PROC zeile neu :
+ INT CONST zeile := line no (file);
+ abschnitt neu (zeile, zeile)
+END PROC zeile neu;
+
+PROC abschnitt neu (INT CONST von satznr, bis satznr) :
+ IF von satznr <= bis satznr
+ THEN erster neusatz := min (erster neusatz, von satznr);
+ letzter neusatz := max (letzter neusatz, bis satznr);
+ neu (nix, abschnitt)
+ ELSE abschnitt neu (bis satznr, von satznr)
+ FI
+END PROC abschnitt neu;
+
+PROC bildabschnitt neu (INT CONST von zeile, bis zeile) : (*sh*)
+ IF von zeile <= bis zeile
+ THEN erster neusatz := max (1, von zeile + bildanfang - 1);
+ letzter neusatz := min (bildlaenge, bis zeile + bildanfang - 1);
+ IF von zeile < 1
+ THEN neu (ueberschrift, abschnitt)
+ ELSE neu (nix , abschnitt)
+ FI
+ ELSE bildabschnitt neu (bis zeile, von zeile)
+ FI
+END PROC bildabschnitt neu;
+
+PROC bild neu : neu (nix, bild) END PROC bild neu; (*sh*)
+
+PROC bild neu (FILE VAR f) :
+ INT CONST editor no := abs (editinfo (f)) DIV 256;
+ IF editor no > 0 AND editor no <= max used editor
+ THEN IF editor no = actual editor
+ THEN bild neu
+ ELSE editstack (editor no).bildstatus.bildbereich := bild
+ FI
+ FI
+END PROC bild neu;
+
+PROC alles neu :
+ neu (ueberschrift, bild);
+ INT VAR i;
+ FOR i FROM 1 UPTO max used editor REP
+ editstack (i).bildstatus.bildbereich := bild;
+ editstack (i).bildstatus.ueberschriftbereich := ueberschrift
+ PER
+END PROC alles neu;
+
+PROC satznr zeigen :
+ out (satznr pre); out (text (text (lineno (file)), 4))
+END PROC satznr zeigen;
+
+PROC ueberschrift zeigen :
+ SELECT ueberschriftbereich OF
+ CASE akt satznr : satznr zeigen;
+ ueberschriftbereich := nix
+ CASE ueberschrift : ueberschrift schreiben;
+ ueberschriftbereich := nix
+ CASE fehlermeldung : fehlermeldung schreiben;
+ ueberschriftbereich := ueberschrift
+ END SELECT
+END PROC ueberschrift zeigen;
+
+PROC fenster zeigen :
+ SELECT bildbereich OF
+ CASE bildzeile :
+ zeile := bildrand + zeilennr;
+ IF line no (file) > lines (file)
+ THEN feldout ("", stelle)
+ ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle)
+ FI
+ CASE abschnitt :
+ bild ausgeben
+ CASE bild :
+ erster neusatz := 1;
+ letzter neusatz := 9999;
+ bild ausgeben
+ OTHERWISE :
+ LEAVE fenster zeigen
+ END SELECT;
+ erster neusatz := 9999;
+ letzter neusatz := 0;
+ bildbereich := nix
+END PROC fenster zeigen ;
+
+PROC bild ausgeben :
+ BOOL CONST schreiben ist ganz einfach := NOT markiert AND verschoben = 0;
+ INT CONST save marke := marke,
+ save verschoben := verschoben,
+ save laenge := laenge,
+ act lineno := lineno (file),
+ von := max (1, erster neusatz - bildanfang + 1);
+ INT VAR bis := min (letzter neusatz - bildanfang + 1, bildlaenge);
+ IF kurze feldlaenge <= 0 THEN bis := min (bis, kurze bildlaenge) FI;
+ IF von > bis THEN LEAVE bild ausgeben FI;
+ verschoben := 0;
+ IF markiert
+ THEN IF mark lineno (file) < bildanfang + von - 1
+ THEN marke := anfang
+ ELSE marke := 0
+ FI
+ FI ;
+ abschnitt loeschen und neuschreiben;
+ to line (file, act lineno);
+ laenge := save laenge;
+ verschoben := save verschoben;
+ marke := save marke .
+
+markiert : mark lineno (file) > 0 .
+
+abschnitt loeschen und neuschreiben :
+ abschnitt loeschen;
+ INT VAR line number := bildanfang + von - 1;
+ to line (file, line number);
+ abschnitt schreiben .
+
+abschnitt loeschen :
+ cursor (rand + 1, bildrand + von);
+ IF bildrest darf komplett geloescht werden
+ THEN out (clear eop)
+ ELSE zeilenweise loeschen
+ FI .
+
+bildrest darf komplett geloescht werden :
+ bis = maxlaenge AND kurze bildlaenge = maxlaenge
+ AND kurze feldlaenge = maxbreite .
+
+zeilenweise loeschen :
+ INT VAR i;
+ FOR i FROM von UPTO bis REP
+ check for interrupt;
+ feldlaenge einstellen;
+ feldrest loeschen;
+ IF i < bis THEN out (down char) FI
+ PER .
+
+feldlaenge einstellen :
+ IF ganze zeile sichtbar
+ THEN laenge := feldlaenge
+ ELSE laenge := kurze feldlaenge
+ FI .
+
+ganze zeile sichtbar : i <= kurze bildlaenge .
+
+abschnitt schreiben :
+ INT CONST last line := lines (file);
+ FOR i FROM von UPTO bis
+ WHILE line number <= last line REP
+ check for interrupt;
+ feldlaenge einstellen;
+ zeile schreiben;
+ down (file);
+ line number INCR 1
+ PER .
+
+check for interrupt :
+ kommando CAT inchety;
+ IF kommando <> ""
+ THEN IF zeilen nr = 1 CAND up command CAND vorgaenger erlaubt
+ THEN LEAVE abschnitt loeschen und neuschreiben
+ ELIF zeilen nr = bildlaenge CAND down command CAND nicht letzter satz
+ THEN LEAVE abschnitt loeschen und neuschreiben
+ FI
+ FI .
+
+vorgaenger erlaubt :
+ satznr > max (1, bildmarke) .
+
+up command : next incharety is (""3"") COR next incharety is (""1""3"") .
+
+down command :
+ next incharety is (""10"") CAND bildlaenge < maxlaenge
+ COR next incharety is (""1""10"") .
+
+nicht letzter satz : act lineno < lines (file) .
+
+zeile schreiben :
+ zeile := bildrand + i;
+ IF schreiben ist ganz einfach
+ THEN exec (PROC (TEXT CONST, INT CONST) simple feldout, file, 0)
+ ELSE zeile kompliziert schreiben
+ FI ;
+ IF line number = old lineno THEN old line update := FALSE FI .
+
+zeile kompliziert schreiben :
+ IF line number = mark lineno (file) THEN marke := mark col (file) FI;
+ IF line number = act lineno
+ THEN verschoben := save verschoben;
+ exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle);
+ verschoben := 0; marke := 0
+ ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, 0);
+ IF line number = mark lineno (file) THEN marke := anfang FI
+ FI .
+END PROC bild ausgeben;
+
+PROC bild zeigen : (* wk *)
+
+ dateizustand holen ;
+ ueberschrift zeigen ;
+ bildausgabe steuern ;
+ bild neu ;
+ fenster zeigen ;
+ oldline no := satznr ;
+ old line update := FALSE ;
+ old satz := "" ;
+ old zeilennr := satznr - bildanfang + 1 ;
+ dateizustand retten .
+
+ENDPROC bild zeigen ;
+
+PROC ueberschrift initialisieren : (*sh*)
+ satznr pre :=
+ cursor pos + code (bildrand - 1) + code (rand + feldlaenge - 6);
+ ueberschrift pre :=
+ cursor pos + code (bildrand - 1) + code (rand) + mark anf;
+ ueberschrift text := ""; INT VAR i;
+ FOR i FROM 16 UPTO feldlaenge REP ueberschrift text CAT "." PER;
+ ueberschrift post := blank + mark end + "Zeile " + mark anf;
+ ueberschrift post CAT blank + mark end + " ";
+ filename := headline (file);
+ filename := subtext (filename, 1, feldlaenge - 24);
+ insert char (filename, blank, 1); filename CAT blank;
+ replace (ueberschrift text, filenamepos, filename);
+ rubin segment in ueberschrift eintragen;
+ margin segment in ueberschrift eintragen;
+ rest segment in ueberschrift eintragen;
+ learn segment in ueberschrift eintragen .
+
+filenamepos : (LENGTH ueberschrift text - LENGTH filename + 3) DIV 2 .
+mark anf : begin mark + mark ausgleich.
+mark end : end mark + mark ausgleich.
+mark ausgleich : (1 - sign (max (mark size, 0))) * blank .
+
+rubin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 9, rubin segment) .
+
+rubin segment :
+ IF einfuegen THEN "RUBIN" ELSE "....." FI .
+
+margin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 2, margin segment) .
+
+margin segment :
+ IF anfang <= 1
+ THEN "......"
+ ELSE TEXT VAR margin text := "M" + text (anfang);
+ (6 - LENGTH margin text) * "." + margin text
+ FI .
+
+rest segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 25, rest segment) .
+
+rest segment :
+ IF zeileneinfuegen THEN "REST" ELSE "...." FI .
+
+learn segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 19, learn segment) .
+
+learn segment :
+ IF lernmodus THEN "LEARN" ELSE "....." FI .
+
+END PROC ueberschrift initialisieren;
+
+PROC ueberschrift schreiben :
+ replace (ueberschrift post, satznr pos, text (text (lineno (file)), 4));
+ out (ueberschrift pre); out (ueberschrift text); out (ueberschrift post);
+ get tabs (file, tab);
+ IF pos (tab, dach) > 0
+ THEN out (ueberschrift pre);
+ out subtext (tab, anfang + 1, anfang + feldlaenge - 1);
+ cursor (rand + 1 + feldlaenge, bildrand); out (end mark)
+ FI .
+
+ satznr pos : IF mark size > 0 THEN 9 ELSE 10 FI . (*sh*)
+END PROC ueberschrift schreiben;
+
+PROC fehlermeldung schreiben :
+ ueberschrift schreiben;
+ out (ueberschrift pre);
+ out ("FEHLER: ");
+ out subtext (fehlertext, 1, feldlaenge - 21);
+ out (blank);
+ out (piep);
+ cursor (rand + 1 + feldlaenge, bildrand); out (end mark)
+END PROC fehlermeldung schreiben;
+
+PROC set busy indicator :
+ cursor (rand + 2, bildrand)
+END PROC set busy indicator;
+
+PROC kommando analysieren (TEXT CONST taste,
+ PROC (TEXT CONST) kommando interpreter) :
+ disable stop;
+ bildausgabe normieren;
+ zustand in datei sichern;
+ editfile modus setzen;
+ kommando interpreter (taste);
+ editfile modus zuruecksetzen;
+ IF actual editor <= 0 THEN LEAVE kommando analysieren FI;
+ absatz ausgleich := 2; (*sh*)
+ konstanten neu berechnen;
+ neues bild bei undefinierter benutzeraktion;
+ evtl fehler behandeln;
+ zustand aus datei holen;
+ bildausgabe steuern .
+
+editfile modus setzen :
+ BOOL VAR alter editget modus := editget modus ;
+ editget modus := FALSE .
+
+editfile modus zuruecksetzen :
+ editget modus := alter editget modus .
+
+evtl fehler behandeln :
+ IF is error
+ THEN fehlertext := errormessage;
+ IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI;
+ clear error
+ ELSE fehlertext := ""
+ FI .
+
+zustand in datei sichern :
+ old zeilennr := zeilennr;
+ old mark lineno := bildmarke;
+ dateizustand retten .
+
+zustand aus datei holen :
+ dateizustand holen;
+ IF letzer editor auf dieser datei <> actual editor
+ THEN zurueck auf alte position; neu (ueberschrift, bild)
+ FI .
+
+zurueck auf alte position :
+ to line (file, old lineno);
+ col (file, alte stelle);
+ IF fliesstext
+ THEN editinfo (file, old zeilennr)
+ ELSE editinfo (file, - old zeilennr)
+ FI ; dateizustand holen .
+
+bildausgabe normieren :
+ bildbereich := undefinierter bereich;
+ erster neusatz := 9999;
+ letzter neusatz := 0 .
+
+neues bild bei undefinierter benutzeraktion :
+ IF bildbereich = undefinierter bereich THEN alles neu FI .
+END PROC kommando analysieren;
+
+PROC bildausgabe steuern :
+ IF markiert
+ THEN IF old mark lineno = 0
+ THEN abschnitt neu (bildmarke, satznr);
+ konstanten neu berechnen
+ ELIF stelle veraendert (*sh*)
+ THEN zeile neu
+ FI
+ ELIF old mark lineno > 0
+ THEN abschnitt neu (old mark lineno, (max (satznr, old lineno)));
+ konstanten neu berechnen
+ FI ;
+ IF satznr <> old lineno
+ THEN neu (akt satznr, nix);
+ neuen bildaufbau bestimmen
+ ELSE zeilennr := old zeilennr
+ FI ;
+ zeilennr := min (min (zeilennr, satznr), aktuelle bildlaenge);
+ bildanfang := satznr - zeilennr + 1 .
+
+stelle veraendert : stelle <> alte stelle .
+
+neuen bildaufbau bestimmen :
+ zeilennr := old zeilennr + satznr - old lineno;
+ IF 1 <= zeilennr AND zeilennr <= aktuelle bildlaenge
+ THEN im fenster springen
+ ELSE bild neu aufbauen
+ FI .
+
+im fenster springen :
+ IF markiert THEN abschnitt neu (old lineno, satznr) FI .
+
+bild neu aufbauen :
+ neu (nix, bild); zeilennr := max (1, aktuelle bildlaenge DIV 2) .
+END PROC bildausgabe steuern;
+
+PROC word wrap (BOOL CONST b) :
+ IF actual editor = 0
+ THEN std fliesstext := b
+ ELSE fliesstext in datei setzen
+ FI .
+
+fliesstext in datei setzen :
+ fliesstext := b;
+ IF fliesstext veraendert THEN editinfo (file, - editinfo (file)) FI;
+ neu (ueberschrift, bild) .
+
+fliesstext veraendert :
+ fliesstext AND editinfo (file) < 0 OR
+ NOT fliesstext AND editinfo (file) > 0 .
+END PROC word wrap;
+
+BOOL PROC word wrap : (*sh*)
+ IF actual editor = 0
+ THEN std fliesstext
+ ELSE fliesstext
+ FI
+END PROC word wrap;
+
+INT PROC margin : anfang END PROC margin;
+
+PROC margin (INT CONST i) : (*sh*)
+ IF anfang <> i CAND i > 0 AND i < 16001
+ THEN anfang := i; neu (ueberschrift, bild);
+ margin segment in ueberschrift eintragen
+ ELSE IF i >= 16001 OR i < 0
+ THEN errorstop ("ungueltige Anfangsposition (1 - 16000)")
+ FI
+ FI .
+
+margin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 2, margin segment) .
+
+margin segment :
+ IF anfang <= 1
+ THEN "......"
+ ELSE TEXT VAR margin text := "M" + text (anfang);
+ (6 - LENGTH margin text) * "." + margin text
+ FI .
+
+END PROC margin;
+
+BOOL PROC rubin mode : rubin mode (actual editor) END PROC rubin mode;
+
+BOOL PROC rubin mode (INT CONST editor nr) : (*sh*)
+ IF editor nr < 1 OR editor nr > max used editor
+ THEN errorstop ("Editor nicht eroeffnet")
+ FI ;
+ IF editor nr = actual editor
+ THEN einfuegen
+ ELSE editstack (editor nr).feldstatus.einfuegen
+ FI
+END PROC rubin mode;
+
+PROC edit (INT CONST i, TEXT CONST res,
+ PROC (TEXT CONST) kommando interpreter) :
+ edit (i, i, i, res, PROC (TEXT CONST) kommando interpreter)
+END PROC edit;
+
+PROC edit (INT CONST von, bis, start, TEXT CONST res,
+ PROC (TEXT CONST) kommando interpreter) :
+ disable stop;
+ IF von < bis
+ THEN edit (von+1, bis, start, res, PROC (TEXT CONST) kommando interpreter);
+ IF max used editor < von THEN LEAVE edit FI;
+ open editor (von)
+ ELSE open editor (start)
+ FI ;
+ absatz ausgleich := 2;
+ bildeditor (res, PROC (TEXT CONST) kommando interpreter);
+ cursor (1, schirmhoehe);
+ IF is error
+ THEN kommando zeiger := 1; kommando := ""; quit
+ FI ;
+ IF lernmodus CAND actual editor = 0 THEN warnung ausgeben FI . (*sh*)
+
+ warnung ausgeben :
+ out (clear eop); out ("WARNUNG: Lernmodus nicht ausgeschaltet"13""10"") .
+END PROC edit;
+
+PROC dateizustand holen :
+ modify (file);
+ get tabs (file, tabulator);
+ zeilennr und fliesstext und letzter editor aus editinfo decodieren;
+ limit := max line length (file);
+ stelle := col (file);
+ markiert := mark (file);
+ IF markiert
+ THEN markierung holen
+ ELSE keine markierung
+ FI ;
+ satz nr := lineno (file);
+ IF zeilennr > aktuelle bildlaenge (*sh*)
+ THEN zeilennr := min (satznr, aktuelle bildlaenge); bild neu
+ ELIF zeilennr > satznr
+ THEN zeilennr := min (satznr, aktuelle bildlaenge)
+ FI ; zeilennr := max (zeilennr, 1);
+ bildanfang := satz nr - zeilennr + 1 .
+
+zeilennr und fliesstext und letzter editor aus editinfo decodieren :
+ zeilennr := edit info (file);
+ IF zeilennr = 0
+ THEN zeilennr := 1;
+ fliesstext := std fliesstext
+ ELIF zeilennr > 0
+ THEN fliesstext := TRUE
+ ELSE zeilennr := - zeilennr;
+ fliesstext := FALSE
+ FI ;
+ letzer editor auf dieser datei := zeilennr DIV 256;
+ zeilennr := zeilennr MOD 256 .
+
+markierung holen :
+ bildmarke := mark lineno (file);
+ feldmarke := mark col (file);
+ IF line no (file) <= bildmarke
+ THEN to line (file, bildmarke);
+ marke := feldmarke;
+ stelle := max (stelle, feldmarke)
+ ELSE marke := 1
+ FI .
+
+keine markierung :
+ bildmarke := 0;
+ feldmarke := 0;
+ marke := 0 .
+END PROC dateizustand holen;
+
+PROC dateizustand retten :
+ put tabs (file, tabulator);
+ IF fliesstext
+ THEN editinfo (file, zeilennr + actual editor * 256)
+ ELSE editinfo (file, - (zeilennr + actual editor * 256))
+ FI ;
+ max line length (file, limit);
+ col (file, stelle);
+ IF markiert
+ THEN mark (file, bildmarke, feldmarke)
+ ELSE mark (file, 0, 0)
+ FI
+END PROC dateizustand retten;
+
+PROC open editor (FILE CONST new file, BOOL CONST access) :
+ disable stop; quit last;
+ neue bildparameter bestimmen;
+ open editor (actual editor + 1, new file, access, x, y, x len, y len).
+
+neue bildparameter bestimmen :
+ INT VAR x, y, x len, y len;
+ IF actual editor > 0
+ THEN teilbild des aktuellen editors
+ ELSE volles bild
+ FI .
+
+teilbild des aktuellen editors :
+ get editcursor (x, y); bildgroesse bestimmen;
+ IF fenster zu schmal (*sh*)
+ THEN enable stop; errorstop ("Fenster zu klein")
+ ELIF fenster zu kurz
+ THEN verkuerztes altes bild nehmen
+ FI .
+
+bildgroesse bestimmen :
+ x len := rand + feldlaenge - x + 3;
+ y len := bildrand + bildlaenge - y + 1 .
+
+fenster zu schmal : x > schirmbreite - 17 .
+fenster zu kurz : y > schirmhoehe - 1 .
+
+verkuerztes altes bild nehmen :
+ x := rand + 1; y := bildrand + 1;
+ IF fenster zu kurz THEN enable stop; errorstop ("Fenster zu klein") FI;
+ x len := feldlaenge + 2;
+ y len := bildlaenge;
+ kurze feldlaenge := 0;
+ kurze bildlaenge := 1 .
+
+volles bild :
+ x := 1; y := 1; x len := schirmbreite; y len := schirmhoehe .
+END PROC open editor;
+
+PROC open editor (INT CONST editor nr,
+ FILE CONST new file, BOOL CONST access,
+ INT CONST x start, y, x len start, y len) :
+ INT VAR x := x start,
+ x len := x len start;
+ IF editor nr > max editor
+ THEN errorstop ("zu viele Editor-Fenster")
+ ELIF editor nr > max used editor + 1 OR editor nr < 1
+ THEN errorstop ("Editor nicht eroeffnet")
+ ELIF fenster ungueltig
+ THEN errorstop ("Fenster ungueltig")
+ ELSE neuen editor stacken
+ FI .
+
+fenster ungueltig :
+ x < 1 COR x > schirmbreite COR y < 1 COR y > schirmhoehe COR
+ x len - 2 <= 15 COR y len - 1 < 1 COR
+ x + x len - 1 > schirmbreite COR y + y len - 1 > schirmhoehe .
+
+neuen editor stacken :
+ disable stop;
+ IF actual editor > 0 AND ist einschraenkung des alten bildes
+ THEN dateizustand holen;
+ aktuelles editorbild einschraenken;
+ arbeitspunkt in das restbild positionieren;
+ abgrenzung beruecksichtigen
+ FI ;
+ aktuellen zustand retten;
+ neuen zustand setzen;
+ neues editorbild zeigen;
+ actual editor := editor nr;
+ IF actual editor > max used editor
+ THEN max used editor := actual editor
+ FI .
+
+ist einschraenkung des alten bildes :
+ x > rand CAND x + x len = rand + feldlaenge + 3 CAND
+ y > bildrand CAND y + y len = bildrand + bildlaenge + 1 .
+
+aktuelles editorbild einschraenken :
+ kurze feldlaenge := x - rand - 3;
+ kurze bildlaenge := y - bildrand - 1 .
+
+arbeitspunkt in das restbild positionieren :
+ IF stelle > 3
+ THEN stelle DECR 3; alte stelle := stelle
+ ELSE WHILE zeilennr > 1 AND zeilennr > kurze bildlaenge REP
+ vorgaenger
+ PER; old lineno := satznr
+ FI .
+
+abgrenzung beruecksichtigen :
+ IF x - rand > 1
+ THEN balken malen;
+ x INCR 2;
+ x len DECR 2
+ FI .
+
+balken malen :
+ INT VAR i;
+ FOR i FROM 0 UPTO y len-1 REP
+ cursor (x, y+i); out (kloetzchen) (*sh*)
+ PER .
+
+kloetzchen : IF mark size > 0 THEN ""15""14"" ELSE ""15" "14" " FI .
+
+aktuellen zustand retten :
+ IF actual editor > 0
+ THEN dateizustand retten;
+ editstack (actual editor).feldstatus := feldstatus;
+ editstack (actual editor).bildstatus := bildstatus;
+ einrueckstack (actual editor) := alte einrueckposition
+ FI .
+
+neuen zustand setzen :
+ FRANGE VAR frange;
+ feldstatus := FELDSTATUS :
+ (1, 1, x-1, 0, 1, 0, x len-2, 0, FALSE, TRUE, access, "");
+ bildstatus := BILDSTATUS :
+ (x len-2, x len-2, y, y len-1, y len-1, ueberschrift, bild,
+ 0, 0, 1, 0, 0, FALSE, FALSE, "", "", "", "", "", frange, new file);
+ alte einrueckposition := 1;
+ dateizustand holen;
+ ueberschrift initialisieren .
+
+neues editorbild zeigen :
+ ueberschrift zeigen; fenster zeigen
+END PROC open editor;
+
+PROC open editor (INT CONST i) :
+ IF i < 1 OR i > max used editor
+ THEN errorstop ("Editor nicht eroeffnet")
+ ELIF actual editor <> i
+ THEN switch editor
+ FI .
+
+switch editor :
+ aktuellen zustand retten;
+ actual editor := i;
+ neuen zustand setzen;
+ IF kein platz mehr fuer restfenster
+ THEN eingeschachtelte editoren vergessen;
+ bildeinschraenkung aufheben
+ ELSE neu (nix, nix)
+ FI .
+
+aktuellen zustand retten :
+ IF actual editor > 0
+ THEN editstack (actual editor).feldstatus := feldstatus;
+ editstack (actual editor).bildstatus := bildstatus;
+ einrueckstack (actual editor) := alte einrueckposition;
+ dateizustand retten
+ FI .
+
+neuen zustand setzen :
+ feldstatus := editstack (i).feldstatus;
+ bildstatus := editstack (i).bildstatus;
+ alte einrueckposition := einrueckstack (i);
+ dateizustand holen .
+
+kein platz mehr fuer restfenster :
+ kurze feldlaenge < 1 AND kurze bildlaenge < 1 .
+
+eingeschachtelte editoren vergessen :
+ IF actual editor < max used editor
+ THEN open editor (actual editor + 1) ;
+ quit
+ FI ;
+ open editor (i) .
+
+bildeinschraenkung aufheben :
+ laenge := feldlaenge;
+ kurze feldlaenge := feldlaenge;
+ kurze bildlaenge := bildlaenge;
+ neu (ueberschrift, bild) .
+END PROC open editor;
+
+FILE PROC editfile :
+ IF actual editor = 0 OR editget modus
+ THEN errorstop ("Editor nicht eroeffnet")
+ FI ; file
+END PROC editfile;
+
+PROC get window (INT VAR x, y, x size, y size) :
+ x := rand + 1;
+ y := bildrand;
+ x size := feldlaenge + 2;
+ y size := bildlaenge + 1
+ENDPROC get window;
+
+(************************* Zugriff auf Bildstatus *************************).
+
+feldlaenge : bildstatus.feldlaenge .
+kurze feldlaenge : bildstatus.kurze feldlaenge .
+bildrand : bildstatus.bildrand .
+bildlaenge : bildstatus.bildlaenge .
+kurze bildlaenge : bildstatus.kurze bildlaenge .
+ueberschriftbereich : bildstatus.ueberschriftbereich .
+bildbereich : bildstatus.bildbereich .
+erster neusatz : bildstatus.erster neusatz .
+letzter neusatz : bildstatus.letzter neusatz .
+old zeilennr : bildstatus.old zeilennr .
+old lineno : bildstatus.old lineno .
+old mark lineno : bildstatus.old mark lineno .
+zeileneinfuegen : bildstatus.zeileneinfuegen .
+old line update : bildstatus.old line update .
+satznr pre : bildstatus.satznr pre .
+ueberschrift pre : bildstatus.ueberschrift pre .
+ueberschrift text : bildstatus.ueberschrift text .
+ueberschrift post : bildstatus.ueberschrift post .
+old satz : bildstatus.old satz .
+old range : bildstatus.old range .
+file : bildstatus.file .
+
+END PACKET editor paket;
+
diff --git a/system/base/1.7.5/src/elan do interface b/system/base/1.7.5/src/elan do interface
new file mode 100644
index 0000000..72026a7
--- /dev/null
+++ b/system/base/1.7.5/src/elan do interface
@@ -0,0 +1,57 @@
+
+PACKET elan do interface DEFINES (*Autor: J.Liedtke *)
+ (*Stand: 08.11.85 *)
+ do ,
+ no do again :
+
+
+LET no ins = FALSE ,
+ no lst = FALSE ,
+ no check = FALSE ,
+ no sermon = FALSE ,
+ compile line mode = 2 ,
+ do again mode = 4 ,
+ max command length = 2000 ;
+
+
+INT VAR do again mod nr := 0 ;
+TEXT VAR previous command := "" ;
+
+DATASPACE VAR ds ;
+
+
+PROC do (TEXT CONST command) :
+
+ enable stop ;
+ IF LENGTH command > max command length
+ THEN errorstop ("Kommando zu lang")
+ ELIF do again mod nr <> 0 AND command = previous command
+ THEN do again
+ ELSE previous command := command ;
+ compile and execute
+ FI .
+
+do again :
+ elan (do again mode, ds, "", do again mod nr,
+ no ins, no lst, no check, no sermon) .
+
+compile and execute :
+ elan (compile line mode, ds, command, do again mod nr,
+ no ins, no lst, no check, no sermon) .
+
+ENDPROC do ;
+
+PROC no do again :
+
+ do again mod nr := 0
+
+ENDPROC no do again ;
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+ INT VAR start module number,
+ BOOL CONST ins, lst, rt check, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ENDPACKET elan do interface ;
+
diff --git a/system/base/1.7.5/src/error handling b/system/base/1.7.5/src/error handling
new file mode 100644
index 0000000..34db65d
--- /dev/null
+++ b/system/base/1.7.5/src/error handling
@@ -0,0 +1,142 @@
+
+PACKET error handling DEFINES
+
+ enable stop ,
+ disable stop ,
+ is error ,
+ clear error ,
+ errormessage ,
+ error code ,
+ error line ,
+ put error ,
+ errorstop ,
+ stop :
+
+
+LET cr lf = ""13""10"" ,
+ line nr field = 1 ,
+ error line field = 2 ,
+ error code field = 3 ,
+ syntax error code= 100 ,
+
+ error pre = ""7""13""10""5"FEHLER : " ;
+
+
+TEXT VAR errortext := "" ;
+
+
+PROC enable stop :
+ EXTERNAL 75
+ENDPROC enable stop ;
+
+PROC disable stop :
+ EXTERNAL 76
+ENDPROC disable stop ;
+
+PROC set error stop (INT CONST code) :
+ EXTERNAL 77
+ENDPROC set error stop ;
+
+BOOL PROC is error :
+ EXTERNAL 78
+ENDPROC is error ;
+
+PROC clear error :
+ EXTERNAL 79
+ENDPROC clear error ;
+
+PROC select error message :
+
+ SELECT error code OF
+ CASE 1 : error text := "'halt' vom Terminal"
+ CASE 2 : error text := "Stack-Ueberlauf"
+ CASE 3 : error text := "Heap-Ueberlauf"
+ CASE 4 : error text := "INT-Ueberlauf"
+ CASE 5 : error text := "DIV durch 0"
+ CASE 6 : error text := "REAL-Ueberlauf"
+ CASE 7 : error text := "TEXT-Ueberlauf"
+ CASE 8 : error text := "zu viele DATASPACEs"
+ CASE 9 : error text := "Ueberlauf bei Subskription"
+ CASE 10: error text := "Unterlauf bei Subskription"
+ CASE 11: error text := "falscher DATASPACE-Zugriff"
+ CASE 12: error text := "INT nicht initialisiert"
+ CASE 13: error text := "REAL nicht initialisiert"
+ CASE 14: error text := "TEXT nicht initialisiert"
+ CASE 15: error text := "nicht implementiert"
+ CASE 16: error text := "Block unlesbar"
+ CASE 17: error text := "Codefehler"
+ END SELECT
+
+ENDPROC select error message ;
+
+TEXT PROC error message :
+
+ select error message ;
+ error text
+
+ENDPROC error message ;
+
+INT PROC error code :
+
+ pcb (error code field)
+
+ENDPROC error code ;
+
+INT PROC error line :
+
+ IF is error
+ THEN pcb (error line field)
+ ELSE 0
+ FI
+
+ENDPROC error line ;
+
+PROC syntax error (TEXT CONST message) :
+
+ INTERNAL 259 ;
+ errorstop (syntax error code, message) .
+
+ENDPROC syntax error ;
+
+PROC errorstop (TEXT CONST message) :
+
+ errorstop (0, message) ;
+
+ENDPROC errorstop ;
+
+PROC errorstop (INT CONST code, TEXT CONST message) :
+
+ IF NOT is error
+ THEN error text := message ;
+ set error stop (code)
+ FI
+
+ENDPROC errorstop ;
+
+PROC put error :
+
+ IF is error
+ THEN select error message ;
+ IF error text <> ""
+ THEN put error message
+ FI
+ FI .
+
+put error message :
+ out (error pre) ;
+ out (error text) ;
+ IF error line > 0
+ THEN out (" bei Zeile "); out (text (error line)) ;
+ FI ;
+ out (cr lf) .
+
+ENDPROC put error ;
+
+PROC stop :
+
+ errorstop ("stop")
+
+ENDPROC stop ;
+
+ENDPACKET error handling ;
+
diff --git a/system/base/1.7.5/src/eumel coder part 1 b/system/base/1.7.5/src/eumel coder part 1
new file mode 100644
index 0000000..83974f7
--- /dev/null
+++ b/system/base/1.7.5/src/eumel coder part 1
@@ -0,0 +1,866 @@
+PACKET eumel coder part 1 (* Autor: U. Bartling *)
+ DEFINES run, run again,
+ insert,
+ prot, prot off,
+ check, check on, check off,
+ warnings, warnings on, warnings off,
+
+ help, bulletin, packets
+ :
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 13.02.1986 *)
+(* Stand der Implementation : 16.04.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR hash table pointer, nt link, permanent pointer, param link,
+ index, mode, word;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 10.04.1986 *)
+(* 1.7.5.4 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ row = 10 ,
+ struct = 11 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+ bold = 2 ,
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+
+ warning message = 2 ,
+ error message = 4 ,
+
+ point line = "..............." ;
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 16.04.1986 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, pattern length, packet link,
+ begin of packet, last packet entry, indentation;
+
+TEXT VAR bulletin name, type and mode, pattern, buffer;
+
+DATASPACE VAR bulletin ds :: nilspace ;
+
+.packet name :
+ cdb text (cdb int(packet link + wordlength) + two word length) .
+
+.within editor :
+ aktueller editor > 0 . ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DATASPACE"
+ CASE row : type and mode CAT "ROW "
+ CASE struct : type and mode CAT "STRUCT"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+PROC help (TEXT CONST proc name) :
+ prep bulletin ;
+ prep help ;
+ scan (object name) ;
+ next symbol (pattern) ;
+ packet link := end of permanent table ;
+ IF function = 0 THEN standard help
+ ELSE asterisk help
+ FI .
+
+prep help :
+ object name := compress (proc name) ;
+ INT VAR function :: 0 ;
+ INT CONST l :: LENGTH object name ;
+ IF l > 1 AND object name <> "**"
+ THEN IF (object name SUB l) = "*"
+ THEN function INCR 2 ;
+ delete char (object name, l)
+ FI ;
+ IF (object name SUB 1) = "*"
+ THEN function INCR 1 ;
+ delete char (object name, 1)
+ FI ;
+ IF another asterisk THEN wrong function FI
+ FI.
+
+another asterisk :
+ pos (object name, "*") <> 0 .
+
+wrong function :
+ errorstop ("unzulaessige Sternfunktion") .
+
+standard help :
+ to object (pattern) ;
+ IF found THEN display
+ ELSE error stop ("unbekannt: " + proc name)
+ FI .
+
+display :
+ WHILE permanent pointer <> 0 REP
+ put name of packet if necessary ;
+ put specifications (pattern) ;
+ next procedure
+ ENDREP ;
+ show bulletin file .
+
+put name of packet if necessary :
+ IF new packet THEN packet link := permanent pointer ;
+ find begin of packet ;
+ writeline (2) ;
+ write packet name
+ FI .
+
+find begin of packet :
+ REP
+ packet link DECR wordlength
+ UNTIL begin of packet found PER .
+
+begin of packet found :
+ cdb int (packet link) = permanent packet .
+
+new packet :
+ permanent pointer < packet link .
+
+asterisk help :
+ hash table pointer := begin of hash table ;
+ pattern length := LENGTH pattern - 1 ;
+ REP
+ list all objects in current hash table chain ;
+ next hash entry
+ UNTIL end of hash table reached ENDREP ;
+ show bulletin file .
+
+list all objects in current hash table chain :
+ nt link := hash table pointer ;
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length) ;
+ IF matching THEN into bulletin FI
+ PER .
+
+matching :
+ INT CONST p :: pos (object name, pattern) ;
+ SELECT function OF
+ CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
+ CASE 2 : p = 1
+ CASE 3 : p <> 0
+ OTHERWISE FALSE
+ ENDSELECT .
+
+into bulletin :
+ object names into bulletin (BOOL PROC not end of chain)
+ENDPROC help ;
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC write packet name :
+ indentation := 0 ;
+ write line ;
+ write bulletin line ("PACKET ") ;
+ indentation := 7 ;
+ object name := packet name ;
+ write bulletin line (object name) ;
+ write bulletin line (":") ;
+ writeline (2)
+ENDPROC write packet name ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type, param mode;
+ get type and mode (type) ;
+ param mode := mode ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF param mode = const THEN " CONST"
+ ELIF param mode = var THEN " VAR"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ forget (bulletin ds) ;
+ bulletin ds := nilspace ;
+ bulletin file := sequential file (output, bulletin ds) ;
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC show bulletin file :
+ IF within editor THEN ueberschrift neu FI ;
+ DATASPACE VAR local ds :: bulletin ds ;
+ FILE VAR local file :: sequential file (modify, local ds) ;
+ show (local file) ;
+ forget (local ds)
+ENDPROC show bulletin file ;
+
+PROC write bulletin line (TEXT CONST line) :
+ IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := indentation * " "
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet ;
+ IF found THEN list packet ;
+ show bulletin file
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+to packet :
+ last packet entry := 0 ;
+ get nametab link of packet name ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+get nametab link of packet name :
+ to object (pattern) ;
+ IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ;
+ LEAVE to packet
+ FI .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC bulletin ;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ write packet name ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is at least one object of this name in the current packet
+ THEN into bulletin FI .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (object name, mode) ;
+ IF type definition THEN put type definition
+ ELSE put object definitions
+ FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put type definition :
+ put obj name (object name) ;
+ write bulletin line ("TYPE ") ;
+ writeline (1) .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ write line (4) ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC bulletin ;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := " " ;
+ bulletin name := point line ;
+ change (bulletin name, 1, end of line or name, name) ;
+ buffer CAT bulletin name ;
+ indentation := LENGTH buffer + 1 .
+
+end of line or name :
+ min (LENGTH name, LENGTH bulletin name)
+ENDPROC put obj name ;
+
+PROC packets :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ object name := packet name ;
+ put obj name (object name) ;
+ write line ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC packets ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 11. ELAN Run-Interface 09.01.1986 *)
+(* *)
+(* Uebersetzen von ELAN-Programmen *)
+(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
+(* *)
+(**************************************************************************)
+
+
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ warning option := FALSE ,
+ listing enabled := FALSE ;
+
+FILE VAR listing file ;
+
+TEXT VAR listing file name := "" ;
+
+
+PROC run (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, no ins)
+END PROC run;
+
+PROC run :
+ run (last param)
+ENDPROC run ;
+
+PROC run again :
+ IF run again mod nr <> 0
+ THEN elan (run again mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+ ELSE errorstop ("'run again' nicht moeglich")
+ FI
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, ins)
+ENDPROC insert ;
+
+PROC insert :
+ insert (last param)
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+ FILE VAR source := sequential file (modify, file name) ;
+ IF listing enabled
+ THEN open listing file
+ FI ;
+
+ disable stop ;
+ no do again ;
+ elan (compile file mode, source, "" , run again mod nr,
+ insert option, list option, check option, sermon) ;
+
+ IF anything noted AND command dialogue
+ THEN ignore halt during compiling ;
+ note edit (source) ;
+ last param (file name) ;
+ errorstop ("")
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+open listing file :
+ listing file := sequential file (output, listing file name) ;
+ max line length (listing file, 130)
+
+ENDPROC run elan ;
+
+PROC out text (TEXT CONST text, INT CONST out type) :
+ INTERNAL 257 ;
+ IF online
+ THEN out (text)
+ FI ;
+ IF out type = error message OR (warning option AND out type = warning message)
+ THEN note (text) ;
+ FI ;
+ IF listing enabled
+ THEN write (listing file, text)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+ INTERNAL 258 ;
+ IF online
+ THEN out (""13""10"")
+ FI ;
+ IF out type = error message
+ OR (warning option AND out type = warning message)
+ THEN note line
+ ELIF listing enabled
+ THEN line (listing file)
+ FI
+ENDPROC out line ;
+
+PROC prot (TEXT CONST file name) :
+ list option := TRUE ;
+ listing file name := file name ;
+ listing enabled := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE ;
+ listing enabled := FALSE
+ENDPROC prot off ;
+
+BOOL PROC prot :
+ list option
+ENDPROC prot ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+BOOL PROC check :
+ check option
+ENDPROC check ;
+
+PROC warnings on :
+ warning option := TRUE
+ENDPROC warnings on ;
+
+PROC warnings off :
+ warning option := FALSE
+ENDPROC warnings off ;
+
+BOOL PROC warnings :
+ warning option
+ENDPROC warnings ;
+
+ENDPACKET eumel coder part 1 ;
+
diff --git a/system/base/1.7.5/src/file b/system/base/1.7.5/src/file
new file mode 100644
index 0000000..530dcb3
--- /dev/null
+++ b/system/base/1.7.5/src/file
@@ -0,0 +1,2122 @@
+(* ------------------- VERSION 35 02.06.86 ------------------- *)
+PACKET file handling DEFINES (* Autoren: J.Liedtke, D.Martinek *)
+ (***********)
+
+ FILE,
+ :=,
+ sequential file,
+ reorganize,
+ input,
+ output,
+ modify,
+ close,
+ putline,
+ getline,
+ put,
+ get,
+ write ,
+ line,
+ reset,
+ down,
+ up,
+ downety,
+ uppety,
+ pattern found,
+ to first record,
+ to line,
+ to eof,
+ insert record,
+ delete record,
+ read record,
+ write record,
+ is first record,
+ eof,
+ line no,
+ FRANGE,
+ set range,
+ reset range ,
+ remove,
+ clear removed,
+ reinsert,
+ max line length,
+ edit info,
+ line type ,
+ copy attributes ,
+ headline,
+ put tabs,
+ get tabs,
+ col,
+ word,
+ at,
+ removed lines,
+ exec,
+ pos ,
+ len ,
+ subtext ,
+ change ,
+ lines ,
+ segments ,
+ mark ,
+ mark line no ,
+ mark col ,
+ set marked range ,
+ split line ,
+ concatenate line ,
+ prefix ,
+ sort ,
+ lexsort :
+
+
+(**********************************************************************)
+(* *)
+(* Terminologie: *)
+(* *)
+(* *)
+(* ATOMROW Menge aller Atome eines FILEs. *)
+(* Die einzelnen Atome haben zwar eine Position *)
+(* im Row, aber in dieser Betrachtung keine *)
+(* logische Reihenfolge. *)
+(* *)
+(* ATOM Basiselement, kann eine Zeile der Datei und die *)
+(* zugehoerige Verwaltungsinformation aufnehmen *)
+(* *)
+(* CHAIN Zyklisch geschlossene Kette von Segmenten. *)
+(* *)
+(* SEGMENT Teilbereich des Atomrows, enthaelt 1 oder mehr *)
+(* zusammenhaengende Atoms. *)
+(* Jedes Segment hat ein Vorgaenger- und ein *)
+(* Nachfolgersegment. *)
+(* Jedes Segment enthaelt einen logisch zumsammen- *)
+(* haengenden Teile einer Sequence. *)
+(* *)
+(* SEQUENCE Logische Folge von Lines. *)
+(* Jede Sequence ist Teil einer Chain oder besteht *)
+(* vollstaendig daraus: *)
+(* *)
+(* SEG1--SEG2--SEG3--SEG4--SEG5 *)
+(* :----sequence----: *)
+(* *)
+(* Die 'Reihenfolge' ebenso wie die 'Anzahl' der *)
+(* Lines ist eine wesentliche Eigenschaft einer *)
+(* Sequence. *)
+(* *)
+(* LINE Ein Atom als Element ein Sequence betrachtet. *)
+(* *)
+(* *)
+(**********************************************************************)
+(* *)
+(* Eigenschaften: *)
+(* *)
+(* Folgende Mengen bilden eine Zerlegung (im math. Sinn) einer *)
+(* gesamten Datei: *)
+(* used segment chain *)
+(* scratch segment chain *)
+(* free segment chain *)
+(* unused tail *)
+(* *)
+(* Fuer jedes X aus (used, scratch, free) gelten: *)
+(* *)
+(* 'X sequence' ist echte Teilmenge von 'X segment chain'. *)
+(* *)
+(* (Daraus folgt, es gibt keine leere 'chain'.) *)
+(* *)
+(* 'X segment chain' ist zyklisch gekettet. *)
+(* *)
+(* Alle Atome von 'X segment chain' haben definierten Inhalt. *)
+(* *)
+(**********************************************************************)
+
+
+LET file size = 4075 ,
+ nil = 0 ,
+
+ free root = 1 ,
+ scratch root = 2 ,
+ used root = 3 ,
+ first unused = 4 ;
+
+
+LET SEQUENCE = STRUCT (INT index, segment begin, segment end,
+ INT line no, lines),
+ SEGMENT = STRUCT (INT succ, pred, end),
+ ATOM = STRUCT (SEGMENT seg, INT type, TEXT line),
+ ATOMROW = ROW filesize ATOM,
+
+ LIST = STRUCT (SEQUENCE used, INT prefix lines, postfix lines,
+ SEQUENCE scratch, free, INT unused tail,
+ INT mode, col, limit, edit info, mark line, mark col,
+ ATOMROW atoms);
+
+TYPE FILE = BOUND LIST ;
+
+TYPE FRANGE = STRUCT (INT pre, post, BOOL pre was split, post was split);
+
+
+OP := (FRANGE VAR left, FRANGE CONST right):
+ CONCR (left) := CONCR (right)
+ENDOP := ;
+
+
+OP := (FILE VAR left, FILE CONST right):
+ EXTERNAL 260
+END OP :=;
+
+
+PROC becomes (INT VAR a, b) :
+ INTERNAL 260 ;
+ a := b
+END PROC becomes;
+
+
+PROC initialize (FILE VAR f) :
+
+ f.used := SEQUENCE : (used root, used root, used root, 1, 0);
+ f.prefix lines := 0;
+ f.postfix lines := 0;
+ f.free := SEQUENCE : (free root, free root, free root, 1, 0);
+ f.scratch := SEQUENCE : (scratch root, scratch root, scratch root, 1, 0);
+ f.unused tail := first unused;
+
+ f.limit := 77;
+ f.edit info := 0;
+ f.col := 1 ;
+ f.mark line := 0 ;
+ f.mark col := 0 ;
+
+ INT VAR i;
+ FOR i FROM 1 UPTO 3 REP
+ root (i).seg := SEGMENT : (i, i, i);
+ root (i).line := ""
+ PER;
+ put tabs (f, "") .
+
+root : f.atoms .
+
+END PROC initialize;
+
+
+(**********************************************************************)
+(* *)
+(* Segment Handler (SEGMENTs & CHAINs) *)
+(* *)
+(**********************************************************************)
+
+INT PROC segs (SEQUENCE CONST s, ATOMROW CONST atom) :
+
+ INT VAR number of segments := 0 ,
+ actual segment := s.segment begin ;
+ REP
+ number of segments INCR 1 ;
+ actual segment := atom (actual segment).seg.succ
+ UNTIL actual segment = s.segment begin PER ;
+ number of segments .
+
+ENDPROC segs ;
+
+
+PROC next segment (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ disable stop;
+ s.line no INCR (s.segment end - s.index + 1);
+ INT CONST new segment index := actual segment.succ;
+ s.segment begin := new segment index;
+ s.segment end := new segment.end;
+ s.index := new segment index .
+
+actual segment : atom (s.segment begin).seg .
+new segment : atom (new segment index).seg .
+
+END PROC next segment;
+
+
+PROC previous segment (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ disable stop;
+ s.line no DECR (s.index - s.segment begin + 1);
+ INT CONST new segment index := actual segment.pred;
+ s.segment begin := new segment index;
+ s.segment end := new segment.end;
+ s.index := s.segment end .
+
+actual segment : atom (s.segment begin).seg .
+new segment : atom (new segment index).seg .
+
+END PROC previous segment;
+
+
+PROC split segment (SEQUENCE VAR s, ATOMROW VAR atom) :
+
+ disable stop;
+ IF not at segment top
+ THEN split segment at actual position
+ FI .
+
+split segment at actual position :
+ INT CONST pred index := s.segment begin,
+ actual index := s.index,
+ succ index := pred.succ;
+
+ actual.pred := pred index;
+ actual.succ := succ index;
+ actual.end := s.segment end;
+
+ pred.succ := actual index;
+ pred.end := actual index - 1;
+
+ succ.pred := actual index;
+
+ s.segment begin := actual index .
+
+not at segment top : s.index > s.segment begin .
+
+pred : atom (pred index).seg .
+
+actual : atom (actual index).seg .
+
+succ : atom (succ index).seg .
+
+END PROC split segment;
+
+
+PROC join segments (ATOMROW VAR atom,
+ INT CONST first index, INT VAR second index) :
+
+ disable stop;
+ IF first seg.end + 1 = second index
+ THEN attach second to first segment
+ ELSE link first to second segment
+ FI .
+
+attach second to first segment :
+ first seg.end := second seg.end;
+ INT VAR successor of second := second seg.succ;
+ IF successor of second = second index
+ THEN first seg.succ := first index
+ ELSE join segments (atom, first index, successor of second)
+ FI;
+ second index := first index .
+
+link first to second segment :
+ first seg.succ := second index;
+ second seg.pred := first index .
+
+first seg : atom (first index).seg .
+second seg : atom (second index).seg .
+
+END PROC join segments;
+
+
+PROC delete segments (SEQUENCE VAR from, ATOMROW VAR atom,
+ INT CONST first index, last index, lines) :
+
+ determine surrounding segments and new atom index;
+ join surrounding segments;
+ update sequence descriptor .
+
+determine surrounding segments and new atom index :
+ INT VAR pred index := first seg.pred,
+ actual index := last seg.succ;
+ from.index := actual index .
+
+join surrounding segments :
+ join segments (atom, pred index, actual index) .
+
+update sequence descriptor :
+ from.segment begin := actual index;
+ from.segment end := actual seg.end;
+ from.lines DECR lines .
+
+actual seg : atom (actual index).seg .
+first seg : atom (first index).seg .
+last seg : atom (last index).seg .
+
+END PROC delete segments;
+
+
+PROC insert segments (SEQUENCE VAR into, ATOMROW VAR atom,
+ INT CONST first index, last index, lines) :
+
+ join into sequence and new segments;
+ update sequence descriptor .
+
+join into sequence and new segments :
+ INT VAR actual index := into.index,
+ pred index := actual seg.pred;
+ join segments (atom, last index, actual index);
+ actual index := first index;
+ join segments (atom, pred index, actual index) .
+
+update sequence descriptor :
+ into.index := first index;
+ into.segment begin := actual index;
+ into.segment end := actual seg.end;
+ into.lines INCR lines .
+
+actual seg : atom (actual index).seg .
+
+END PROC insert segments;
+
+
+PROC next atom (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ IF s.line no <= s.lines
+ THEN to next atom
+ ELSE errorstop ("'down' nach Dateiende")
+ FI .
+
+to next atom :
+ disable stop;
+ IF s.index = s.segment end
+ THEN next segment (s, atom)
+ ELSE s.index INCR 1;
+ s.line no INCR 1
+ FI
+
+END PROC next atom;
+
+
+PROC next atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) :
+
+ INT CONST destination line := min (s.line no + times, s.lines + 1);
+ jump upto destination segment;
+ position within destination segment .
+
+jump upto destination segment :
+ WHILE s.line no + length of actual segments tail < destination line REP
+ next segment (s, atom);
+ PER .
+
+position within destination segment :
+ disable stop;
+ s.index INCR (destination line - s.line no);
+ s.line no := destination line .
+
+length of actual segments tail : s.segment end - s.index .
+
+END PROC next atoms;
+
+
+PROC previous atom (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ IF s.line no > 1
+ THEN to previous atom
+ ELSE errorstop ("'up' am Dateianfang")
+ FI .
+
+to previous atom :
+ disable stop;
+ IF s.index = s.segment begin
+ THEN previous segment (s, atom)
+ ELSE s.index DECR 1;
+ s.line no DECR 1
+ FI
+
+END PROC previous atom;
+
+
+PROC previous atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) :
+
+ INT CONST destination line := max (1, s.line no - times);
+ jump back to destination segment;
+ position within destination segment .
+
+jump back to destination segment :
+ WHILE s.line no - length of actual segments head > destination line REP
+ previous segment (s, atom);
+ PER .
+
+position within destination segment :
+ disable stop;
+ s.index DECR (s.line no - destination line);
+ s.line no := destination line .
+
+length of actual segments head : s.index - s.segment begin .
+
+END PROC previous atoms;
+
+
+TEXT VAR pre, pat, pattern0;
+INT VAR last search line ;
+
+PROC search down (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT CONST max lines, INT VAR column) :
+
+ INT CONST start col := column ,
+ start line := s.lineno ;
+ last search line := min (s.lines, s.lineno + max lines) ;
+ pre:= somefix (pattern) ;
+ pattern0 := pattern ** 0 ;
+ down in atoms (s, atom, pre, column);
+ IF NOT (last search succeeded CAND like pattern)
+ THEN try again
+ FI;
+ last search succeeded := TRUE ;
+ column := matchpos (0) .
+
+try again:
+ WHILE s.line no < last search line
+ REP next atom (s, atom) ;
+ column := 1 ;
+ down in atoms (s, atom, pre, column);
+ IF last search succeeded CAND like pattern
+ THEN LEAVE try again
+ FI
+ PER;
+ column := 1 + LENGTH record;
+ last search succeeded := FALSE ;
+ LEAVE search down.
+
+like pattern :
+ correct position ;
+ pat := any (column-1) ;
+ pat CAT any ;
+ pat CAT pattern0 ;
+ pat CAT any ;
+ record LIKE pat .
+
+correct position :
+ IF s.lineno = start line
+ THEN column := start col
+ ELSE column := 1
+ FI .
+
+record : atom (s.index).line .
+
+ENDPROC search down ;
+
+PROC down in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT VAR column) :
+
+ last search succeeded := FALSE ;
+ search forwards in actual line ;
+ IF NOT found AND s.line no < last search line
+ THEN search in following lines
+ FI ;
+ IF found
+ THEN last search succeeded := TRUE
+ ELSE set column behind last char
+ FI .
+
+set column behind last char :
+ column := LENGTH atom (s.index).line + 1 .
+
+search forwards in actual line :
+ IF pattern <> ""
+ THEN column := pos (atom (s.index).line, pattern, column)
+ ELIF column > LENGTH atom (s.index).line
+ THEN column := 0
+ FI .
+
+search in following lines :
+ next atom (s, atom) ;
+ IF pattern = ""
+ THEN column := 1 ;
+ LEAVE search in following lines
+ FI ;
+ REP
+ search forwards through segment ;
+ update file position forwards ;
+ IF found OR s.line no = last search line
+ THEN LEAVE search in following lines
+ ELSE next segment (s, atom)
+ FI
+ PER .
+
+search forwards through segment :
+ INT VAR search index := s.index ,
+ last index := min (s.segment end, s.index+(last search line-s.line no));
+ REP
+ column := pos (atom (search index).line, pattern) ;
+ IF found OR search index = last index
+ THEN LEAVE search forwards through segment
+ FI ;
+ search index INCR 1
+ PER .
+
+update file position forwards :
+ disable stop ;
+ s.line no INCR (search index - s.index) ;
+ s.index := search index ;
+ enable stop .
+
+found : column > 0 .
+
+ENDPROC down in atoms ;
+
+TEXT PROC prefix (TEXT CONST pattern) :
+
+ INT VAR invalid char pos := pos (pattern, ""0"", ""31"", 1) ;
+ SELECT invalid char pos OF
+ CASE 0 : pattern
+ CASE 1 : ""
+ OTHERWISE : subtext (pattern, 1, invalid char pos - 1)
+ ENDSELECT .
+
+ENDPROC prefix ;
+
+PROC search up (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT CONST max lines, INT VAR column) :
+
+ last search line := max (1, s.lineno - max lines) ;
+ pre:= prefix (pattern);
+ pattern0 := pattern ** 0;
+ remember start point ;
+ up in atoms (s, atom, pre, column);
+ IF NOT (last search succeeded CAND last pattern in line found)
+ THEN try again
+ FI;
+ last search succeeded := TRUE ;
+ column := matchpos (0) .
+
+ try again:
+ WHILE s.lineno > last search line OR column > 1
+ REP previous atom (s, atom);
+ column := LENGTH record ;
+ up in atoms (s, atom, pre, column);
+ IF last search succeeded CAND last pattern in line found
+ THEN LEAVE try again
+ FI
+ PER;
+ column := 1;
+ last search succeeded := FALSE ;
+ LEAVE search up.
+
+ remember start point :
+ INT VAR c:= column, r:= s.lineno;.
+
+ last pattern in line found :
+ column := 2 ;
+ WHILE like pattern CAND right of start REP
+ column := matchpos (0) +1
+ PER ;
+ column DECR 1 ;
+ like pattern CAND right of start .
+
+ like pattern :
+ pat := any (column-1) ;
+ pat CAT any ;
+ pat CAT pattern0 ;
+ pat CAT any ;
+ record LIKE pat .
+
+ right of start : (r > s.lineno COR c >= matchpos(0)) .
+ record : atom (s.index).line .
+
+ENDPROC search up ;
+
+PROC up in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT VAR column) :
+
+ last search succeeded := FALSE ;
+ search backwards in actual line ;
+ IF NOT found AND s.line no > last search line
+ THEN search in preceeding lines
+ FI ;
+ IF found
+ THEN last search succeeded := TRUE
+ ELSE column := 1
+ FI .
+
+search backwards in actual line :
+ IF pattern = ""
+ THEN LEAVE search backwards in actual line
+ FI ;
+ INT VAR last pos , new pos := 0 ;
+ REP
+ last pos := new pos ;
+ new pos := pos (atom (s.index).line, pattern, last pos+1) ;
+ UNTIL new pos = 0 OR new pos > column PER ;
+ column := last pos .
+
+search in preceeding lines :
+ previous atom (s, atom) ;
+ IF pattern = ""
+ THEN column := LENGTH atom (s.index).line + 1 ;
+ last search succeeded := TRUE ;
+ LEAVE search in preceeding lines
+ FI ;
+ REP
+ search backwards through segment ;
+ update file position backwards ;
+ IF found OR s.line no = last search line
+ THEN LEAVE search in preceeding lines
+ ELSE previous segment (s, atom)
+ FI
+ PER .
+
+search backwards through segment :
+ INT VAR search index := s.index ,
+ last index := max (s.segment begin, s.index-(s.line no-last search line));
+ REP
+ new pos := 0 ;
+ REP
+ column := new pos ;
+ new pos := pos (atom (search index).line, pattern, column+1) ;
+ UNTIL new pos = 0 PER ;
+ IF found OR search index = last index
+ THEN LEAVE search backwards through segment
+ FI ;
+ search index DECR 1
+ PER .
+
+update file position backwards :
+ disable stop ;
+ s.line no DECR (s.index - search index) ;
+ s.index := search index ;
+ enable stop .
+
+found : column > 0 .
+
+ENDPROC up in atoms ;
+
+BOOL VAR last search succeeded ;
+
+BOOL PROC pattern found :
+ last search succeeded
+ENDPROC pattern found ;
+
+
+
+PROC delete atom (SEQUENCE VAR used, free, ATOMROW VAR atom) :
+
+ disable stop;
+ IF used.line no <= used.lines
+ THEN delete actual atom
+ ELSE errorstop ("'delete' am Dateiende")
+ FI .
+
+delete actual atom :
+ position behind actual free segment;
+ split segment (used, atom);
+ INT VAR actual index := used.index;
+ cut off tail of actual used segment;
+ delete segments (used, atom, actual index, actual index, 1);
+ insert segments (free, atom, actual index, actual index, 1) .
+
+position behind actual free segment :
+ IF free.line no <= free.lines
+ THEN next segment (free, atom)
+ FI .
+
+cut off tail of actual used segment :
+ IF actual index <> used.segment end
+ THEN used.index INCR 1;
+ split segment (used, atom);
+ used.index DECR 1
+ FI .
+
+END PROC delete atom;
+
+
+PROC insert atom (SEQUENCE VAR used, free,INT VAR unused, ATOMROW VAR atom) :
+
+ disable stop;
+ split segment (used, atom);
+ IF free.lines > 0
+ THEN insert new atom from free sequence
+ ELIF unused <= file size
+ THEN insert new atom from unused tail
+ ELSE errorstop ("FILE-Ueberlauf")
+ FI .
+
+insert new atom from free sequence :
+ get a free segments head;
+ make this atom to actual segment;
+ transfer from free to used chain .
+
+get a free segments head :
+ IF actual free segment is root segment
+ THEN previous segment (free, atom)
+ FI;
+ position to actual segments head .
+
+position to actual segments head :
+ INT VAR actual index := free.segment begin;
+ free.line no DECR (free.index - actual index);
+ free.index := actual index .
+
+make this atom to actual segment :
+ IF free.segment end > actual index
+ THEN free.index INCR 1;
+ split segment (free, atom);
+ free.index DECR 1
+ FI .
+
+transfer from free to used chain :
+ delete segments (free, atom, actual index, actual index, 1);
+ insert segments (used, atom, actual index, actual index, 1);
+ atom (actual index).line := "" .
+
+insert new atom from unused tail :
+ actual index := unused;
+ atom (actual index).seg :=
+ SEGMENT:(actual index, actual index, actual index);
+ atom (actual index).line := "";
+ insert segments (used, atom, actual index, actual index, 1);
+ unused INCR 1 .
+
+actual free segment is root segment : free.segment begin = free root .
+
+END PROC insert atom;
+
+
+PROC insert next (SEQUENCE VAR used, free, INT VAR unused, ATOMROW VAR atom,
+ TEXT CONST record) :
+
+ IF used.line no > used.lines
+ THEN insert atom (used, free, unused, atom)
+ ELIF actual position before unused nonempty atomrow part
+ THEN forward and insert atom by simple extension of used atomrow part
+ ELSE next atom (used, atom);
+ insert atom (used, free, unused, atom)
+ FI;
+ atom (used.index).line := record .
+
+forward and insert atom by simple extension of used atomrow part :
+ used.line no INCR 1;
+ used.lines INCR 1;
+ used.index INCR 1;
+ used.segment end INCR 1;
+ atom (used.segment begin).seg.end INCR 1;
+ unused INCR 1 .
+
+actual position before unused nonempty atomrow part :
+ used.index = unused - 1 AND unused part not empty .
+
+unused part not empty : unused <= file size .
+
+END PROC insert next;
+
+
+PROC transfer subsequence (SEQUENCE VAR source, dest,
+ ATOMROW VAR atom, INT CONST size) :
+
+ IF size > 0
+ THEN INT VAR subsequence size := min (size, source.line no);
+ mark begin of source part;
+ mark end of source part;
+ split destination sequence;
+ transfer part
+ FI .
+
+mark begin of source part :
+ previous atoms (source, atom, subsequence size - 1);
+ split segment (source, atom);
+ INT CONST first := source.segment begin .
+
+mark end of source part :
+ next atoms (source, atom, subsequence size - 1);
+ INT CONST last := source.segment begin;
+ next atom (source, atom);
+ split segment (source, atom) .
+
+split destination sequence :
+ split segment (dest, atom) .
+
+transfer part :
+ disable stop;
+ delete segments (source, atom, first, last, subsequence size);
+ source.line no DECR subsequence size;
+ insert segments (dest, atom, first, last, subsequence size);
+ next atoms (dest, atom, subsequence size - 1) .
+
+END PROC transfer subsequence;
+
+
+
+(********************************************************************)
+(***** *****)
+(***** FILE handler *****)
+(***** *****)
+(********************************************************************)
+
+
+
+LET file type = 1003 ,
+ file type 16 = 1002 ,
+
+ closed = 0,
+ inp = 1,
+ outp = 2,
+ mod = 3,
+ end = 4,
+
+ max limit = 16000,
+ super limit = 16001;
+
+
+TYPE TRANSPUTDIRECTION = INT;
+
+
+TRANSPUTDIRECTION PROC input :
+ TRANSPUTDIRECTION : (inp)
+END PROC input;
+
+
+TRANSPUTDIRECTION PROC output :
+ TRANSPUTDIRECTION : (outp)
+END PROC output;
+
+
+TRANSPUTDIRECTION PROC modify :
+ TRANSPUTDIRECTION : (mod)
+END PROC modify;
+
+
+FILE VAR result file;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ DATASPACE CONST ds) :
+ IF type (ds) = file type
+ THEN result := ds
+ ELIF type (ds) < 0
+ THEN result := ds; type (ds, file type); initialize (result file)
+ ELSE enable stop; errorstop ("Datenraum hat falschen Typ")
+ FI;
+ reset (result file, mode);
+ result file .
+
+result : CONCR (result file) .
+
+END PROC sequential file;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, TEXT CONST name) :
+
+ IF exists (name)
+ THEN get dataspace if file
+ ELIF CONCR (mode) <> inp
+ THEN get new file space
+ ELSE errorstop (""""+name+""" gibt es nicht") ; enable stop
+ FI;
+ update status if necessary;
+ reset (result file, mode);
+ result file .
+
+get dataspace if file :
+ IF type (old (name)) = file type 16
+ THEN reorganize (name)
+ FI ;
+ result := old (name, file type) ;
+ IF is 170 file
+ THEN result.col := 1 ;
+ result.mark line := 0 ;
+ result.mark col := 0
+ FI .
+
+is 170 file : result.mark col < 0 .
+
+get new file space :
+ result := new (name);
+ IF NOT is error
+ THEN type (old (name), file type); initialize (result file)
+ FI .
+
+update status if necessary :
+ IF CONCR (mode) <> inp
+ THEN status (name, ""); headline (result file, name)
+ FI .
+
+result : CONCR (result file) .
+
+END PROC sequential file;
+
+
+PROC reset (FILE VAR f) :
+
+ IF f.mode = end
+ THEN reset (f, input)
+ ELSE reset (f, TRANSPUTDIRECTION:(f.mode))
+ FI .
+
+ENDPROC reset ;
+
+PROC reset (FILE VAR f, TRANSPUTDIRECTION CONST mode) :
+
+ IF f.mode <> mod OR new mode <> mod
+ THEN f.mode := new mode ;
+ initialize file index
+ FI .
+
+initialize file index :
+ IF new mode = outp
+ THEN to line without check (f, f.used.lines);
+ col := super limit
+ ELSE to line without check (f, 1);
+ col := 1 ;
+ IF new mode = inp AND file is empty
+ THEN f.mode := end
+ FI
+ FI .
+
+file is empty : f.used.lines = 0 .
+
+new mode : CONCR (mode) .
+
+col : CONCR (CONCR (f)).col .
+
+END PROC reset;
+
+
+PROC input (FILE VAR f) :
+
+ reset (f, input) .
+
+END PROC input;
+
+
+PROC output (FILE VAR f) :
+
+ reset (f, output)
+
+END PROC output;
+
+
+PROC modify (FILE VAR f) :
+
+ reset (f, modify)
+
+END PROC modify;
+
+
+PROC close (FILE VAR f) :
+
+ f.mode := closed .
+
+END PROC close;
+
+
+PROC check mode (FILE CONST f, INT CONST mode) :
+
+ IF f.mode = mode
+ THEN LEAVE check mode
+ ELIF f.mode = closed
+ THEN errorstop ("Datei zu!")
+ ELIF f.mode = mod
+ THEN errorstop ("unzulaessiger Zugriff auf modify-FILE")
+ ELIF mode = mod
+ THEN errorstop ("Zugriff nur auf modify-FILE zulaessig")
+ ELIF f.mode = end
+ THEN errorstop ("Leseversuch nach Dateiende")
+ ELIF mode = inp
+ THEN errorstop ("Leseversuch auf output-FILE")
+ ELIF mode = outp
+ THEN errorstop ("Schreibversuch auf input-FILE")
+ FI .
+
+END PROC check mode;
+
+
+PROC to line without check (FILE VAR f, INT CONST destination line) :
+
+ INT CONST distance := destination line - f.used.line no;
+ IF distance > 0
+ THEN next atoms (f.used, f.atoms, distance)
+ ELIF distance < 0
+ THEN previous atoms (f.used, f.atoms, - distance)
+ FI .
+
+END PROC to line without check;
+
+
+PROC to line (FILE VAR f, INT CONST destination line) :
+
+ check mode (f, mod);
+ to line without check (f, destination line)
+
+END PROC to line;
+
+
+PROC to first record (FILE VAR f) :
+
+ to line (f, 1)
+
+END PROC to first record;
+
+
+PROC to eof (FILE VAR f) :
+
+ to line (f, f.used.lines + 1) .
+
+END PROC to eof;
+
+
+PROC putline (FILE VAR f, TEXT CONST word) :
+
+ write (f, word);
+ col := super limit .
+
+col : CONCR (CONCR (f)).col .
+
+END PROC putline;
+
+
+PROC delete record (FILE VAR f) :
+
+ check mode (f, mod);
+ delete atom (f.used, f.free, f.atoms) .
+
+END PROC delete record;
+
+
+PROC insert record (FILE VAR f) :
+
+ check mode (f, mod);
+ insert atom (f.used, f.free, f.unused tail, f.atoms) .
+
+END PROC insert record;
+
+
+PROC down (FILE VAR f) :
+
+ check mode (f, mod);
+ next atom (f.used, f.atoms) .
+
+END PROC down ;
+
+PROC up (FILE VAR f) :
+
+ check mode (f, mod);
+ previous atom (f.used, f.atoms) .
+
+END PROC up ;
+
+PROC down (FILE VAR f, INT CONST n) :
+
+ to line (f, lineno (f) + n)
+
+ENDPROC down ;
+
+PROC up (FILE VAR f, INT CONST n) :
+
+ to line (f, lineno (f) - n)
+
+ENDPROC up ;
+
+
+PROC write record (FILE VAR f, TEXT CONST record) :
+
+ check mode (f, mod);
+ IF not at eof
+ THEN f.atoms (f.used.index).line := record
+ ELSE errorstop ("'write' nach Dateiende")
+ FI .
+
+not at eof : f.used.line no <= f.used.lines .
+
+END PROC write record;
+
+
+PROC read record (FILE CONST f, TEXT VAR record) :
+
+ check mode (f, mod);
+ record := f.atoms (f.used.index).line .
+
+END PROC read record;
+
+
+PROC line (FILE VAR f) :
+
+ IF mode = end
+ THEN errorstop ("Leseversuch nach Dateiende")
+ ELIF mode = inp
+ THEN next atom (f.used, f.atoms); col := 1; check eof
+ ELIF mode = outp
+ THEN IF col <= max limit
+ THEN col := super limit
+ ELSE append empty line
+ FI
+ FI .
+
+append empty line :
+ insert next (f.used, f.free, f.unused tail, f.atoms, "") .
+
+col : CONCR (CONCR (f)).col .
+
+mode : CONCR (CONCR (f)).mode .
+
+check eof :
+ IF eof (f) THEN mode := end FI .
+
+END PROC line;
+
+
+PROC line (FILE VAR f, INT CONST lines) :
+
+ INT VAR i; FOR i FROM 1 UPTO lines REP line (f) PER
+
+END PROC line;
+
+
+PROC getline (FILE VAR f, TEXT VAR text) :
+
+ check mode (f, inp);
+ text := subtext (record, f.col);
+ IF f.used.line no >= f.used.lines
+ THEN f.mode := end ;
+ set end of file
+ ELSE to next line ;
+ f.col := 1
+ FI .
+
+to next line :
+ next atom (f.used, f.atoms) .
+
+set end of file :
+ f.col := LENGTH record + 1 .
+
+record : f.atoms (f.used.index).line .
+
+END PROC getline;
+
+
+BOOL PROC is first record (FILE CONST f) :
+
+ check mode (f, mod);
+ f.used.line no = 1 .
+
+END PROC is first record;
+
+
+BOOL PROC eof (FILE CONST f) :
+
+ IF line no < lines THEN FALSE
+ ELIF line no = lines THEN col > LENGTH record
+ ELSE TRUE
+ FI .
+
+line no : f.used.line no .
+lines : f.used.lines .
+col : f.col .
+record : f.atoms (f.used.index).line .
+
+END PROC eof;
+
+
+INT PROC line no (FILE CONST f) :
+
+ f.used.line no .
+
+END PROC line no;
+
+
+PROC line type (FILE VAR f, INT CONST t) :
+
+ f.atoms (f.used.index).type := t .
+
+ENDPROC line type ;
+
+INT PROC line type (FILE CONST f) :
+
+ f.atoms (f.used.index).type .
+
+ENDPROC line type ;
+
+
+PROC put (FILE VAR f, TEXT CONST word) :
+
+ check mode (f, outp);
+ IF col + LENGTH word > f.limit
+ THEN append new line
+ ELSE record CAT word
+ FI;
+ record CAT " ";
+ col := LENGTH record + 1 .
+
+append new line :
+ insert next (f.used, f.free, f.unused tail, f.atoms, word) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+END PROC put;
+
+
+PROC put (FILE VAR f, INT CONST value) :
+
+ put (f, text (value))
+
+END PROC put;
+
+
+PROC put (FILE VAR f, REAL CONST real) :
+
+ put (f, text (real))
+
+END PROC put;
+
+
+PROC write (FILE VAR f, TEXT CONST word) :
+
+ check mode (f, outp);
+ IF col + LENGTH word - 1 > f.limit
+ THEN append new line
+ ELSE record CAT word
+ FI;
+ col := LENGTH record + 1 .
+
+append new line :
+ insert next (f.used, f.free, f.unused tail, f.atoms, word) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+END PROC write;
+
+
+PROC get (FILE VAR f, TEXT VAR word, TEXT CONST separator) :
+
+ check mode (f, inp);
+ skip separators;
+ IF word found
+ THEN get word
+ ELSE try to find word in next line
+ FI .
+
+skip separators :
+ INT CONST separator length := LENGTH separator;
+ WHILE is separator REP col INCR separator length PER .
+
+is separator :
+ subtext (record, col, col + separator length - 1) = separator .
+
+word found : col <= LENGTH record .
+
+get word :
+ INT VAR end of word := pos (record, separator, col) - 1;
+ IF separator found
+ THEN get text upto separator
+ ELSE get rest of record
+ FI .
+
+separator found : end of word >= 0 .
+
+get text upto separator :
+ word := subtext (record, col, end of word);
+ col := end of word + separator length + 1;
+ IF col > LENGTH record THEN line (f) FI .
+
+get rest of record :
+ word := subtext (record, col); line (f) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+try to find word in next line :
+ line (f); IF eof (f) THEN word := "" ELSE get (f, word, separator) FI .
+
+END PROC get;
+
+
+PROC get (FILE VAR f, TEXT VAR word, INT CONST max length) :
+
+ check mode (f, inp);
+ IF word is only a part of record
+ THEN get text of certain length
+ ELSE get rest of record
+ FI .
+
+word is only a part of record :
+ col <= LENGTH record - max length .
+
+get text of certain length :
+ word := text (record, max length, col);
+ col INCR max length .
+
+get rest of record :
+ word := subtext (record, col); line (f) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+END PROC get;
+
+
+PROC get (FILE VAR f, TEXT VAR word) :
+
+ get (f, word, " ")
+
+END PROC get;
+
+
+TEXT VAR number word;
+
+
+PROC get (FILE VAR f, INT VAR number) :
+
+ get (f, number word);
+ number := int (number word)
+
+END PROC get;
+
+
+PROC get (FILE VAR f, REAL VAR number) :
+
+ get (f, number word);
+ number := real (number word)
+
+END PROC get;
+
+
+TEXT VAR split record ;
+INT VAR indentation ;
+
+PROC split line (FILE VAR f, INT CONST split col) :
+
+ split line (f, split col, TRUE)
+
+ENDPROC split line ;
+
+PROC split line (FILE VAR f, INT CONST split col, BOOL CONST note indentation ) :
+
+ IF note indentation
+ THEN get indentation
+ ELSE indentation := 0
+ FI ;
+ get split record ;
+ insert split record and indentation ;
+ cut off old record .
+
+get indentation :
+ indentation := pos (actual record,""33"",""254"",1) - 1 ;
+ IF indentation < 0 OR indentation >= split col
+ THEN indentation := split col - 1
+ FI .
+
+get split record :
+ split record := subtext (actual record, split col, max limit) .
+
+insert split record and indentation :
+ down (f) ;
+ insert record (f) ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO indentation REP
+ actual record CAT " "
+ PER ;
+ actual record CAT split record ;
+ up (f) .
+
+cut off old record :
+ actual record := subtext (actual record, 1, split col-1) .
+
+actual record : f.atoms (f.used.index).line .
+
+ENDPROC split line ;
+
+PROC concatenate line (FILE VAR f, BOOL CONST delete blanks) :
+
+ down (f) ;
+ split record := actual record ;
+ IF delete blanks
+ THEN delete leading blanks
+ FI ;
+ delete record (f) ;
+ up (f) ;
+ actual record CAT split record .
+
+delete leading blanks :
+ INT CONST non blank col := pos (split record, ""33"", ""254"", 1) ;
+ IF non blank col > 0
+ THEN split record := subtext (split record, non blank col)
+ FI .
+
+actual record : f.atoms (f.used.index).line .
+
+ENDPROC concatenate line ;
+
+PROC concatenate line (FILE VAR f) :
+ concatenate line (f, TRUE)
+ENDPROC concatenate line ;
+
+PROC reorganize :
+
+ reorganize (last param)
+
+END PROC reorganize;
+
+
+TEXT VAR file record ;
+
+PROC reorganize (TEXT CONST file name) :
+
+ enable stop ;
+ FILE VAR input file, output file;
+ DATASPACE VAR scratch space;
+ INT CONST type of dataspace := type (old (file name)) ;
+ INT VAR counter;
+
+ last param (file name);
+ IF type of dataspace = file type
+ THEN reorganize new to new
+ ELIF type of dataspace = file type 16
+ THEN reorganize old to new
+ ELSE errorstop ("Datenraum hat falschen Typ")
+ FI;
+ replace file space by scratch space .
+
+reorganize new to new :
+ input file := sequential file (input, file name);
+ disable stop ;
+ scratch space := nilspace ;
+ output file := sequential file (output, scratch space);
+ copy attributes (input file, output file) ;
+
+ FOR counter FROM 1 UPTO 9999
+ WHILE NOT eof (input file) REP
+ cout (counter);
+ getline (input file, file record);
+ putline (output file, file record);
+ check for interrupt
+ PER .
+
+reorganize old to new :
+ LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT record);
+ LET OLDFILE = BOUND ROW 4075 OLDRECORD;
+ LET dateianker = 2, freianker = 1;
+ INT VAR index := dateianker;
+
+ OLDFILE VAR old file := old (file name);
+ disable stop;
+ scratch space := nilspace;
+ output file := sequential file (output, scratch space);
+ get old attributes ;
+
+ say ("Datei wird in 1.7-Format gewandelt: ") ;
+
+ FOR counter FROM 1 UPTO 9999
+ WHILE NOT end of old file REP
+ cout (counter);
+ index := next record;
+ file record := record of old file ;
+ IF pos (file record, ""128"", ""250"", 1) > 0
+ THEN change special chars
+ FI ;
+ putline (output file, file record);
+ check for interrupt
+ PER .
+
+get old attributes :
+ get old headline ;
+ get old limit and tabs .
+
+get old headline :
+ headline (output file, old file (dateianker).record) .
+
+get old limit and tabs :
+ file record := old file (freianker).record ;
+ max line length (output file, int (subtext (file record, 11, 15))) ;
+ put tabs (output file, subtext (file record, 16)) .
+
+change special chars :
+ change all (file record, ""193"", ""214"") (* Ae *) ;
+ change all (file record, ""207"", ""215"") (* Oe *) ;
+ change all (file record, ""213"", ""216"") (* Ue *) ;
+ change all (file record, ""225"", ""217"") (* ae *) ;
+ change all (file record, ""239"", ""218"") (* oe *) ;
+ change all (file record, ""245"", ""219"") (* ue *) ;
+ change all (file record, ""235"", ""220"") (* k *) ;
+ change all (file record, ""173"", ""221"") (* - *) ;
+ change all (file record, ""163"", ""222"") (* fis *) ;
+ change all (file record, ""160"", ""223"") (* blank *) ;
+ change all (file record, ""194"", ""251"") (* eszet *) .
+
+end of old file : next record = dateianker .
+
+next record : old file (index).succ .
+
+record of old file : old file (index).record .
+
+check for interrupt :
+ INT VAR size, used ;
+ storage (size, used) ;
+ IF used > size
+ THEN errorstop ("Speicherengpass")
+ FI ;
+ IF is error
+ THEN forget (scratch space) ; LEAVE reorganize
+ FI .
+
+replace file space by scratch space :
+ headline (output file, file name);
+ forget (file name, quiet) ;
+ type (scratch space, file type);
+ copy (scratch space, file name);
+ forget (scratch space) .
+
+END PROC reorganize;
+
+
+PROC set range (FILE VAR f, INT CONST start line, start col,
+ FRANGE VAR old range) :
+
+ check mode (f, mod);
+ IF valid restriction parameters
+ THEN prepare last line ;
+ prepare first line ;
+ save old range ;
+ set new range
+ ELSE errorstop ("FRANGE ungueltig")
+ FI .
+
+valid restriction parameters :
+ start line > 0 AND start col > 0 AND start before or at actual point .
+
+start before or at actual point :
+ start line < line no (f) OR
+ start line = line no (f) AND start col <= col (f) .
+
+prepare last line :
+ INT VAR last line ;
+ IF col (f) > 1
+ THEN split line (f, col(f), FALSE)
+ FI .
+
+prepare first line :
+ IF start col > 1
+ THEN split start line ;
+ FI .
+
+split start line :
+ INT VAR old line no := line no (f) ;
+ to line (f, start line) ;
+ split line (f, start col, FALSE) ;
+ to line (f, old line no + 1) .
+
+save old range :
+ old range.pre := f.prefix lines ;
+ old range.post:= f.postfix lines .
+
+set new range :
+ get pre lines ;
+ get post lines ;
+ disable stop ;
+ f.prefix lines INCR pre lines ;
+ f.postfix lines INCR post lines ;
+ f.used.lines DECR (post lines + pre lines) ;
+ f.used.line no DECR pre lines .
+
+get pre lines :
+ INT VAR pre lines ;
+ IF start col = 1
+ THEN old range.pre was split := FALSE ;
+ pre lines := start line - 1
+ ELSE old range.pre was split := TRUE ;
+ pre lines := start line
+ FI .
+
+get post lines :
+ INT VAR post lines ;
+ IF col (f) = 1
+ THEN old range.post was split := FALSE ;
+ post lines := lines (f) - line no (f) + 1
+ ELSE old range.post was split := TRUE ;
+ post lines := lines (f) - line no (f)
+ FI .
+
+END PROC set range;
+
+
+PROC set range (FILE VAR f, FRANGE VAR new range) :
+
+ check mode (f, mod);
+ INT CONST pre add := prefix - new range.pre,
+ post add := postfix - new range.post;
+ IF pre add < 0 OR post add < 0
+ THEN errorstop ("FRANGE ungueltig")
+ ELSE set new range;
+ undo splitting if necessary ;
+ make range var invalid
+ FI .
+
+set new range :
+ disable stop;
+ prefix DECR pre add;
+ postfix DECR post add;
+ used.line no INCR pre add;
+ used.lines INCR (pre add + post add) .
+
+undo splitting if necessary :
+ IF new range.pre was split
+ THEN concatenate first line
+ FI ;
+ IF new range.post was split
+ THEN concatenate last line
+ FI .
+
+concatenate first line :
+ INT VAR old line := line no (f) ;
+ to line (f, pre add) ;
+ concatenate line (f, FALSE) ;
+ to line (f, old line - 1) .
+
+concatenate last line :
+ old line := line no (f) ;
+ to line (f, lines (f) - post add) ;
+ concatenate line (f, FALSE) ;
+ to line (f, old line) .
+
+make range var invalid :
+ new range.pre := maxint .
+
+used : f.used .
+prefix : f.prefix lines .
+postfix : f.postfix lines .
+
+END PROC set range;
+
+PROC reset range (FILE VAR f) :
+
+ FRANGE VAR complete ;
+ complete.pre := 0 ;
+ complete.post:= 0 ;
+ complete.pre was split := FALSE ;
+ complete.post was split:= FALSE ;
+ set range (f, complete)
+
+ENDPROC reset range ;
+
+PROC remove (FILE VAR f, INT CONST size) :
+
+ check mode (f, mod);
+ transfer subsequence (f.used, f.scratch, f.atoms, size) .
+
+END PROC remove;
+
+
+PROC clear removed (FILE VAR f) :
+
+ check mode (f, mod);
+ transfer subsequence (f.scratch, f.free, f.atoms, f.scratch.lines) .
+
+END PROC clear removed;
+
+
+PROC reinsert (FILE VAR f) :
+
+ check mode (f, mod);
+ transfer subsequence (f.scratch, f.used, f.atoms, f.scratch.lines) .
+
+END PROC reinsert;
+
+
+PROC copy attributes (FILE CONST source file, FILE VAR dest file) :
+
+ dest.limit := source.limit ;
+ dest.atoms (free root).line := source.atoms (free root).line ;
+ dest.atoms (scratch root).line := source.atoms (scratch root).line ;
+ dest.edit info := source.edit info .
+
+dest : CONCR (CONCR (dest file)) .
+source : CONCR (CONCR (source file)) .
+
+ENDPROC copy attributes ;
+
+
+INT PROC max line length (FILE CONST f) :
+
+ f.limit .
+
+END PROC max line length;
+
+
+PROC max line length (FILE VAR f, INT CONST new limit) :
+
+ IF new limit > 0 AND new limit <= max limit
+ THEN f.limit := new limit
+ FI .
+
+END PROC max line length;
+
+
+TEXT PROC headline (FILE CONST f) :
+
+ f.atoms (free root).line .
+
+END PROC headline;
+
+
+PROC headline (FILE VAR f, TEXT CONST head) :
+
+ f.atoms (free root).line := head .
+
+END PROC headline;
+
+
+PROC get tabs (FILE CONST f, TEXT VAR tabs) :
+
+ tabs := f.atoms (scratch root).line .
+
+END PROC get tabs;
+
+
+PROC put tabs (FILE VAR f, TEXT CONST tabs) :
+
+ f.atoms (scratch root).line := tabs .
+
+END PROC put tabs;
+
+
+INT PROC edit info (FILE CONST f) :
+
+ f.edit info .
+
+END PROC edit info;
+
+
+PROC edit info (FILE VAR f, INT CONST info) :
+
+ f.edit info := info .
+
+END PROC edit info;
+
+
+INT PROC lines (FILE CONST f) :
+
+ f.used.lines .
+
+END PROC lines;
+
+
+INT PROC removed lines (FILE CONST f) :
+
+ f.scratch.lines .
+
+END PROC removed lines;
+
+
+INT PROC segments (FILE CONST f) :
+
+ segs(f.used,f.atoms) + segs(f.scratch,f.atoms) + segs(f.free,f.atoms) - 2 .
+
+ENDPROC segments ;
+
+
+INT PROC col (FILE CONST f) :
+
+ f.col
+
+ENDPROC col ;
+
+PROC col (FILE VAR f, INT CONST new column) :
+
+ IF new column > 0
+ THEN f.col := new column
+ FI
+
+ENDPROC col ;
+
+TEXT PROC word (FILE CONST f) :
+
+ word (f, " ")
+
+ENDPROC word ;
+
+TEXT PROC word (FILE CONST f, TEXT CONST delimiter) :
+
+ INT VAR del pos := pos (f, delimiter, col (f)) ;
+ IF del pos = 0
+ THEN del pos := len (f) + 1
+ FI ;
+ subtext (f, col (f), del pos - 1)
+
+ENDPROC word ;
+
+TEXT PROC word (FILE CONST f, INT CONST max length) :
+
+ subtext (f, col (f), col (f) + max length - 1)
+
+ENDPROC word ;
+
+BOOL PROC at (FILE CONST f, TEXT CONST word) :
+
+ pat := any (column-1) ;
+ pat CAT word ;
+ pat CAT any ;
+ record LIKE pat .
+
+column : f.col .
+record : f.atoms (f.used.index).line .
+
+ENDPROC at ;
+
+
+PROC exec (PROC (TEXT VAR, TEXT CONST) proc, FILE VAR f, TEXT CONST t) :
+
+ proc (record, t) .
+
+record : f.atoms (f.used.index).line .
+
+END PROC exec;
+
+
+PROC exec (PROC (TEXT VAR, INT CONST) proc, FILE VAR f, INT CONST i) :
+
+ proc (record, i) .
+
+record : f.atoms (f.used.index).line .
+
+END PROC exec;
+
+INT PROC pos (FILE CONST f, TEXT CONST pattern, INT CONST i) :
+
+ pos (record, pattern, i) .
+
+record : f.atoms (f.used.index).line .
+
+END PROC pos ;
+
+PROC down (FILE VAR f, TEXT CONST pattern) :
+
+ down (f, pattern, file size)
+
+ENDPROC down ;
+
+PROC down (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col + 1 ;
+ search down (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC down ;
+
+PROC downety (FILE VAR f, TEXT CONST pattern) :
+
+ downety (f, pattern, file size)
+
+ENDPROC downety ;
+
+PROC downety (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col ;
+ search down (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC downety ;
+
+PROC up (FILE VAR f, TEXT CONST pattern) :
+
+ up (f, pattern, file size)
+
+ENDPROC up ;
+
+PROC up (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col - 1 ;
+ search up (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC up ;
+
+PROC uppety (FILE VAR f, TEXT CONST pattern) :
+
+ uppety (f, pattern, file size)
+
+ENDPROC uppety ;
+
+PROC uppety (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col ;
+ search up (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC uppety ;
+
+
+INT PROC len (FILE CONST f) :
+
+ length (record) .
+
+record : f.atoms (f.used.index).line .
+
+ENDPROC len ;
+
+TEXT PROC subtext (FILE CONST f, INT CONST from, to) :
+
+ subtext (record, from, to) .
+
+record : f.atoms (f.used.index).line .
+
+ENDPROC subtext ;
+
+PROC change (FILE VAR f, INT CONST from, to, TEXT CONST new) :
+
+ check mode (f, mod) ;
+ change (record, from, to, new) .
+
+record : f.atoms (f.used.index).line .
+
+ENDPROC change ;
+
+
+BOOL PROC mark (FILE CONST f) :
+
+ f.mark line > 0
+
+ENDPROC mark ;
+
+PROC mark (FILE VAR f, INT CONST line no, col) :
+
+ IF line no > 0
+ THEN f.mark line := line no + f.prefix lines ;
+ f.mark col := col
+ ELSE f.mark line := 0 ;
+ f.mark col := 0
+ FI
+
+ENDPROC mark ;
+
+INT PROC mark line no (FILE CONST f) :
+
+ IF f.mark line = 0
+ THEN 0
+ ELSE max (1, f.mark line - f.prefix lines)
+ FI
+
+ENDPROC mark line no ;
+
+INT PROC mark col (FILE CONST f) :
+
+ IF f.mark line = 0
+ THEN 0
+ ELIF f.mark line <= f.prefix lines
+ THEN 1
+ ELSE f.mark col
+ FI
+
+ENDPROC mark col ;
+
+PROC set marked range (FILE VAR f, FRANGE VAR old range) :
+
+ IF mark (f)
+ THEN set range (f, mark line no (f), mark col (f), old range)
+ ELSE old range := previous range of file
+ FI .
+
+previous range of file :
+ FRANGE : (f.prefix lines, f.postfix lines, FALSE, FALSE) .
+
+ENDPROC set marked range ;
+
+
+(*****************************************************************)
+
+ (* Autor: P.Heyderhoff *)
+ (* Stand: 11.10.83 *)
+
+BOUND LIST VAR datei;
+INT VAR sortierstelle, sortanker;
+BOOL VAR ascii sort;
+TEXT VAR median, tausch , links, rechts;
+
+PROC sort (TEXT CONST dateiname) :
+ sort (dateiname, 1)
+END PROC sort;
+
+PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ ascii sort := TRUE ;
+ sortierstelle := sortieranfang; sortiere (dateiname)
+END PROC sort;
+
+PROC lex sort (TEXT CONST dateiname) :
+ lex sort (dateiname, 1)
+ENDPROC lex sort ;
+
+PROC lex sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ ascii sort := FALSE ;
+ sortierstelle := sortieranfang; sortiere (dateiname)
+ENDPROC lex sort ;
+
+PROC sortiere (TEXT CONST dateiname) :
+
+ reorganize file if necessary ;
+ sort file .
+
+reorganize file if necessary :
+ FILE VAR f := sequential file (modify, dateiname) ;
+ IF segments (f) > 1
+ THEN reorganize (dateiname)
+ FI .
+
+sort file :
+ f := sequential file (modify, dateiname) ;
+ INT CONST sortende := lines (f) + 3 ;
+ sortanker := 1 + 3 ;
+ datei := old (dateiname) ;
+ quicksort(sortanker, sortende) .
+
+END PROC sortiere;
+
+PROC quicksort ( INT CONST anfang, ende ) :
+ IF anfang < ende
+ THEN INT VAR p,q;
+ spalte (anfang, ende, p, q);
+ quicksort (anfang, q);
+ quicksort (p, ende) FI
+END PROC quicksort;
+
+PROC spalte (INT CONST anfang, ende, INT VAR p, q):
+ fange an der seite an und waehle den median;
+ ruecke p und q so dicht wie moeglich zusammen;
+ hole ggf median in die mitte .
+
+ fange an der seite an und waehle den median :
+ p := anfang; q := ende ;
+ INT CONST m :: (p + q) DIV 2 ;
+ median := subtext(datei m, sortierstelle) .
+
+ ruecke p und q so dicht wie moeglich zusammen :
+ REP schiebe p und q so weit wie moeglich auf bzw ab;
+ IF p < q THEN vertausche die beiden FI
+ UNTIL p > q END REP .
+
+ vertausche die beiden :
+ tausch := datei p; datei p := datei q; datei q := tausch;
+ p INCR 1; q DECR 1 .
+
+ schiebe p und q so weit wie moeglich auf bzw ab :
+ WHILE p kann groesser werden REP p INCR 1 END REP;
+ WHILE q kann kleiner werden REP q DECR 1 END REP .
+
+ p kann groesser werden :
+ IF p <= ende
+ THEN links := subtext (datei p, sortierstelle) ;
+ IF ascii sort
+ THEN median >= links
+ ELSE median LEXGREATEREQUAL links
+ FI
+ ELSE FALSE
+ FI .
+
+ q kann kleiner werden :
+ IF q >= anfang
+ THEN rechts := subtext(datei q, sortierstelle) ;
+ IF ascii sort
+ THEN rechts >= median
+ ELSE rechts LEXGREATEREQUAL median
+ FI
+ ELSE FALSE
+ FI .
+
+ hole ggf median in die mitte :
+ IF m < q THEN vertausche m und q
+ ELIF m > p THEN vertausche m und p FI .
+
+ vertausche m und q :
+ tausch := datei m; datei m := datei q; datei q := tausch; q DECR 1 .
+
+ vertausche m und p :
+ tausch := datei m; datei m := datei p; datei p := tausch; p INCR 1 .
+
+ datei m : datei.atoms (m).line .
+ datei p : datei.atoms (p).line .
+ datei q : datei.atoms (q).line .
+
+END PROC spalte;
+
+END PACKET file handling;
+
diff --git a/system/base/1.7.5/src/functions b/system/base/1.7.5/src/functions
new file mode 100644
index 0000000..9f338ff
--- /dev/null
+++ b/system/base/1.7.5/src/functions
@@ -0,0 +1,760 @@
+PACKET editor functions DEFINES (* FUNCTIONS - 052 *)
+ (**************) (* 17.07.85 -bk- *)
+ (* 10.09.85 -ws- *)
+ edit, (* 25.04.86 -sh- *)
+ show, (* 27.05.86 -wk- *)
+ U,
+ D,
+ T,
+ up,
+ down,
+ downety,
+ uppety,
+ to line,
+ PUT,
+ GET,
+ P,
+ G,
+ limit,
+ len,
+ eof,
+ C,
+ change to,
+ CA,
+ change all,
+ lines,
+ line no,
+ col,
+ mark,
+ at,
+ word,
+ std kommando interpreter,
+ note,
+ note line,
+ note edit,
+ anything noted,
+ note file:
+
+
+LET marker = "^",
+ ersatzmarker = "'",
+ schritt = 50,
+ file size = 4072,
+ write acc = TRUE,
+ read acc = FALSE;
+
+LET bold = 2,
+ integer = 3,
+ string = 4,
+ end of file = 7;
+
+LET std res = "eqvw19dpgn"9"";
+
+FILE VAR edfile;
+BOOL VAR from scratchfile :: FALSE;
+TEXT VAR kommandotext, tabulator, zeile;
+
+
+PROC std kommando interpreter (TEXT CONST taste) :
+ enable stop ;
+ edfile := editfile;
+ set busy indicator;
+ SELECT pos (std res, taste) OF
+ CASE 1 (*e*) : edit
+ CASE 2 (*q*) : quit
+ CASE 3 (*v*) : quit last
+ CASE 4 (*w*) : open editor (next editor)
+ CASE 5 (*1*) : toline (1); col (1)
+ CASE 6 (*9*) : toline (lines); col (len+1)
+ CASE 7 (*d*) : d case
+ CASE 8 (*p*) : p case
+ CASE 9 (*g*) : g case
+ CASE 10(*n*) : note edit
+ CASE 11(*tab*): change tabs
+ OTHERWISE : echtes kommando analysieren
+ END SELECT .
+
+d case :
+ IF mark
+ THEN PUT ""; mark (FALSE); from scratchfile := TRUE
+ ELSE textzeile auf taste legen
+ FI .
+
+p case :
+ IF mark (*sh*)
+ THEN IF write permission
+ THEN PUT ""; push(""27""12""); from scratchfile := TRUE
+ ELSE out (""7"")
+ FI
+ ELSE textzeile auf taste legen
+ FI .
+
+g case :
+ IF write permission (*sh*)
+ THEN IF from scratchfile
+ THEN GET ""
+ ELSE IF is editget
+ THEN push (lernsequenz auf taste ("g")); nichts neu
+ FI
+ FI
+ ELSE out (""7"")
+ FI .
+
+textzeile auf taste legen :
+ read record (edfile, zeile);
+ zeile := subtext (zeile, col);
+ lernsequenz auf taste legen ("g", zeile);
+ from scratchfile := FALSE; zeile neu .
+
+next editor :
+ (aktueller editor MOD groesster editor) + 1 .
+
+change tabs :
+ get tabs (edfile, tabulator) ;
+ IF pos (tabulator, marker) <> 0
+ THEN change all (tabulator, marker, ersatzmarker)
+ ELSE change all (tabulator, ersatzmarker, marker)
+ FI ;
+ put tabs (edfile, tabulator) ;
+ ueberschrift neu .
+
+echtes kommando analysieren :
+ kommandotext := kommando auf taste (taste);
+ IF kommandotext = ""
+ THEN nichts neu; LEAVE std kommando interpreter
+ FI ;
+ scan (kommandotext);
+ TEXT VAR s1; INT VAR t1; next symbol (s1, t1);
+ TEXT VAR s2; INT VAR t2; next symbol (s2, t2);
+ IF t1 = integer AND t2 = end of file THEN toline (int (s1))
+ ELIF t1 = string AND t2 = end of file THEN down (s1)
+ ELIF perhaps simple up or down THEN
+ ELIF perhaps simple changeto THEN
+ ELSE do (kommandotext)
+ FI .
+
+perhaps simple up or down :
+ IF t1 = bold
+ THEN TEXT VAR s3; INT VAR t3; next symbol (s3, t3);
+ IF t3 <> end of file THEN FALSE
+ ELIF s1 = "U" THEN perhaps simple up
+ ELIF s1 = "D" THEN perhaps simple down
+ ELSE FALSE
+ FI
+ ELSE FALSE
+ FI .
+
+perhaps simple up :
+ IF t2 = string THEN up (s2); TRUE
+ ELIF t2 = integer THEN up (int (s2)); TRUE
+ ELSE FALSE
+ FI .
+
+perhaps simple down :
+ IF t2 = string THEN down (s2); TRUE
+ ELIF t2 = integer THEN down (int (s2)); TRUE
+ ELSE FALSE
+ FI .
+
+perhaps simple changeto :
+ IF t1 = string AND s2 = "C" AND t3 is string AND t4 is eof
+ THEN s1 C s3; TRUE
+ ELSE FALSE
+ FI .
+
+t3 is string :
+ next symbol (s3, t3);
+ t3 = string .
+
+t4 is eof :
+ TEXT VAR s4; INT VAR t4;
+ next symbol (s4, t4);
+ t4 = end of file .
+END PROC std kommando interpreter;
+
+
+PROC edit (FILE VAR f) :
+ enable stop;
+ IF aktueller editor > 0 (*wk*)
+ THEN ueberschrift neu
+ FI ;
+ open editor (f, write acc);
+ edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter)
+END PROC edit;
+
+
+PROC edit (FILE VAR f, INT CONST x, y, x size, y size) :
+ enable stop;
+ open editor (groesster editor + 1, f, write acc, x, y, x size, y size);
+ edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter)
+END PROC edit;
+
+
+PROC edit (FILE VAR f, TEXT CONST res, PROC (TEXT CONST) kdo interpreter) :
+ enable stop;
+ open editor (f, write acc);
+ edit (groesster editor, res, PROC(TEXT CONST) kdo interpreter)
+END PROC edit;
+
+
+PROC edit :
+ IF aktueller editor > 0
+ THEN dateiname einlesen;
+ edit (dateiname)
+ ELSE edit (last param)
+ FI .
+
+dateiname einlesen :
+ INT VAR x, y; get editcursor (x, y);
+ IF x < x size - 17 (*sh*)
+ THEN cursor (x, y);
+ out (""15"Dateiname:"14"");
+ (x size-14-x) TIMESOUT " ";
+ (x size-14-x) TIMESOUT ""8"";
+ TEXT VAR dateiname := std;
+ editget (dateiname);
+ trailing blanks entfernen;
+ quotes entfernen
+ ELSE errorstop ("Fenster zu klein")
+ FI .
+
+trailing blanks entfernen:
+ INT VAR i := LENGTH dateiname;
+ WHILE (dateiname SUB i) = " " REP i DECR 1 PER;
+ dateiname := subtext (dateiname, 1, i) .
+
+quotes entfernen :
+ IF (dateiname SUB 1) = """" AND (dateiname SUB LENGTH dateiname) = """"
+ THEN dateiname := subtext (dateiname, 2, LENGTH dateiname - 1)
+ FI .
+END PROC edit;
+
+
+PROC edit (TEXT CONST filename) :
+ IF filename <> ""
+ THEN edit named file
+ ELSE errorstop ("Name ungueltig")
+ FI .
+
+edit named file :
+ last param (filename);
+ IF exists (filename) COR yes ("""" + filename + """ neu einrichten")
+ THEN IF aktueller editor > 0 THEN ueberschrift neu FI; (*sh*)
+ FILE VAR f := sequential file (modify, filename);
+ headline (f, filename); edit (f); last param (filename)
+ ELSE errorstop ("")
+ FI .
+END PROC edit;
+
+
+PROC edit (TEXT CONST filename, INT CONST x, y, x size, y size) :
+ last param (filename);
+ IF exists (filename) COR yes ("""" + filename + """ neu einrichten")
+ THEN FILE VAR f := sequential file (modify, filename);
+ headline (f, filename); edit (f, x, y, x size, y size);
+ last param (filename)
+ ELSE errorstop ("")
+ FI
+END PROC edit;
+
+
+PROC edit (INT CONST i) :
+ edit (i, std res, PROC (TEXT CONST) std kommando interpreter)
+END PROC edit;
+
+
+PROC show (FILE VAR f) :
+ enable stop;
+ open editor (f, read acc);
+ edit(groesster editor, std res, PROC(TEXT CONST) std kommando interpreter);
+END PROC show;
+
+
+PROC show (TEXT CONST filename) : (*sh*)
+ last param (filename);
+ IF exists (filename)
+ THEN FILE VAR f := sequential file (modify, filename);
+ show (f); last param (filename)
+ ELSE errorstop ("""" + filename + """ gibt es nicht")
+ FI
+END PROC show;
+
+
+PROC show :
+ show (last param)
+END PROC show;
+
+
+DATASPACE VAR local space;
+INT VAR zeilenoffset;
+TEXT VAR kopierzeile;
+
+
+OP PUT (TEXT CONST filename) :
+ nichts neu;
+ IF mark
+ THEN markierten bereich in datei schreiben
+ FI .
+
+markierten bereich in datei schreiben :
+ disable stop;
+ zieldatei vorbereiten;
+ quelldatei oeffnen;
+ IF noch genuegend platz in der zieldatei (*sh*)
+ THEN zeilenweise kopieren
+ ELSE errorstop ("FILE-Ueberlauf")
+ FI ;
+ quelldatei schliessen;
+ zieldatei schliessen;
+ set busy indicator .
+
+zieldatei vorbereiten :
+ FRANGE VAR ganze zieldatei;
+ IF exists (filename) THEN forget (filename); ueberschrift neu FI;
+ FILE VAR destination;
+ IF filename = ""
+ THEN forget (local space); local space := nilspace;
+ destination := sequential file (output, local space)
+ ELSE destination := sequential file (modify, filename) ;
+ INT CONST groesse der zieldatei := lines (destination); (*sh*)
+ set marked range (destination, ganze zieldatei) ;
+ output (destination)
+ FI .
+
+quelldatei oeffnen :
+ zeilenoffset := mark line no (edfile) - 1;
+ INT CONST old line := line no, old col := col;
+ FRANGE VAR ganze datei;
+ set range (edfile, mark lineno (edfile), mark col (edfile), ganze datei);
+ input (edfile) .
+
+noch genuegend platz in der zieldatei :
+ lines + groesse der zieldatei < file size .
+
+zeilenweise kopieren :
+ enable stop;
+ satznr neu;
+ INT VAR zeile;
+ FOR zeile FROM 1 UPTO lines (edfile) REP
+ getline (edfile, kopierzeile);
+ putline (destination, kopierzeile);
+ satznr zeigen
+ PER .
+
+quelldatei schliessen :
+ modify (edfile);
+ set range (edfile, ganze datei);
+ to line (old line);
+ col (old col) .
+
+zieldatei schliessen :
+ IF filename <> ""
+ THEN INT CONST last line written := line no (destination) ;
+ modify (destination) ;
+ to line (destination, last line written) ;
+ col (destination, len (destination) + 1) ;
+ bild neu (destination) ;
+ set range (destination, ganze zieldatei)
+ FI .
+END OP PUT;
+
+
+OP P (TEXT CONST filename) :
+ PUT filename
+END OP P ;
+
+
+OP GET (TEXT CONST filename) : (*sh*)
+ IF NOT write permission
+ THEN errorstop ("Schreibversuch auf 'show'-Datei")
+ FI ;
+ quelldatei oeffnen;
+ IF nicht mehr genuegend platz im editfile
+ THEN quelldatei schliessen; errorstop ("FILE-Ueberlauf")
+ FI ;
+ disable stop;
+ zieldatei oeffnen;
+ zeilenweise kopieren ;
+ zieldatei schliessen;
+ quelldatei schliessen;
+ set busy indicator .
+
+quelldatei oeffnen :
+ FILE VAR source;
+ FRANGE VAR ganze quelldatei;
+ IF filename = ""
+ THEN source := sequential file (input, local space)
+ ELSE IF NOT exists (filename)
+ THEN errorstop ("""" + filename + """ gibt es nicht")
+ FI ;
+ source := sequential file (modify, filename);
+ INT CONST old line := line no (source),
+ old col := col (source);
+ set marked range (source, ganze quelldatei);
+ input (source)
+ FI .
+
+nicht mehr genuegend platz im editfile :
+ lines (source) + lines >= file size .
+
+zeilenweise kopieren :
+ enable stop;
+ satznr neu;
+ INT VAR zeile;
+ FOR zeile FROM 1 UPTO lines (source) REP
+ getline (source, kopierzeile);
+ putline (edfile, kopierzeile);
+ satznr zeigen
+ PER .
+
+zieldatei oeffnen :
+ zeilenoffset := line no - 1;
+ leere datei in editfile einschachteln;
+ output (edfile) .
+
+leere datei in editfile einschachteln :
+ INT CONST range start col := col;
+ FRANGE VAR ganze datei;
+ set range (edfile, line no, col, ganze datei);
+ IF lines = 1 THEN delete record (edfile) FI .
+
+quelldatei schliessen :
+ IF filename <> ""
+ THEN modify (source);
+ set range (source, ganze quelldatei);
+ to line (source, old line);
+ col (source, old col)
+ FI .
+
+zieldatei schliessen :
+ modify (edfile);
+ to line (lines);
+ col (range start col);
+ set range (edfile, ganze datei);
+ abschnitt neu (zeilenoffset + 1, lines) .
+END OP GET;
+
+
+OP G (TEXT CONST filename) :
+ GET filename
+END OP G;
+
+
+INT PROC len :
+ len (edfile)
+END PROC len;
+
+
+PROC col (INT CONST stelle) :
+ nichts neu; col (edfile, stelle)
+END PROC col;
+
+
+INT PROC col :
+ col (edfile)
+END PROC col;
+
+
+PROC limit (INT CONST limit) :
+ nichts neu; max line length (edfile, limit)
+END PROC limit;
+
+
+INT PROC limit :
+ max line length (edfile)
+END PROC limit;
+
+
+INT PROC lines :
+ lines (edfile)
+END PROC lines;
+
+
+INT PROC line no :
+ line no (edfile)
+END PROC line no;
+
+
+PROC to line (INT CONST satz nr) :
+ satznr neu;
+ edfile := editfile;
+ IF satz nr > lines
+ THEN toline (edfile, lines); col (len + 1)
+ ELSE to line (edfile, satz nr)
+ FI
+END PROC to line;
+
+
+OP T (INT CONST satz nr) :
+ to line (satz nr)
+END OP T;
+
+
+PROC down (INT CONST anz) :
+ nichts neu; down (edfile, anz)
+END PROC down;
+
+
+OP D (INT CONST anz) :
+ down (anz)
+END OP D;
+
+
+PROC up (INT CONST anz) :
+ nichts neu; up (edfile, anz)
+END PROC up;
+
+
+OP U (INT CONST anz) :
+ up (anz)
+END OP U;
+
+
+PROC down (TEXT CONST muster) :
+ nichts neu;
+ REP
+ down (muster, schritt - line no MOD schritt);
+ IF pattern found
+ THEN LEAVE down
+ ELSE satznr zeigen
+ FI
+ UNTIL eof PER
+END PROC down;
+
+
+OP D (TEXT CONST muster) :
+ down (muster)
+END OP D;
+
+
+PROC down (TEXT CONST muster, INT CONST anz) :
+ nichts neu; down (edfile, muster, anz)
+END PROC down;
+
+
+PROC up (TEXT CONST muster) :
+ nichts neu;
+ REP
+ up (muster, (line no - 1) MOD schritt + 1);
+ IF pattern found
+ THEN LEAVE up
+ ELSE satznr zeigen
+ FI
+ UNTIL line no = 1 PER
+END PROC up;
+
+
+OP U (TEXT CONST muster) :
+ up (muster)
+END OP U;
+
+
+PROC up (TEXT CONST muster, INT CONST anz) :
+ nichts neu; up (edfile, muster, anz)
+END PROC up;
+
+
+PROC downety (TEXT CONST muster) :
+ nichts neu;
+ IF NOT at (muster)
+ THEN down (muster)
+ FI
+END PROC downety;
+
+
+PROC downety (TEXT CONST muster, INT CONST anz) :
+ nichts neu; downety (edfile, muster, anz)
+END PROC downety;
+
+
+PROC uppety (TEXT CONST muster) :
+ nichts neu;
+ IF NOT at (muster)
+ THEN up (muster)
+ FI
+END PROC uppety;
+
+
+PROC uppety (TEXT CONST muster, INT CONST anz) :
+ nichts neu; uppety (edfile, muster, anz)
+END PROC uppety;
+
+
+OP C (TEXT CONST old, new) :
+ change to (old, new)
+END OP C;
+
+OP C (TEXT CONST replacement) :
+ IF NOT write permission (*sh*)
+ THEN errorstop ("Schreibversuch auf 'show'-Datei")
+ FI ;
+ IF at (edfile, match(0))
+ THEN zeile neu; change (edfile, matchpos(0), matchend(0), replacement)
+ FI
+END OP C;
+
+PROC change to (TEXT CONST old, new) :
+ IF NOT write permission (*sh*)
+ THEN errorstop ("Schreibversuch auf 'show'-Datei")
+ FI ;
+ nichts neu;
+ REP
+ downety (old, schritt - line no MOD schritt);
+ IF pattern found
+ THEN change (edfile, matchpos(0), matchend(0), new);
+ col (col + LENGTH new); zeile neu;
+ LEAVE changeto
+ ELSE satznr zeigen
+ FI
+ UNTIL eof PER
+END PROC change to;
+
+
+OP CA (TEXT CONST old, new) :
+ change all (old, new)
+END OP CA;
+
+
+PROC change all (TEXT CONST old, new) :
+ WHILE NOT eof REP old C new PER
+END PROC change all;
+
+
+BOOL PROC eof :
+ eof (edfile)
+END PROC eof;
+
+
+BOOL PROC mark :
+ mark (edfile)
+END PROC mark;
+
+
+PROC mark (BOOL CONST mark on) :
+ nichts neu;
+ IF mark on
+ THEN mark (edfile, line no, col)
+ ELSE mark (edfile, 0, 0)
+ FI
+END PROC mark;
+
+
+BOOL PROC at (TEXT CONST pattern) :
+ at (edfile, pattern)
+END PROC at;
+
+TEXT PROC word :
+ word (edfile)
+END PROC word;
+
+
+TEXT PROC word (TEXT CONST sep) :
+ word (edfile, sep)
+END PROC word;
+
+
+TEXT PROC word (INT CONST len) :
+ word (edfile, len)
+END PROC word;
+
+
+LET no access = 0,
+ edit access = 1,
+ output access = 2;
+
+INT VAR last note file mode;
+FILE VAR notebook;
+INITFLAG VAR this packet := FALSE;
+DATASPACE VAR note ds;
+
+
+PROC note (TEXT CONST text) :
+ access note file (output access);
+ write (notebook, text)
+END PROC note;
+
+
+PROC note (INT CONST number) :
+ access note file (output access);
+ put (notebook, number)
+END PROC note;
+
+
+PROC note line :
+ access note file (output access);
+ line (notebook)
+END PROC note line;
+
+
+BOOL PROC anything noted :
+ access note file (no access);
+ last note file mode = output access
+END PROC anything noted;
+
+
+FILE PROC note file :
+ access note file (output access);
+ notebook
+END PROC note file;
+
+
+PROC note edit (FILE VAR context) : (*sh*)
+ access note file (edit access);
+ make notebook erasable;
+ IF aktueller editor = 0
+ THEN open editor (1, context, write acc, 1, 1, x size - 1, y size)
+ FI ;
+ get window size;
+ IF window large enough
+ THEN include note editor;
+ edit (aktueller editor-1, aktueller editor, aktueller editor-1,
+ std res, PROC (TEXT CONST) std kommando interpreter)
+ FI .
+
+get window size :
+ INT VAR x, y, windows x size, windows y size;
+ get window (x, y, windows x size, windows y size) .
+
+window large enough :
+ windows y size > 4 .
+
+include note editor :
+ open editor (aktueller editor + 1, notebook, write acc,
+ x, y + (windows y size + 1) DIV 2,
+ windows x size, windows y size DIV 2) .
+
+make notebook erasable :
+ last note file mode := edit access .
+END PROC note edit;
+
+
+PROC note edit :
+ access note file (edit access);
+ make notebook erasable;
+ edit (notebook) .
+
+make notebook erasable :
+ last note file mode := edit access .
+END PROC note edit;
+
+
+PROC access note file (INT CONST new mode) :
+ disable stop;
+ initialize note ds if necessary;
+ IF last note file mode < new mode
+ THEN forget (note ds);
+ note ds := nilspace;
+ notebook := sequential file (output, note ds);
+ headline (notebook, "notebook");
+ last note file mode := new mode
+ FI .
+
+initialize note ds if necessary :
+ IF NOT initialized (this packet)
+ THEN note ds := nilspace;
+ last note file mode := no access
+ FI .
+END PROC access note file;
+
+END PACKET editor functions;
+
diff --git a/system/base/1.7.5/src/init b/system/base/1.7.5/src/init
new file mode 100644
index 0000000..471a717
--- /dev/null
+++ b/system/base/1.7.5/src/init
@@ -0,0 +1,251 @@
+ "run again impossible"
+ "recursive run"
+ " "
+ " Compiler Error : "
+" "
+" |"
+" Fehler entdeckt "
+"Keine Fehler gefunden, "
+" "
+" ******* ENDE DER UEBERSETZUNG *******"
+"FEHLER bei >> "
+" << "
+"weiter bei "
+"TEXTende (Anfuehrungszeichen) fehlt irgendwo"
+"Kommentarende fehlt irgendwo"
+"nach dem Hauptprogramm darf kein Paket folgen"
+"ungueltiger Name fuer ein DEFINES-Objekt"
+"':' fehlt"
+"nach ENDPACKET folgt nicht der Paketname"
+"ENDPACKET fehlt"
+"CONST oder VAR fehlt"
+"ungueltiger Name"
+" ',' in Deklarationsliste fehlt"
+"ist nicht der PROC Name"
+"fehlerhaftes Ende des Hauptprogramms"
+"ENDPROC fehlt"
+"PROC/OP Schachtelung unzulaessig"
+"OP darf kein Parameter sein"
+"steht mehrfach im PACKET Interface"
+" ist mehrfach deklariert"
+"ist schon als Datenobjekt deklariert"
+"ist schon als PROC/OP deklariert"
+"')' nach Parameterliste erwartet"
+"Standard-Schluesselwort kann nicht redefiniert werden"
+"ungueltig als BOLD"
+"'(' fehlt"
+"CONST bzw VAR nicht bei Strukturfeldern"
+"'=' fehlt"
+"Schluesselwort wird im Paket schon andersartig verwandt"
+"Datentyp fehlt"
+"ungueltiger OP Name"
+"OP muss monadisch oder dyadisch sein"
+"ist nicht der OP Name"
+"ENDOP fehlt"
+"Name nach ENDPROC fehlt"
+"Name nach ENDOP fehlt"
+"';' fehlt"
+"END END ist Unsinn"
+"Dieses END... kenne ich nicht"
+"ROW Groesse ist kein INT"
+"ROW Groesse ist kein Denoter"
+"Ein ROW muss mindestens ein Element haben"
+"ROW Groesse fehlt"
+"Parameter kann man nicht initialisieren"
+"Konstanten muessen initialisiert werden"
+"'::' verwenden"
+"')' fehlt"
+"Exponent fehlt"
+"Undefinierter Typ"
+"Rekursiv definierter Typ"
+"Mehrfach definierter Selektor"
+"Variable bzw. Abkuerzung in der Paket-Schnittstelle"
+"undefinierte ROW Groesse"
+"Typ Deklarationen nur im Paketrumpf"
+"CONST bzw. VAR ohne Zusammenhang"
+"ist nicht deklariert, steht aber in der Paket-Schnittstelle"
+"ist nicht deklariert"
+"unbekanntes Kommando"
+"THIS IS NO CORRECT EXTERNAL NUMBER."
+"Schluesselwort unzulaessig"
+"Name erwartet"
+"Denoter erwartet"
+"ENDPROC ohne Zusammenhang"
+"ENDOP ohne Zusammenhang"
+"Refinement ohne Zusammenhang"
+"Delimiter zwischen Paket-Refinement und Deklaration fehlt"
+"unzulaessiges Selektor-Symbol (kein Name)"
+"BOUND Schachtelungen unzulaessig"
+"BOUND-Objekte unzulaessig als Parameter"
+"Textende fehlt"
+"TEXT-Denoter zu lang"
+
+"Denoter-Wert wird fuer diese Maschine zu gross"
+"Compiler-Fehler, wenden Sie sich an Ihren Systemberater!"
+"ist ein zusammenhangloses Schluesselwort"
+"'::' nur fuer Initialisierungen, sonst ':='"
+"welches Objekt soll verlassen werden?"
+"du bist gar nicht innerhalb dieses Refinements"
+"nur die eigene PROC / OP kann verlassen werden"
+"THEN fehlt"
+"FI fehlt"
+"BOOL-Ausdruck erwartet"
+"ELSE-Teil ist notwendig, da ein Wert geliefert wird"
+"INT-Ausdruck erwartet"
+"OF fehlt"
+"Keine Typanpassung moeglich"
+"CASE-Label fehlt"
+"mindestens eine CASE-Anweisung geben"
+"CASE-Label ist zu gross (skipped)"
+"mehrfach definiertes CASE-Label"
+"ungueltiges Zeichen nach CASE-Label"
+"OTHERWISE-Teil fehlt"
+"END SELECT fehlt"
+"rekursiver Aufruf eines Refinements"
+" wird nicht benutzt"
+"';' oder Operator ('+','-',...) fehlt"
+"undefinierter monadischer Operator"
+"undefinierter dyadischer Operator"
+"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen"
+"fuer diesen Typ nicht definierter Selektor"
+"INT,REAL,BOOL,TEXT koennen nicht selektiert werden"
+"bei ROWs nur Subscription"
+"nicht selektierbar"
+"unzulaessiger Index fuer Subscription"
+"'[' ohne Zusammenhang"
+"']' ohne Zusammenhang"
+"']' nach Subscription fehlt"
+"ungueltig zwischen Anweisungen"
+"nur die letzte Anweisung eines Abschnitts darf einen Wert liefern"
+"Der Paketrumpf kann keinen Wert liefern"
+"anstelle des letzten Symbols wurde ein Operand erwartet"
+"Der Schleifenrumpf darf keinen Wert liefern"
+"die Laufvariable muss eine INT VAR sein"
+"wird schon in einer aeusseren Schleife als Laufvariable benutzt"
+"FROM erwartet"
+"UPTO bzw DOWNTO fehlt"
+"REPEAT fehlt"
+"END REP fehlt"
+"die Konstante darf nicht veraendert werden"
+"in einer FOR-Schleife darf die Laufvariable nicht veraendert werden"
+"falscher Typ des Resultats"
+"ist CONST, es wird aber ein VAR Parameter verlangt"
+"unbekannte Prozedur"
+"Parameter-Prozedur liefert falsches Resultat"
+"Anzahl bzw. Typen der Parameter sind falsch"
+"unbekannte Parameter-Prozedur"
+"aktuelle Parameter-Prozedur hat CONST-, formale hat VAR-Parameter"
+"Kein Konstruktor moeglich, da die Feinstruktur hier unbekannt ist"
+"zu wenig Felder angegeben"
+"zu viele Felder angegeben"
+"unzulaessiger Trenner zwischen Feldern"
+"Feld hat falschen Typ"
+"falsche Element-Anzahl im ROW-Konstruktor"
+"Dieser Typ kann nicht noch mehr konkretisiert werden"
+"BOUND-Objekt zu gross"
+
+"Warnung in Zeile "
+" Zeile "
+"in Zeile "
+" <----+---> "
+" TYPE undefiniert "
+" MODE undefiniert "
+"Parameter spezifiziert: "
+"Parameter Typ(en) sind: "
+" B Code, "
+" B Paketdaten generiert"
+"Operand: "
+"Operanden: "
+", "
+"erwartet "
+"gefunden "
+" "
+
+(* 001 *) END
+(* 002 *) ENDPACKET
+(* 003 *) ENDOP
+(* 004 *) ENDOPERATOR
+(* 005 *) ENDPROC
+(* 006 *) ENDPROCEDURE
+(* 007 *) PACKET
+(* 008 *) OP
+(* 009 *) OPERATOR
+(* 010 *) PROC
+(* 011 *) PROCEDURE
+(* 012 *) FI
+(* 013 *) ENDIF
+(* 014 *) ENDREP
+(* 015 *) ENDREPEAT
+(* 016 *) PER
+(* 017 *) ELIF
+(* 018 *) ELSE
+(* 019 *) UNTIL
+(* 020 *) CASE
+(* 021 *) OTHERWISE
+(* 022 *) ENDSELECT
+(* 023 *) INTERNAL
+(* 024 *) DEFINES
+(* 025 *) LET
+(* 026 *) TYPE
+(* 027 *) INT
+(* 028 *) REAL
+(* 029 *) DATASPACE
+(* 030 *) TEXT
+(* 031 *) BOOL
+(* 032 *) BOUND
+(* 033 *) ROW
+(* 034 *) STRUCT
+(* 035 *) CONST
+(* 036 *) VAR
+(* 037 INIT CONTROL *) INTERNAL
+(* 038 *) CONCR
+(* 039 *) REP
+(* 040 *) REPEAT
+(* 041 *) SELECT
+(* 042 *) EXTERNAL
+(* 043 *) IF
+(* 044 *) THEN
+(* 045 *) OF
+(* 046 *) FOR
+(* 047 *) FROM
+(* 048 *) UPTO
+(* 049 *) DOWNTO
+(* 050 *) WHILE
+(* 051 *) LEAVE
+(* 052 *) WITH
+(* 053 *) TRUE
+(* 054 *) FALSE
+(* 055 *) :: SBL := INCR DECR
+(* 056 *) + - * / DIV MOD
+ **
+ AND
+ CAND
+ OR
+ COR
+ NOT
+ = <> > >= < <=
+(*040 *) MAIN
+(*043*) ENDOFFILE
+
+PACKET a :
+
+PROC out (TEXT CONST t) :
+ EXTERNAL 60
+ENDPROC out ;
+
+PROC out text (TEXT CONST t, INT CONST typ) :
+ INTERNAL 257 ;
+ IF typ = typ
+ THEN out (t)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST typ) :
+ INTERNAL 258 ;
+ IF typ = typ
+ THEN out (""13""10"")
+ FI
+ENDPROC out line ;
+
+ENDPACKET a ;
+
diff --git a/system/base/1.7.5/src/integer b/system/base/1.7.5/src/integer
new file mode 100644
index 0000000..aefb77f
--- /dev/null
+++ b/system/base/1.7.5/src/integer
@@ -0,0 +1,265 @@
+(* ------------------- STAND : 23.10.85 --------------------*)
+PACKET integer DEFINES text, int, MOD,
+ sign, SIGN, abs, ABS, **, min, max, minint, maxint,
+ random, initialize random ,
+ last conversion ok, set conversion :
+
+INT PROC minint : -32767 - 1 ENDPROC minint ;
+
+INT PROC maxint : 32767 ENDPROC maxint ;
+
+
+TEXT PROC text (INT CONST number) :
+
+ IF number = minint THEN "-32768"
+ ELIF number < 0 THEN "-" + text(-number)
+ ELIF number <= 9 THEN code (number + 48)
+ ELSE text (number DIV 10) + digit
+ FI .
+
+digit :
+ code ( number MOD 10 + 48 ) .
+
+ENDPROC text ;
+
+TEXT PROC text (INT CONST number, length) :
+
+ TEXT VAR result := text (number) ;
+ INT CONST number length := LENGTH result ;
+ IF number length < length
+ THEN (length - number length) * " " + result
+ ELIF number length > length
+ THEN length * "*"
+ ELSE result
+ FI
+
+ENDPROC text ;
+
+INT PROC int (TEXT CONST number) :
+
+ skip blanks and sign ;
+ get value ;
+ result .
+
+skip blanks and sign :
+ BOOL VAR number is positive ;
+ INT VAR pos := 1 ;
+ skip blanks ;
+ IF (number SUB pos) = "-"
+ THEN number is positive := FALSE ;
+ pos INCR 1
+ ELIF (number SUB pos) = "+"
+ THEN number is positive := TRUE ;
+ pos INCR 1
+ ELSE number is positive := TRUE
+ FI .
+
+get value :
+ INT VAR value ;
+ get first digit ;
+ WHILE is digit REP
+ value := value * 10 + digit ;
+ pos INCR 1
+ PER ;
+ set conversion ok result .
+
+get first digit :
+ IF is digit
+ THEN value := digit ;
+ pos INCR 1
+ ELSE set conversion (FALSE) ;
+ LEAVE int WITH 0
+ FI .
+
+is digit : 0 <= digit AND digit <= 9 .
+
+digit : code (number SUB pos) - 48 .
+
+result :
+ IF number is positive
+ THEN value
+ ELSE - value
+ FI .
+
+set conversion ok result :
+ skip blanks ;
+ conversion ok := (pos > LENGTH number) .
+
+skip blanks :
+ WHILE (number SUB pos) = " " REP
+ pos INCR 1
+ PER .
+
+ENDPROC int ;
+
+INT OP MOD (INT CONST left, right) :
+
+ EXTERNAL 43
+
+ENDOP MOD ;
+
+INT PROC sign (INT CONST argument) :
+
+ IF argument < 0 THEN -1
+ ELIF argument > 0 THEN 1
+ ELSE 0
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (INT CONST argument) :
+ sign (argument)
+ENDOP SIGN ;
+
+INT PROC abs (INT CONST argument) :
+
+ IF argument > 0 THEN argument
+ ELSE - argument
+ FI
+
+ENDPROC abs ;
+
+INT OP ABS (INT CONST argument) :
+ abs (argument)
+ENDOP ABS ;
+
+INT OP ** (INT CONST arg, exp) :
+
+ INT VAR x := arg , z := 1 ,
+ counter := exp ;
+
+ IF exp = 0
+ THEN LEAVE ** WITH 1
+ ELIF exp < 0
+ THEN LEAVE ** WITH 1 DIV arg
+ FI ;
+
+ WHILE counter >= 2 REP
+ calculate new x and z ;
+ counter := counter DIV 2 ;
+ ENDREP ;
+ z * x .
+
+calculate new x and z :
+ IF counter is not even
+ THEN z := z * x
+ FI ;
+ x := x * x .
+
+counter is not even :
+ counter MOD 2 = 1 .
+
+ENDOP ** ;
+
+INT PROC min (INT CONST first, second) :
+
+ IF first < second THEN first ELSE second FI
+
+ENDPROC min ;
+
+INT PROC max (INT CONST first, second) :
+
+ IF first > second THEN first ELSE second FI
+
+ENDPROC max ;
+
+
+
+BOOL VAR conversion ok := TRUE ;
+
+BOOL PROC last conversion ok :
+ conversion ok
+ENDPROC last conversion ok ;
+
+PROC set conversion (BOOL CONST success) :
+ conversion ok := success
+ENDPROC set conversion ;
+
+
+
+(*******************************************************************)
+(* *)
+(* Autor: A. Flammenkamp *)
+(* RANDOM GENERATOR *)
+(* *)
+(* x := 4095 * x MOD (4095*4096+4093) *)
+(* n+1 n *)
+(* *)
+(* Periode: 2**24-4 > 16.0e6 *)
+(* *)
+(* Beachte: x = 4096 * x1 + x0, 0 <= x0,x1 < 4096 *)
+(* *)
+(*******************************************************************)
+
+
+INT VAR high := 1, low := 0 ;
+
+PROC initialize random (INT CONST start) :
+
+ low := start MOD 4096 ;
+ IF start < 0
+ THEN high := 256 + 16 + start DIV 4096 ;
+ IF low <> 0 THEN high DECR 1 FI
+ ELSE high := 256 + start DIV 4096
+ FI
+
+ENDPROC initialize random ;
+
+INT PROC random (INT CONST lower bound, upper bound) :
+
+ compute new random value ;
+ normalize high ;
+ normalize low ;
+ map into interval .
+
+compute new random value :
+ (* (high,low) := (low-high , 3*high-low) *)
+ high := low - high ;
+ low INCR low - 3 * high .
+
+normalize high :
+ IF high < 0
+ THEN high INCR 4096 ; low DECR 3
+ FI .
+
+normalize low :
+ (* high INCR low DIV 4096 ;
+ low := low MOD 4096
+ *)
+ IF low >= 4096 THEN low overflow
+ ELIF low < 0 THEN low underflow
+ FI .
+
+low overflow :
+ IF low >= 8192
+ THEN low DECR 8192 ; high INCR 2
+ ELSE low DECR 4096 ; high INCR 1 ; post normalization
+ FI .
+
+post normalization :
+ (* IF (high,low) >= (4095,4093)
+ THEN (high,low) DECR (4095,4093)
+ FI
+ *)
+ IF high >= 4095
+ THEN IF low >= 4093 THEN high DECR 4095 ; low DECR 4093
+ ELIF high = 4096 THEN high := 0 ; low INCR 3
+ FI
+ FI .
+
+low underflow :
+ low INCR 4096 ; high DECR 1 .
+
+map into interval :
+ INT VAR number := high MOD 16 - 8 ;
+ number INCR 4095 * number + low ;
+ IF lower bound <= upper bound
+ THEN lower bound + number MOD (upper bound - lower bound + 1)
+ ELSE upper bound + number MOD (lower bound - upper bound + 1)
+ FI .
+
+ENDPROC random ;
+
+
+ENDPACKET integer ;
+
diff --git a/system/base/1.7.5/src/local manager b/system/base/1.7.5/src/local manager
new file mode 100644
index 0000000..48d024b
--- /dev/null
+++ b/system/base/1.7.5/src/local manager
@@ -0,0 +1,373 @@
+(* ------------------- VERSION 2 24.02.86 ------------------- *)
+PACKET local manager (* Autor: J.Liedtke *)
+
+ DEFINES
+ create, (* neue lokale Datei einrichten *)
+ new, (* 'create' und Datei liefern *)
+ old, (* bestehende Datei liefern *)
+ forget, (* lokale Datei loeschen *)
+ exists, (* existiert Datei (lokal) ? *)
+ status, (* setzt und liefert Status *)
+ rename, (* Umbenennung *)
+ copy , (* Datenraum in Datei kopieren *)
+ enter password,(* Passwort einfuehren *)
+ write password ,
+ read password ,
+ write permission ,
+ read permission ,
+ begin list ,
+ get list entry ,
+ all :
+
+
+
+LET size = 200 ,
+ nil = 0 ;
+
+INT VAR index ;
+
+TEXT VAR system write password := "" ,
+ system read password := "" ,
+ actual password ;
+
+INITFLAG VAR this packet := FALSE ;
+
+DATASPACE VAR password space ;
+
+BOUND ROW size STRUCT (TEXT write, read) VAR passwords ;
+
+
+THESAURUS VAR dir := empty thesaurus ;
+
+ROW size STRUCT (DATASPACE ds,
+ BOOL protected,
+ TEXT status) VAR crowd ;
+
+
+PROC initialize if necessary :
+
+ IF NOT initialized (this packet)
+ THEN system write password := "" ;
+ system read password := "" ;
+ dir := empty thesaurus ;
+ password space := nilspace ;
+ passwords := password space
+ FI
+
+ENDPROC initialize if necessary ;
+
+
+
+PROC create (TEXT CONST name) :
+
+IF exists (name )
+ THEN error (name, "existiert bereits") ;
+ index := nil
+ ELSE insert and initialize entry
+FI .
+
+insert and initialize entry :
+ disable stop ;
+ insert (dir, name, index) ;
+ IF index <> nil
+ THEN crowd (index).ds := nilspace ;
+ IF is error
+ THEN delete (dir, name, index) ;
+ LEAVE create
+ FI ;
+ status (name, "") ;
+ crowd (index).protected := FALSE
+ ELIF NOT is error
+ THEN errorstop ("zu viele Dateien")
+ FI .
+
+ENDPROC create ;
+
+DATASPACE PROC new (TEXT CONST name) :
+
+ create (name) ;
+ IF index <> nil
+ THEN crowd (index).ds
+ ELSE nilspace
+ FI
+
+ENDPROC new ;
+
+DATASPACE PROC old (TEXT CONST name) :
+
+ initialize if necessary ;
+ index := link (dir, name) ;
+ IF index = 0
+ THEN error (name, "gibt es nicht") ;
+ nilspace
+ ELSE space
+ FI .
+
+space : crowd (index).ds .
+
+ENDPROC old ;
+
+DATASPACE PROC old (TEXT CONST name, INT CONST expected type) :
+
+ initialize if necessary ;
+ index := link (dir, name) ;
+ IF index = 0
+ THEN error (name, "gibt es nicht") ;
+ nilspace
+ ELIF type (space) <> expected type
+ THEN errorstop ("Datenraum hat falschen Typ") ;
+ nilspace
+ ELSE space
+ FI .
+
+space : crowd (index).ds .
+
+ENDPROC old ;
+
+BOOL PROC exists (TEXT CONST name) :
+
+ initialize if necessary ;
+ dir CONTAINS name
+
+ENDPROC exists ;
+
+PROC forget (TEXT CONST name ) :
+
+ initialize if necessary ;
+ say ("""") ;
+ say (name) ;
+ IF NOT exists (name) THEN say (""" existiert nicht")
+ ELIF yes (""" loeschen") THEN forget (name, quiet)
+ FI .
+
+ENDPROC forget ;
+
+PROC forget (TEXT CONST name, QUIET CONST q) :
+
+ initialize if necessary ;
+ disable stop ;
+ delete (dir, name, index) ;
+ IF index <> nil
+ THEN forget ( crowd (index).ds ) ;
+ crowd (index).status := ""
+ FI .
+
+ENDPROC forget ;
+
+PROC forget :
+
+ BOOL VAR status := command dialogue ;
+ command dialogue (TRUE) ;
+ forget (last param) ;
+ command dialogue (status)
+
+ENDPROC forget ;
+
+PROC status (TEXT CONST name, status text) :
+
+ initialize if necessary ;
+ INT VAR index := link (dir, name) ;
+ IF index > 0
+ THEN crowd (index).status := date + " " + text (status text, 4)
+ FI
+
+ENDPROC status ;
+
+TEXT PROC status (TEXT CONST name) :
+
+ initialize if necessary ;
+ INT VAR index := link (dir, name) ;
+ IF index > 0
+ THEN crowd (index).status
+ ELSE ""
+ FI
+
+ENDPROC status ;
+
+PROC status (INT CONST pos, TEXT CONST status pattern) :
+
+ initialize if necessary ;
+ INT VAR index := 0 ;
+ WHILE index < highest entry (dir) REP
+ index INCR 1 ;
+ replace (actual status, pos , status pattern)
+ PER .
+
+actual status : crowd (index).status .
+
+ENDPROC status ;
+
+PROC copy (DATASPACE CONST source, TEXT CONST dest name) :
+
+ IF exists (dest name)
+ THEN error (dest name, "existiert bereits")
+ ELSE copy file
+ FI .
+
+copy file :
+ disable stop ;
+ create ( dest name ) ;
+ INT VAR index := link (dir, dest name) ;
+ IF index > nil
+ THEN forget (crowd (index).ds) ;
+ crowd (index).ds := source
+ FI
+
+ENDPROC copy ;
+
+PROC copy (TEXT CONST source name, dest name) :
+
+ copy (old (source name), dest name)
+
+ENDPROC copy ;
+
+PROC rename (TEXT CONST old name, new name) :
+
+ IF exists (new name)
+ THEN error (new name, "existiert bereits")
+ ELIF exists (old name)
+ THEN rename (dir, old name, new name) ;
+ last param (new name)
+ ELSE error (old name, "gibt es nicht")
+ FI .
+
+ENDPROC rename ;
+
+
+PROC begin list :
+
+ initialize if necessary ;
+ index := 0
+
+ENDPROC begin list ;
+
+PROC get list entry (TEXT VAR entry, status text) :
+
+ get (dir, entry, index) ;
+ IF found
+ THEN status text := crowd (index).status ;
+ ELSE status text := "" ;
+ FI .
+
+found : index > 0 .
+
+ENDPROC get list entry ;
+
+
+TEXT PROC write password :
+
+ system write password
+
+ENDPROC write password ;
+
+TEXT PROC read password :
+
+ system read password
+
+ENDPROC read password ;
+
+
+PROC enter password (TEXT CONST password) :
+
+ initialize if necessary ;
+ say (""3""5"") ;
+ INT CONST slash pos := pos (password, "/") ;
+ IF slash pos = 0
+ THEN system write password := password ;
+ system read password := password
+ ELSE system write password := subtext (password, 1, slash pos-1) ;
+ system read password := subtext (password, slash pos+1)
+ FI .
+
+ENDPROC enter password ;
+
+PROC enter password (TEXT CONST file name, write pass, read pass) :
+
+ INT CONST index := link (dir, file name) ;
+ IF index > 0
+ THEN set protect password
+ FI .
+
+set protect password :
+ IF write pass = "" AND read pass = ""
+ THEN crowd (index).protected := FALSE
+ ELSE crowd (index).protected := TRUE ;
+ passwords (index).write := write pass ;
+ passwords (index).read := read pass
+ FI .
+
+ENDPROC enter password ;
+
+INT PROC password index (TEXT CONST file name) :
+
+ initialize if necessary ;
+ INT CONST index := link (dir, file name) ;
+ IF index > 0 CAND crowd (index).protected
+ THEN index
+ ELSE 0
+ FI
+
+ENDPROC password index ;
+
+BOOL PROC read permission (TEXT CONST name, supply password) :
+
+ (****************************************************************)
+ (* for reasons of data security the password check algorithm *)
+ (* must not copy parts of the file password into variables *)
+ (* located in the standard dataspace! *)
+ (****************************************************************)
+
+ access file password ;
+ file has no password COR (supply password <> "-" AND read password match) .
+
+read password match :
+ file password.read = supply password OR file password.read = "" .
+
+access file password :
+ INT CONST pw index := password index (name) .
+
+file password : passwords (pw index) .
+
+file has no password : pw index = 0 .
+
+ENDPROC read permission ;
+
+BOOL PROC write permission (TEXT CONST name, supply password) :
+
+ (****************************************************************)
+ (* for reasons of data security the password check algorithm *)
+ (* must not copy parts of the file password into variables *)
+ (* located in the standard dataspace! *)
+ (****************************************************************)
+
+ access file password ;
+ file has no password COR (supply password <> "-" AND write password match).
+
+write password match :
+ file password.write = supply password OR file password.write = "" .
+
+access file password :
+ INT CONST pw index := password index (name) .
+
+file password : passwords (pw index) .
+
+file has no password : pw index = 0 .
+
+ENDPROC write permission ;
+
+THESAURUS PROC all :
+
+ initialize if necessary ;
+ THESAURUS VAR result := dir ; (*ueberfluessig ab naechstem Compiler *)
+ result
+
+ENDPROC all ;
+
+PROC error (TEXT CONST file name, error text) :
+
+ errorstop ("""" + file name + """ " + error text)
+
+ENDPROC error ;
+
+ENDPACKET local manager ;
+
diff --git a/system/base/1.7.5/src/local manager 2 b/system/base/1.7.5/src/local manager 2
new file mode 100644
index 0000000..8f70301
--- /dev/null
+++ b/system/base/1.7.5/src/local manager 2
@@ -0,0 +1,41 @@
+
+PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 25.02.85 *)
+ list :
+
+
+TEXT VAR file name, status text;
+
+
+PROC list :
+
+ disable stop ;
+ DATASPACE VAR ds := nilspace ;
+ FILE VAR list file := sequential file (output, ds) ;
+ headline (list file, "list") ;
+ list (list file) ;
+ show (list file) ;
+ forget (ds) .
+
+ENDPROC list ;
+
+PROC list (FILE VAR f) :
+
+ enable stop ;
+ begin list ;
+ putline (f, "") ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE list
+ FI ;
+ write (f, status text + " """ ) ;
+ write (f, file name) ;
+ write (f, """") ;
+ line (f)
+ PER .
+
+ENDPROC list ;
+
+ENDPACKET local manager part 2 ;
+
diff --git a/system/base/1.7.5/src/mathlib b/system/base/1.7.5/src/mathlib
new file mode 100644
index 0000000..c726495
--- /dev/null
+++ b/system/base/1.7.5/src/mathlib
@@ -0,0 +1,268 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET mathlib DEFINES sqrt, **, exp, ln, log2, log10, e, pi,
+ sin, cos, tan, sind, cosd, tand,
+ arctan, arctand, random, initializerandom :
+
+LET pii = 3.141592653589793238462,
+ pi2 = 1.570796326794896619231,
+ pi3 = 1.047197551196597746154,
+ pi6 = 0.523598775598298873077,
+ pi4 = 1.273239544735162686151,
+ ln2 = 0.693147180559945309417,
+ lg2 = 0.301029995663981195213,
+ ln10 = 2.302585092994045684018,
+ lge = 0.434294481903251827651,
+ ei = 2.718281828459045235360,
+ pi180 = 57.295779513082320876798,
+ sqrt3 = 1.732050807568877293527,
+ sqr3 = 0.577350269189625764509,
+ sqr3p2= 3.732050807568877293527,
+ sqr3m2= 0.267949192431122706473,
+ sqr2 = 0.707106781186547524400;
+
+REAL VAR rdg::0.4711;
+
+REAL PROC pi: pii END PROC pi;
+REAL PROC e : ei END PROC e;
+
+REAL PROC ln ( REAL CONST x ):
+ log2(x) * ln2
+END PROC ln;
+
+REAL PROC log10( REAL CONST x ):
+ log2(x) * lg2
+END PROC log10;
+
+REAL PROC log2 ( REAL CONST z ):
+ REAL VAR t, summe::0.0, x::z;
+ IF x=1.0 THEN 0.0
+ ELIF x>0.0 THEN normal
+ ELSE errorstop("log2: " + text (x,20)); 0.0 FI.
+
+normal:
+ IF x >= 0.5 THEN normalise downwards
+ ELSE normalise upwards FI;
+ IF x < sqr2 THEN summe := summe - 0.75; t := trans8
+ ELSE summe := summe - 0.25; t := trans2 FI;
+ summe + reihenentwicklung.
+
+ normalise downwards:
+ WHILE x >= 8.0 REP x := 0.0625 * x; summe:=summe+4.0 PER;
+ WHILE x >= 1.0 REP x := 0.5 * x; summe:=summe+1.0 PER.
+
+ normalise upwards:
+ WHILE x<=0.0625 REP x := 16.0 * x; summe:=summe-4.0 PER;
+ WHILE x<= 0.5 REP x := 2.0 * x; summe:=summe-1.0 PER.
+
+ trans8: (x - 0.5946035575013605)/(x + 0.5946035575013605).
+ trans2: (x - 0.8408964152537145)/(x + 0.8408964152537145).
+
+ reihenentwicklung: x := t * t; t * 0.06405572387119384648 *
+ ((((((3.465*x+4.095)*x+5.005)*x+6.435)*x+9.009)*x+15.015)*x+45.045)
+END PROC log2;
+
+REAL PROC sqrt ( REAL CONST z ):
+ REAL VAR y0, y1, x::z;
+ INT VAR p :: decimal exponent(x) DIV 2;
+ IF p <= -64 THEN 0.0
+ ELIF x < 0.0 THEN errorstop("sqrt: " + text (x,20)); 0.0
+ ELSE nontrivial FI.
+
+ nontrivial:
+ set exp (decimal exponent (x) -p-p, x);
+ IF x<10.0 THEN x := 5.3176703 - 40.760905/( 8.408065 + x )
+ ELSE x := 16.81595 - 1288.973 /( 84.08065 + x ) FI;
+ y0 := x;
+ set exp (decimal exponent (x) + p, y0);
+ y1 := 0.5 * ( y0 + z/y0 );
+ y0 := 0.5 * ( y1 + z/y1 );
+ y1 := 0.5 * ( y0 + z/y0 );
+ 0.5 * ( y1 + z/y1 )
+END PROC sqrt;
+
+REAL PROC exp ( REAL CONST z ):
+ REAL VAR x::z, a::1.0; BOOL VAR negativ :: x<0.0;
+ IF negativ THEN x := -x FI;
+ IF x>292.42830676
+ THEN IF NOT negativ THEN errorstop ("REAL-Ueberlauf") FI ; 0.0
+ ELIF x<=0.0001
+ THEN ( 0.5*z + 1.0 ) * z + 1.0
+ ELSE approx
+ FI.
+
+ approx:
+ IF x > ln10
+ THEN x := lge*x;
+ a := 1.0;
+ set exp (int(x), a);
+ x := frac(x)*ln10
+ FI;
+ IF x >= 2.0 THEN a := 7.389056098930650227230*a; x := x-2.0 FI;
+ IF x >= 1.0 THEN a := 2.718281828459045235360*a; x := x-1.0 FI;
+ IF x >= 0.5 THEN a := 1.648721270700128146848*a; x := x-0.5 FI;
+ IF x >= 0.25 THEN a := 1.284025416687741484073*a; x := x-0.25 FI;
+ IF x >= 0.125 THEN a := 1.133148453066826316829*a; x := x-0.125 FI;
+ IF x >= 0.0625THEN a := 1.064494458917859429563*a; x := x-0.0625FI;
+ a:=a/50.4*(((((((0.01*x+0.07)*x+0.42)*x+2.1)*x+8.4)*x+25.2)*x+50.4)*x+50.4);
+ IF negativ THEN 1.0/a ELSE a FI .
+
+ENDPROC exp ;
+
+REAL PROC tan (REAL CONST x):
+ IF x < 0.0 THEN - tg( -x * pi4)
+ ELSE tg( x * pi4) FI
+END PROC tan;
+
+REAL PROC tand (REAL CONST x):
+ IF x < 0.0 THEN - tg( -x / 45.0)
+ ELSE tg( x / 45.0) FI
+END PROC tand;
+
+REAL PROC tg (REAL CONST x ):
+ REAL VAR q::floor(x), s::x-q; INT VAR n;
+ q := q - floor(0.25*q) * 4.0 ;
+ IF q < 2.0
+ THEN IF q < 1.0
+ THEN n:=0;
+ ELSE n:=1; s := 1.0 - s FI
+ ELSE IF q < 3.0
+ THEN n:=2;
+ ELSE n:=3; s := 1.0 - s FI
+ FI;
+ q := s * s;
+ q := (((((((((-5.116186989653120e-11*q-5.608325022830701e-10)*q-
+ 9.526170109403018e-9)*q-1.517906721393745e-7)*q-2.430939946375515e-6)*q-
+ 3.901461426385464e-5)*q-6.324811612385572e-4)*q-1.076606829172646e-2)*q-
+ 0.2617993877991508)*q+pi4);
+
+ SELECT n OF
+ CASE 0 : s/q
+ CASE 1 : q/s
+ CASE 2 : -q/s
+ OTHERWISE : -s/q ENDSELECT .
+
+END PROC tg;
+
+REAL PROC sin ( REAL CONST x ):
+ REAL VAR y, r, q;
+ IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI;
+ y := y * pi4;
+ r := floor(y);
+ sincos( q+r , y-r )
+END PROC sin;
+
+REAL PROC sind ( REAL CONST x ):
+ REAL VAR y, r, q;
+ IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI;
+ y := y / 45.0;
+ r := floor(y);
+ sincos( q+r , y-r )
+END PROC sind;
+
+REAL PROC cos ( REAL CONST x ):
+ REAL VAR y, q;
+ IF x < 0.0 THEN y := -x ELSE y := x FI;
+ y := y * pi4;
+ q := floor(y);
+ sincos( q+2.0, y-q )
+END PROC cos;
+
+REAL PROC cosd ( REAL CONST x ):
+ REAL VAR y, q;
+ IF x < 0.0 THEN y := -x ELSE y := x FI;
+ y := y / 45.0;
+ q := floor(y);
+ sincos( q+2.0, y-q )
+END PROC cosd;
+
+REAL PROC sincos ( REAL CONST q, y ):
+ REAL VAR r :: q - floor( 0.125*q + 0.1 ) * 8.0;
+ IF r >= 4.0 THEN IF r >= 6.0 THEN IF r >= 7.0 THEN - sin approx(1.0-y)
+ ELSE - cos approx(y) FI
+ ELSE IF r >= 5.0 THEN - cos approx(1.0-y)
+ ELSE - sin approx(y) FI FI
+ ELSE IF r >= 2.0 THEN IF r >= 3.0 THEN sin approx(1.0-y)
+ ELSE cos approx(y) FI
+ ELSE IF r >= 1.0 THEN cos approx(1.0-y)
+ ELSE sin approx(y) FI FI FI
+END PROC sincos;
+
+REAL PROC sin approx ( REAL CONST x ):
+ REAL VAR z::x*x;
+ x*((((((0.6877101540593035e-11*z-0.1757149296873372e-8)*z+0.3133616216672568
+ e-6)*z-0.3657620415845891e-4)*z+0.2490394570188737e-2)*z-0.807455121882e-1)*
+ z+0.7853981633974483)
+END PROC sin approx;
+
+REAL PROC cos approx ( REAL CONST x ):
+ REAL VAR z::x*x;
+ ((((((-0.3857761864560276e-12*z+0.115004970178141e-9)*z-0.246113638267419e-7
+ )*z+0.3590860445885748e-5)*z-0.3259918869266875e-3)*z+0.1585434424381541e-1)
+ *z-0.3084251375340425)*z+1.0
+END PROC cos approx;
+
+REAL PROC arctan ( REAL CONST y ):
+ REAL VAR f, z, x; BOOL VAR neg :: y < 0.0;
+ IF neg THEN x := -y ELSE x := y FI;
+ IF x>1.0 THEN f := a ELSE f := -b; neg := NOT neg FI;
+ z := x * x;
+ x := x/(((((((0.0107090276046822*z-0.01647757182108040)*z
+ +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z
+ -0.0888888888888888)*z+0.3333333333333333)*z+1.0);
+ IF neg THEN x - f ELSE f - x FI.
+
+ a:IF x>sqr3p2 THEN x := 1.0/x; pi2 ELSE x := 4.0/(sqrt3+x+x+x)-sqr3; pi3 FI.
+ b:IF x<sqr3m2 THEN 0.0 ELSE x := sqrt3 - 4.0/(sqrt3+x); pi6 FI
+END PROC arctan;
+
+REAL PROC arctand ( REAL CONST x ):
+ arctan(x) * pi180
+END PROC arctand;
+
+REAL OP ** ( REAL CONST b, e ):
+ IF b=0.0
+ THEN IF e=0.0 THEN 1.0 ELSE 0.0 FI
+ ELIF b < 0.0
+ THEN errorstop("("+text(b,20)+") ** "+text(e)); (-b) ** e
+ ELSE exp( e * log2( b ) * ln2 )
+ FI
+END OP **;
+
+REAL OP ** ( REAL CONST a, INT CONST b ) :
+
+ REAL VAR p := 1.0 ,
+ r := a ;
+ INT VAR n := ABS b ,
+ m ;
+ IF (a = 0.0 OR a = -0.0)
+ THEN IF b = 0
+ THEN 1.0
+ ELSE 0.0
+ FI
+ ELSE WHILE n>0 REP
+ m := n DIV 2 ;
+ IF m + m = n
+ THEN n := m ;
+ r := r*r
+ ELSE n DECR 1 ;
+ p := p*r
+ FI
+ END REP ;
+ IF b>0
+ THEN p
+ ELSE 1.0 / p
+ FI
+ FI .
+
+END OP ** ;
+
+REAL PROC random:
+ rdg:=rdg+pii;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg
+END PROC random;
+
+PROC initializerandom ( REAL CONST z ):
+ rdg := frac(z)
+END PROC initializerandom;
+
+END PACKET mathlib;
+
diff --git a/system/base/1.7.5/src/pattern match b/system/base/1.7.5/src/pattern match
new file mode 100644
index 0000000..f6190d8
--- /dev/null
+++ b/system/base/1.7.5/src/pattern match
@@ -0,0 +1,768 @@
+PACKET pattern match DEFINES (* Author: P.Heyderhoff *)
+ (* Date: 09.06.1986 *)
+ -,
+ OR,
+ **,
+ any,
+ notion,
+ bound,
+ match,
+ matchpos,
+ matchend,
+ somefix,
+ UNLIKE,
+ LIKE :
+
+(*------- Operation codes of the internal intermeadiate language: --------*)
+
+LET
+ z = ""0"",
+ stopz = ""1""0"",
+ closez = ""2""0"",
+ closor = ""2""0""3""0"",
+ or = ""3"",
+ oralpha = ""3""5"",
+ open2 = ""4""0""4""0"",
+ alpha = ""5"",
+ alphaz = ""5""0"",
+ lenz = ""6""0"",
+ nilz = ""6""0""0""0""7""0"", (* = any (0) *)
+ starz = ""7""0"",
+ star = ""8""0""2""7""0""1""0"", (* = any ** 1 *)
+ powerz = ""8""0"",
+ powerz0 = ""8""0""1"",
+ notionz = ""9""0"",
+ fullz = ""10""0"",
+ boundz = ""11""0"";
+(*------------------------------------------------------------------------*)
+
+LET undefined = 0, (* fixleft value *)
+ forcer = 0, (* vaHue parameter *)
+ delimiter = " !""#$%&'()*+,-./:;<=>?§^_`­"; (* for 'PROC notion' *)
+
+TEXT OP - (TEXT CONST alphabet ):
+ p:= "";
+ INT VAR j;
+ FOR j FROM 0 UPTO 255
+ REP IF pos(alphabet,code(j)) = 0
+ THEN p CAT code(j)
+ FI
+ PER;
+ p
+ ENDOP -;
+
+TEXT OP OR (TEXT CONST a, b):
+ open2 + notnil (a) + closor + notnil (b) + closez
+ ENDOP OR;
+
+TEXT OP ** (TEXT CONST p, INT CONST x):
+ powerz + code (1+x) + notnil (p) + stopz
+ ENDOP **;
+
+TEXT CONST any:= starz;
+
+TEXT PROC any (INT CONST n):
+ TEXT VAR t:= " ";
+ replace (t, 1, ABSn);
+ lenz + t + starz
+ ENDPROC any;
+
+TEXT PROC any (TEXT CONST a): alphaz + a + starz ENDPROC any;
+
+TEXT PROC any (INT CONST n, TEXT CONST a):
+ TEXT VAR t:= " ";
+ replace (t, 1, ABSn);
+ lenz + t + alphaz + a + starz
+ ENDPROC any;
+
+TEXT PROC notion (TEXT CONST t): notionz + notnil(t) + stopz ENDPROC notion;
+
+TEXT PROC notnil (TEXT CONST t):
+ IF t = ""
+ THEN nilz
+ ELSE t
+ FI
+ ENDPROC notnil;
+
+TEXT CONST bound := boundz;
+
+TEXT PROC full (TEXT CONST t): fullz + t + stopz ENDPROC full;
+
+TEXT PROC match (INT CONST x):
+ subtext (p, matchpos(x), matchend(x))
+ ENDPROC match;
+
+INT PROC matchpos (INT CONST x): mapos (1 + x MOD 256) ENDPROC matchpos;
+
+INT PROC matchend (INT CONST x): maend (1 + x MOD 256) - 1
+ ENDPROC matchend;
+
+(*----------------- GLOBAL VARIABLES: -----------------------------------*)
+
+ROW 256 INT VAR
+ (* Table of match registers. Each entry consists of two *)
+ (* pointers, which points to the TEXT object 't' *)
+ mapos, (* points to the beginning of the match *)
+ maend; (* points to the position after the end of match *)
+
+INT VAR ppos, tpos, (* workpositions in pattern 'p' and text 't' *)
+ floatpos, (* accumulation of all pending floatlengths *)
+ failpos, (* result of 'PROC in alpha' *)
+ plen, tlen, (* length of pattern 'p' and length of text 't' *)
+ skipcount, (* for track forward skipping *)
+ multi, vari; (* for handling of nonexclusive alternatives *)
+
+TEXT VAR p, (* the pattern to be find or some result *)
+ stack, (* stack of pending assignments *)
+ alphabet:=""; (* result of 'PROC find alpha', reset to nil *)
+ (* after its usage by 'find any' *)
+
+BOOL VAR fix, (* text position is fixed and not floating *)
+ no vari; (* not variing the order of alternatives *)
+
+TEXT PROC somefix (TEXT CONST pattern):
+
+ (* delivers the first text occuring unconditionally in the pattern *)
+
+ p:= pattern;
+ INT VAR j:= 1, n:= 0, k, len:= LENGTH p;
+ REP
+ SELECT text( subtext (p, j, j+1), 2) ISUB 1 OF
+ CASE 1,3,7,9,10,11: j INCR 2
+ CASE 2: j INCR 2; n DECR 1 (* condition closed *)
+ CASE 4: j INCR 2; n INCR 1 (* condition opened *)
+ CASE 5: j := pos (p, starz, j+2) + 2
+ CASE 6: j INCR 4
+ CASE 8: j INCR 3
+ OTHERWISE k:= pos(p, z, j+1) - 1;
+ IF k <= 0 THEN k:= 1+len FI;
+ IF star found
+ THEN change (p, starpos, starpos, star);
+ len:= LENGTH p;
+ k:= starpos
+ FI;
+ IF n = 0 CAND ( p SUB k ) <> or CAND k > j
+ THEN LEAVE somefix WITH subtext(p,j,k-1)
+ ELSE j:=k
+ FI
+ ENDSELECT
+ UNTIL j > len
+ PER;
+ "" .
+
+ star found:
+ INT VAR starpos:= pos (p, "*", j);
+ starpos > 0 CAND starpos <= k .
+
+ ENDPROC somefix;
+
+PROC skip (TEXT CONST p, BOOL CONST upto or):
+
+ (* skips 'ppos' upto the end of the opened nest, n = nesting level *)
+
+ INT VAR n:= 0;
+ REP
+ SELECT text (subtext (p, ppos, ppos+1), 2) ISUB 1 OF
+ CASE 1,2: IF n = 0
+ THEN LEAVE skip
+ FI;
+ ppos INCR 2;
+ nDECR1
+ CASE 3: IF n = 0 CAND upto or
+ THEN LEAVE skip
+ FI;
+ ppos INCR 2
+ CASE 7: ppos INCR 2
+ CASE 4,9,10,11: ppos INCR 2;
+ n INCR 1
+ CASE 5: ppos:= pos (p, starz, ppos+2) + 2
+ CASE 6: ppos INCR 4
+ CASE 8: ppos INCR 3;
+ n INCR 1
+ OTHERWISE ppos:= pos(p, z, ppos+1) - 1;
+ IF ppos < 0
+ THEN ppos:= plen;
+ LEAVE skip
+ FI
+ ENDSELECT
+ PER
+ ENDPROC skip;
+
+BOOL OP UNLIKE (TEXT CONST t, p): NOT ( t LIKE p ) ENDOP UNLIKE;
+
+BOOL OP LIKE (TEXT CONST t, pattern):
+ init;
+ BOOL CONST found:= find (t,1,1, fixresult, floatresult);
+ save;
+ found.
+
+ init: no vari:= TRUE;
+ vari:= 0;
+ tlen:= 1 + LENGTH t;
+ p:= full (pattern);
+ IF pos (p, bound) > 0
+ THEN
+ IF subtext (p, 14, 15) = bound
+ THEN p:= subtext (p, 1, 8) + powerz0 + subtext (p, 16)
+ FI;
+ plen:= LENGTH p - 7;
+ IF subtext (p, plen, plen+1) = bound
+ THEN p:= subtext (p, 1, plen - 1) + stopz + stopz
+ FI;
+ FI;
+ plen:= LENGTH p + 1;
+ INT VAR fixresult, floatresult;
+ tpos:= 1;
+ floatpos:= 0;
+ stack:= "";
+ alphabet:= "";
+ fix:= TRUE;
+ skipcount:= 0;
+ multi:= 0.
+
+ save: p:= t
+
+ ENDOP LIKE;
+
+(*-------- Realisation of the pattern matching algorithms 'find' --------*)
+
+BOOL PROC find
+ (TEXT CONST t, INT CONST unit, from, INT VAR fixleft, floatlen):
+
+ initialize;
+ BOOL CONST found:= pattern unit;
+ SELECT next command * unit OF
+ CASE 0,1,2: found
+ CASE 3: next;
+ find alternative
+ OTHERWISE find concatenation
+ ENDSELECT .
+
+ find alternative:
+ IF found
+ THEN save left position;
+ backtrack;
+ IF find pattern CAND better
+ THEN note multiplicity
+ ELSE back to first one
+ FI
+ ELSE backtrack multi
+ FI.
+
+ better: permutation XOR more left.
+
+ permutation: vari MOD 2 = 1.
+
+ save left position: j:= fixleft.
+
+ more left: j > fixleft.
+
+ backtrack multi: multi:= 2 * backmulti + 1;
+ vari:= backvari DIV 2;
+ find pattern.
+
+ note multiplicity: multi:= 2 * multi + 1;
+ vari:= vari DIV 2;
+ TRUE.
+
+ back to first one: backtrack;
+ IF find first subpattern
+ THEN skip (p, FALSE);
+ note multiplicity
+ ELSE errorstop ("pattern");
+ FALSE
+ FI.
+
+ find concatenation:
+ IF found
+ THEN IF ppos=plen COR find pattern COR track forward
+ COR ( multi > backmulti CAND vari = 0 CAND find variation )
+ THEN TRUE
+ ELSE backtrack; FALSE
+ FI
+ ELSE skip (p, TRUE); FALSE
+ FI.
+
+ track forward: (* must be performed before variation *)
+ j:=0;
+ last multi:= multi;
+ last vari:= vari;
+ WHILE skipcount = 0
+ REP IF tlen = tpos
+ THEN LEAVE track forward WITH FALSE
+ FI;
+ backtrack;
+ j INCR 1;
+ skipcount:= j
+ UNTIL find first subpattern CAND find pattern
+ PER;
+ j:= skipcount;
+ skipcount:=0;
+ j=0.
+
+ find variation:
+ multi:= last multi;
+ vari:= last vari;
+ FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1
+ REP backtrack with variation;
+ IF find first subpattern CAND find pattern
+ THEN vari:=0;
+ LEAVE find variation WITH TRUE
+ FI
+ PER;
+ FALSE.
+
+ backtrack with variation:
+ backtrack;
+ vari:= k.
+
+ find pattern:
+ find (t, 1, ppos+forcer, fixresult, floatresult) CAND keep result.
+
+ find first subpattern:
+ find (t, 0, from, fixresult, floatresult) CAND keep result .
+
+ initialize:
+ INT VAR j,
+ k,
+ fixresult,
+ floatresult,
+ last multi,
+ last vari;
+ BOOL CONST backfix:= fix;
+ TEXT CONST backstack:= stack;
+ floatlen:= 0;
+ INT CONST back:= tpos,
+ backfloat:= floatpos,
+ backskip:= skipcount,
+ backmulti:= multi,
+ backvari:= vari;
+ fixleft:= fixleft0.
+
+ fixleft0: IF fix THEN back ELSE undefined FI.
+
+ backtrack:
+ fix:= backfix;
+ tpos:= back;
+ fixleft:= fixleft0;
+ floatlen:= 0;
+ floatpos:= backfloat;
+ stack:= backstack;
+ skipcount:= backskip;
+ multi:= backmulti;
+ vari:= backvari.
+
+ keep result:
+ IF fixleft = undefined
+ THEN IF fixresult = undefined
+ THEN floatlen INCR floatresult
+ ELSE fixleft := fixresult - floatlen;
+ floatpos DECR floatlen;
+ floatlen:= 0
+ FI
+ FI;
+ TRUE.
+
+ pattern unit:
+ init ppos;
+ SELECT command OF
+ CASE 1,2: find end
+ CASE 3: find nil
+ CASE 4: find choice
+ CASE 5: find alphabet
+ CASE 6: find fixlength any
+ CASE 7: find varlength any
+ CASE 8: find and store match
+ CASE 9: find notion
+ CASE 10: find full
+ CASE 11: next; find nil
+ OTHERWISE find plain text END SELECT.
+
+ init ppos: ppos:= from + 2.
+
+ command: text (subtext (p, from, from+1), 2) ISUB 1.
+
+ next command: text (subtext (p, ppos, ppos+1), 2) ISUB 1.
+
+ next: ppos INCR 2.
+
+ find end: ppos DECR 2;
+ fixleft:= tpos;
+ LEAVE find WITH TRUE;
+ TRUE.
+
+ find nil: ppos DECR 2;
+ fixleft:= tpos;
+ TRUE.
+
+ find choice: IF find pattern
+ THEN next; TRUE
+ ELSE next; FALSE
+ FI.
+
+ find plain text: find text upto next command;
+ IF fix THEN allow fix position only
+ ELIF text found THEN allow variable position
+ ELSE allow backtrack
+ FI.
+
+ find text upto next command:
+ ppos:= pos (p, z, from + 1);
+ IF ppos = 0
+ THEN ppos:= plen
+ ELSE ppos DECR 1
+ FI;
+ IF star found
+ THEN change (p, starpos, starpos, star);
+ plen:= 1 + LENGTH p;
+ ppos:= starpos
+ FI;
+ tpos:= pos (t, subtext (p, from, ppos - 1), tpos).
+
+ star found:
+ INT VAR starpos:= pos (p, "*", from);
+ starpos > 0 CAND starpos <= ppos .
+
+ text found:
+ WHILE skipcount > 0 CAND tpos > 0
+ REP skipcount DECR 1;
+ tpos:= pos (t, subtext(p,from,ppos-1), tpos+1)
+ PER;
+ tpos > 0 .
+
+ allow fix position only:
+ IF tpos = back
+ THEN tpos INCR (ppos-from); TRUE
+ ELSE tpos:= back;
+ from = ppos
+ FI.
+
+ allow variable position:
+ IF alphabet = "" COR in alpha (t, back, tpos)
+ THEN fix it;
+ tpos INCR (ppos-from);
+ TRUE
+ ELSE tpos:= back;
+ FALSE
+ FI.
+
+ allow backtrack:
+ tpos:= back;
+ IF from = ppos
+ THEN fix it;
+ TRUE
+ ELSE FALSE
+ FI .
+
+ find alphabet:
+ j:= pos (p, starz, ppos);
+ alphabet:= subtext (p, ppos, j-1);
+ ppos := j;
+ TRUE.
+
+ find fixlength any:
+ get length value;
+ find alpha attribut;
+ IF alphabet = ""
+ THEN find any with fix length
+ ELSE find any in alphabet with fix length
+ FI.
+
+ get length value:
+ floatlen:= subtext(p, ppos, ppos+1) ISUB 1;
+ ppos INCR 4.
+
+ find alpha attribut:
+ IF (p SUB (ppos-2)) = alpha CAND find alphabet
+ THEN next
+ FI.
+
+ find any with fix length:
+ tpos INCR floatlen;
+ IF tpos > tlen
+ THEN tpos:= back;
+ floatlen:=0;
+ FALSE
+ ELSE IF fix THEN floatlen:= 0
+ ELIF floatlen = 0
+ THEN fix it (* unlike niltext 6.6. *)
+ ELSE floatpos INCR floatlen
+ FI;
+ TRUE
+ FI.
+
+ find any in alphabet with fix length:
+ IF first character in alpha
+ THEN IF NOT fix THEN fix it FI;
+ set fix found
+ ELSE set fix not found
+ FI.
+
+ first character in alpha:
+ (fix COR advance) CAND in alpha (t, tpos, tpos+floatlen).
+
+ advance:
+ FOR tpos FROM back UPTO tlen
+ REP IF pos (alphabet, t SUB tpos) > 0
+ THEN LEAVE advance WITH TRUE
+ FI
+ PER;
+ FALSE.
+
+ fix it:
+ fixleft:= back-floatpos;
+ make fix (back);
+ fixleft:= tpos.
+
+ set fix found:
+ tpos INCR floatlen;
+ floatlen:= 0;
+ alphabet:= "";
+ TRUE.
+
+ set fix not found: tpos:= back;
+ alphabet:= "";
+ floatlen:= 0;
+ FALSE.
+
+ find varlength any: IF alphabet = ""
+ THEN really any
+ ELSE find varlength any in alphabet
+ FI.
+
+ really any: IF fix
+ THEN fix:= FALSE;
+ fixleft:= tpos
+ ELIF floatpos = 0
+ THEN fixleft:= tpos (* 6.6. *)
+ FI;
+ TRUE .
+
+ find varlength any in alphabet:
+ IF fix THEN fixleft := tpos FI;
+ IF fix CAND pos (alphabet, t SUB tpos) > 0
+ COR NOT fix CAND advance
+ THEN IF NOT fix THEN fix it FI;
+ set var found
+ ELSE set var not found
+ FI.
+
+ set var found: tpos:= end of varlength any;
+ alphabet:= "";
+ TRUE.
+ set var not found: tpos:= back;
+ alphabet:= "";
+ FALSE.
+ end of varlength any: IF NOT in alpha(t,tpos,tlen)
+ THEN failpos
+ ELSE tlen
+ FI.
+
+ find and store match: get register name;
+ IF find pattern
+ THEN next;
+ store;
+ TRUE
+ ELSE next;
+ FALSE
+ FI.
+
+ store: IF fix
+ THEN mapos (reg):= fixleft;
+ maend (reg):= tpos
+ ELSE stack CAT code(floatlen) +
+ code(floatpos) + code(fixleft) + c
+ FI.
+
+ get register name: TEXT CONST c:= p SUB (ppos);
+ INT VAR reg:= code (c);
+ ppos INCR 1.
+
+ find notion: float notion;
+ exhaust notion .
+
+ float notion: j:= back;
+ REP IF find pattern
+ THEN IF is notion (t, fixleft)
+ THEN LEAVE find notion WITH TRUE
+ ELIF backfix
+ THEN LEAVE float notion
+ ELSE go ahead FI
+ ELIF j=back
+ THEN next;
+ LEAVE find notion WITH FALSE
+ ELSE LEAVE float notion
+ FI
+ PER.
+
+ go ahead: j INCR 1;
+ IF simple THEN j:= max (tpos, j) FI;
+ notion backtrack.
+
+ simple: k:= from;
+ REP k := pos (p, z, k+2);
+ IF k > ppos-3
+ THEN LEAVE simple WITH TRUE
+ ELIF pos (oralpha, p SUB k-1) > 0
+ THEN LEAVE simple WITH FALSE
+ FI
+ PER;
+ FALSE.
+
+ notion backtrack: tpos:= j;
+ fix:= backfix;
+ fixleft:= fixleft0;
+ floatlen:= 0;
+ floatpos:= backfloat + tpos - back;
+ stack:= backstack;
+ ppos:= from + 2 .
+
+ exhaust notion: IF notion expansion
+ COR multi > backmulti
+ CAND no vari
+ CAND notion variation
+ THEN TRUE
+ ELSE backtrack; FALSE
+ FI.
+
+ notion expansion: j:= 0;
+ multi:= last multi;
+ vari:= last vari;
+ WHILE skipcount = 0
+ REP skip and try PER;
+ j:= skipcount;
+ skipcount:= 0;
+ j = 0.
+
+ skip and try: backtrack;
+ j INCR 1;
+ skipcount:=j;
+ ppos:= from + 2;
+ IF find pattern
+ THEN IF is notion (t, fixleft)
+ THEN LEAVE find notion WITH TRUE
+ FI
+ ELSE next; LEAVE find notion WITH FALSE
+ FI .
+
+ notion variation: no vari:= FALSE;
+ last multi:= multi;
+ last vari:= vari;
+ FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1
+ REP backtrack with variation;
+ IF find first subpattern
+ THEN no vari:= TRUE;
+ LEAVE find notion WITH TRUE
+ FI
+ PER;
+ no vari:= TRUE;
+ FALSE.
+
+ find full:
+ find pattern CAND (end of line COR exhaust line).
+
+ end of line:
+ next;
+ IF fix
+ THEN tpos = tlen
+ ELSE tpos:= tlen;
+ make fix (1);
+ TRUE
+ FI.
+
+ exhaust line:
+ IF full expansion COR multi > 0 CAND no vari CAND full variation
+ THEN TRUE ELSE backtrack;
+ FALSE
+ FI.
+
+ full expansion:
+ j:=0;
+ last multi:= multi;
+ last vari:= vari;
+ WHILE skipcount = 0
+ REP IF tlen = tpos
+ THEN LEAVE full expansion WITH FALSE
+ FI;
+ backtrack;
+ j INCR 1;
+ skipcount:= j;
+ ppos:=from + 2
+ UNTIL find pattern CAND tpos=tlen
+ PER;
+ j:= skipcount;
+ skipcount:=0;
+ j=0.
+
+ full variation:
+ no vari:= FALSE;
+ multi:= last multi;
+ vari:= last vari;
+ FOR k FROM 1 UPTO multi
+ REP backtrack with variation;
+ IF find first subpattern
+ THEN no vari:= TRUE;
+ LEAVE find WITH TRUE
+ FI
+ PER;
+ no vari:= TRUE;
+ FALSE.
+
+ ENDPROC find;
+
+BOOL PROC is notion (TEXT CONST t, INT CONST fixleft):
+ ppos INCR 2;
+ ( NOT fix
+ COR tpos = tlen
+ COR pos (delimiter, t SUB tpos) > 0
+ COR pos (delimiter, t SUB tpos-1) > 0
+ COR (t SUB tpos) <= "Z"
+ CAND (t SUB tpos-1) > "Z" )
+ CAND ( fixleft <= 1
+ COR pos (delimiter, t SUB fixleft-1) > 0
+ COR pos (delimiter, t SUB fixleft) > 0
+ COR (t SUB fixleft) > "Z"
+ CAND (t SUB fixleft-1) <= "Z" )
+
+ END PROC is notion;
+
+PROC make fix (INT CONST back):
+ WHILE stack not empty
+ REP INT VAR reg:= code (stack SUB top),
+ pos:= code (stack SUB top-1),
+ len:= code (stack SUB top-3),
+ dis:= code (stack SUB top-2) - floatpos;
+ maend(reg):= min (tpos + dis, tlen); (* 6.6. *)
+ mapos(reg):= pos or fix or float;
+ stack:= subtext (stack,1,top-4)
+ PER;
+ fix:= TRUE;
+ floatpos:= 0 .
+
+ stack not empty: INT VAR top:= LENGTH stack;
+ top > 0.
+
+ pos or fix or float:
+ IF pos = undefined
+ THEN IF len = 0
+ THEN min (back + dis, tlen)
+ ELSE maend(reg) - len
+ FI
+ ELSE pos
+ FI.
+
+ ENDPROC make fix;
+
+BOOL PROC in alpha (TEXT CONST t, INT CONST from, to):
+ FOR failpos FROM from UPTO to - 1
+ REP IF pos (alphabet, t SUB failpos) = 0
+ THEN LEAVE in alpha WITH FALSE
+ FI
+ PER;
+ TRUE
+ ENDPROC in alpha;
+
+TEXT PROC notion (TEXT CONST t, INT CONST r): notion (t) ** r ENDPROC notion;
+
+ENDPACKET pattern match;
+
diff --git a/system/base/1.7.5/src/pcb control b/system/base/1.7.5/src/pcb control
new file mode 100644
index 0000000..9bf0e2d
--- /dev/null
+++ b/system/base/1.7.5/src/pcb control
@@ -0,0 +1,79 @@
+
+PACKET pcb and init control DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 25.08.84 *)
+ session ,
+ pcb ,
+ set line nr ,
+ clock ,
+ INITFLAG ,
+ := ,
+ initialized ,
+ storage ,
+ id ,
+ ke :
+
+
+LET line number field = 1 ,
+ myself id field = 9 ;
+
+TYPE INITFLAG = INT ;
+
+
+INT PROC session :
+ EXTERNAL 126
+ENDPROC session ;
+
+INT PROC pcb (INT CONST field) :
+ EXTERNAL 80
+ENDPROC pcb ;
+
+PROC write pcb (INT CONST task nr, field, value) :
+ EXTERNAL 105
+ENDPROC write pcb ;
+
+PROC set line nr (INT CONST value) :
+ write pcb (pcb (myself id field), line number field, value)
+ENDPROC set line nr ;
+
+
+OP := (INITFLAG VAR flag, BOOL CONST flagtrue) :
+
+ IF flagtrue
+ THEN CONCR (flag) := myself no
+ ELSE CONCR (flag) := 0
+ FI .
+
+myself no : pcb (myself id field) AND 255 .
+
+ENDOP := ;
+
+BOOL PROC initialized (INITFLAG VAR flag) :
+
+ IF CONCR (flag) = myself no
+ THEN TRUE
+ ELSE CONCR (flag) := myself no ;
+ FALSE
+ FI .
+
+myself no : pcb (myself id field) AND 255 .
+
+ENDPROC initialized ;
+
+REAL PROC clock (INT CONST nr) :
+ EXTERNAL 102
+ENDPROC clock ;
+
+PROC storage (INT VAR size, used) :
+ EXTERNAL 89
+ENDPROC storage ;
+
+INT PROC id (INT CONST no) :
+ EXTERNAL 129
+ENDPROC id ;
+
+PROC ke :
+ EXTERNAL 6
+ENDPROC ke ;
+
+ENDPACKET pcb and init control ;
+
diff --git a/system/base/1.7.5/src/real b/system/base/1.7.5/src/real
new file mode 100644
index 0000000..3e3c651
--- /dev/null
+++ b/system/base/1.7.5/src/real
@@ -0,0 +1,442 @@
+(* ------------------- VERSION 6 05.05.86 ------------------- *)
+PACKET real DEFINES (* Autor: J.Liedtke *)
+
+ text ,
+ int ,
+ real ,
+ round ,
+ floor ,
+ frac ,
+ decimal exponent ,
+ set exp ,
+ INCR ,
+ DECR ,
+ abs ,
+ ABS ,
+ sign ,
+ SIGN ,
+ MOD ,
+ min ,
+ max ,
+ max real ,
+ small real :
+
+LET mantissa length = 13 ,
+ digit zero index = 1 ,
+ digit nine index = 10 ;
+INT CONST
+ decimal point index := -1 ;
+
+TEXT VAR mantissa ;
+
+ROW 10 REAL VAR real digit ;
+
+INT VAR i ; REAL VAR d := 0.0 ;
+FOR i FROM 1 UPTO 10 REP
+ real digit (i) := d ;
+ d := d + 1.0
+PER ;
+
+REAL PROC max real : 9.999999999999e126 ENDPROC max real ;
+
+REAL PROC small real : 1.0e-12 ENDPROC small real ;
+
+PROC sld (INT CONST in, REAL VAR real, INT VAR out) :
+ EXTERNAL 96
+ENDPROC sld ;
+
+INT PROC decimal exponent (REAL CONST mantissa) :
+ EXTERNAL 97
+ENDPROC decimal exponent ;
+
+PROC set exp (INT CONST exponent, REAL VAR number) :
+ EXTERNAL 98
+ENDPROC set exp ;
+
+REAL PROC tenpower (INT CONST exponent) :
+ REAL VAR result := 1.0 ;
+ set exp (exponent, result) ;
+ result
+ENDPROC tenpower ;
+
+REAL PROC floor (REAL CONST real) :
+ EXTERNAL 99
+ENDPROC floor ;
+
+REAL PROC round (REAL CONST real, INT CONST digits) :
+
+ REAL VAR result := real ;
+ IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length)
+ THEN round result ;
+ FI ;
+ result .
+
+round result :
+ set exp (decimal exponent (result) + digits, result) ;
+ IF result >= 0.0
+ THEN result := floor (result + 0.5)
+ ELSE result := floor (result - 0.5)
+ FI ;
+ IF result <> 0.0
+ THEN set exp (decimal exponent (result) - digits, result)
+ FI .
+
+ENDPROC round ;
+
+TEXT VAR result ;
+
+TEXT PROC text (REAL CONST real) :
+
+ REAL VAR value := rounded to seven digits ;
+ IF value = 0.0
+ THEN "0.0"
+ ELSE
+ process sign ;
+ get mantissa (value) ;
+ INT CONST exponent := decimal exponent (value) ;
+ get short mantissa ;
+ IF exponent > 7 OR exponent < LENGTH short mantissa - 7
+ THEN scientific notation
+ ELSE short notation
+ FI
+ FI .
+
+rounded to seven digits :
+ round ( real * tenpower( -decimal exponent(real) ) , 6 )
+ * tenpower ( decimal exponent(real) ) .
+
+process sign :
+ IF value < 0.0
+ THEN result := "-" ;
+ value := - value
+ ELSE result := ""
+ FI .
+
+get short mantissa :
+ INT VAR i := 7 ;
+ WHILE (mantissa SUB i) = "0" REP
+ i DECR 1
+ UNTIL i=1 END REP ;
+ TEXT CONST short mantissa := subtext (mantissa, 1, i) .
+
+scientific notation :
+ result CAT (mantissa SUB 1) ;
+ result CAT "." ;
+ result CAT subtext (mantissa, 2, 7) ;
+ result + "e" + text (exponent) .
+
+short notation :
+ IF exponent < 0
+ THEN result + "0." + (-exponent - 1) * "0" + short mantissa
+ ELSE result CAT subtext (short mantissa, 1, exponent+1) ;
+ result CAT (exponent+1 - LENGTH short mantissa) * "0" ;
+ result CAT "." ;
+ result CAT subtext (short mantissa, exponent+2) ;
+ IF LENGTH short mantissa < exponent + 2
+ THEN result + "0"
+ ELSE result
+ FI
+ FI .
+
+ENDPROC text ;
+
+PROC get mantissa (REAL CONST number) :
+
+ REAL VAR real mantissa := number ;
+ mantissa := "" ;
+ INT VAR i , digit ;
+ FOR i FROM 1 UPTO mantissa length REP
+ sld (0, real mantissa, digit) ;
+ mantissa CAT code (digit + 48)
+ PER ;
+
+ENDPROC get mantissa ;
+
+TEXT PROC text (REAL CONST real, INT CONST length) :
+
+ INT CONST mantissa length := min (length - 7, 13) ;
+ IF mantissa length > 0
+ THEN construct scientific notation
+ ELSE result := length * "*"
+ FI ;
+ result .
+
+construct scientific notation :
+ REAL VAR value := rounded real ;
+ IF value = 0.0
+ THEN result := subtext (" 0.0 ", 1, length)
+ ELSE process sign ;
+ process mantissa ;
+ process exponent
+ FI .
+
+rounded real :
+ round (real * tenpower ( -decimal exponent (real)) , mantissa length - 1)
+ * tenpower (decimal exponent (real)) .
+
+process sign :
+ IF value < 0.0
+ THEN result := "-"
+ ELSE result := "+"
+ FI .
+
+process mantissa :
+ get mantissa (value) ;
+ result CAT (mantissa SUB 1) ;
+ result CAT "." ;
+ result CAT subtext (mantissa, 2, mantissa length) .
+
+process exponent :
+ IF decimal exponent (value) >= 0
+ THEN result CAT "e+"
+ ELSE result CAT "e-"
+ FI ;
+ result CAT text (ABS decimal exponent (value), 3) ;
+ change all (result, " ", "0") .
+
+ENDPROC text ;
+
+TEXT PROC text (REAL CONST real, INT CONST length, fracs) :
+
+ REAL VAR value := round (real, fracs) ;
+ INT VAR exponent := decimal exponent (value) ;
+ IF value = 0.0 THEN exponent := 0 FI ;
+ INT VAR floors := exponent + 1 ,
+ floor length := length - fracs - 1 ;
+ IF value < 0.0 THEN floor length DECR 1 FI ;
+
+ IF value too big
+ THEN length * "*"
+ ELSE transformed value
+ FI .
+
+transformed value :
+ process leading blanks and sign ;
+ get mantissa (value) ;
+ result CAT subtext (mantissa, 1, floors) ;
+ IF LENGTH mantissa < floors
+ THEN result CAT (floors - LENGTH mantissa) * "0"
+ FI ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result CAT (-floors) * "0" ;
+ result CAT subtext (mantissa, 1, length - LENGTH result)
+ ELSE result CAT subtext (mantissa, floors+1, floors + fracs)
+ FI ;
+ IF LENGTH result < length
+ THEN result CAT (length - LENGTH result) * "0"
+ FI ;
+ result .
+
+process leading blanks and sign :
+ result := (floor length - max(floors,0)) * " " ;
+ IF value < 0.0
+ THEN result CAT "-" ;
+ value := - value
+ FI .
+
+value too big :
+ floors > floor length .
+
+ENDPROC text ;
+
+REAL PROC real (TEXT CONST text) :
+
+ skip leading blanks ;
+ sign ;
+ mantissa part ;
+ exponent ;
+ result .
+
+skip leading blanks :
+ INT VAR pos := 1 ;
+ skip blanks .
+
+skip blanks :
+ WHILE (text SUB pos) = " " REP
+ pos INCR 1
+ PER .
+
+sign :
+ BOOL VAR negative ;
+ IF (text SUB pos) = "-"
+ THEN negative := TRUE ;
+ pos INCR 1
+ ELIF (text SUB pos) = "+"
+ THEN negative := FALSE ;
+ pos INCR 1
+ ELSE negative := FALSE
+ FI .
+
+mantissa part:
+ REAL VAR value ;
+ INT VAR exponent pos := 0 ;
+ get first digit ;
+ WHILE pos <= LENGTH text REP
+ digit := code (text SUB pos) - 47 ;
+ IF digit >= digit zero index AND digit <= digit nine index
+ THEN value := value * 10.0 + real digit (digit) ;
+ pos INCR 1
+ ELIF digit = decimal point index AND exponent pos = 0
+ THEN pos INCR 1 ;
+ exponent pos := pos
+ ELSE LEAVE mantissa part
+ FI
+ END REP .
+
+get first digit :
+ INT VAR digit := code (text SUB pos) - 47 ;
+ IF digit = decimal point index
+ THEN pos INCR 1 ;
+ exponent pos := pos ;
+ digit := code (text SUB pos) - 47
+ FI ;
+ IF digit >= digit zero index AND digit <= digit nine index
+ THEN value := real digit (digit) ;
+ pos INCR 1
+ ELSE set conversion (FALSE) ;
+ LEAVE real WITH 0.0
+ FI .
+
+exponent :
+ INT VAR exp ;
+ IF exponent pos > 0
+ THEN exp := exponent pos - pos
+ ELSE exp := 0
+ FI ;
+ IF (text SUB pos) = "e"
+ THEN exp INCR int (subtext(text,pos+1))
+ ELSE no more nonblank chars permitted
+ FI .
+
+no more nonblank chars permitted :
+ skip blanks ;
+ IF pos > LENGTH text
+ THEN set conversion (TRUE)
+ ELSE set conversion (FALSE)
+ FI .
+
+result :
+ value := value * tenpower (exp) ;
+ IF negative
+ THEN - value
+ ELSE value
+ FI .
+
+ENDPROC real ;
+
+
+REAL PROC abs (REAL CONST value) :
+
+ IF value >= 0.0
+ THEN value
+ ELSE -value
+ FI
+
+ENDPROC abs ;
+
+REAL OP ABS (REAL CONST value) :
+
+ abs (value)
+
+ENDOP ABS ;
+
+INT PROC sign (REAL CONST value) :
+
+ IF value < 0.0 THEN -1
+ ELIF value = 0.0 THEN 0
+ ELSE 1
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (REAL CONST value) :
+
+ sign (value)
+
+ENDOP SIGN ;
+
+REAL OP MOD (REAL CONST left, right) :
+
+ REAL VAR result := left - floor (left/right) * right ;
+ IF result < 0.0
+ THEN result + abs (right)
+ ELSE result
+ FI
+
+ENDOP MOD ;
+
+REAL PROC frac (REAL CONST value) :
+
+ value - floor (value)
+
+ENDPROC frac ;
+
+REAL PROC max (REAL CONST a, b) :
+
+ IF a > b THEN a ELSE b FI
+
+ENDPROC max ;
+
+REAL PROC min (REAL CONST a, b) :
+
+ IF a < b THEN a ELSE b FI
+
+ENDPROC min ;
+
+OP INCR (REAL VAR dest, REAL CONST increment) :
+
+ dest := dest + increment
+
+ENDOP INCR ;
+
+OP DECR (REAL VAR dest, REAL CONST decrement) :
+
+ dest := dest - decrement
+
+ENDOP DECR ;
+
+INT PROC int (REAL CONST value) :
+
+ IF value = minint value
+ THEN minint
+ ELSE compute int result ;
+ IF value < 0.0
+ THEN - result
+ ELSE result
+ FI
+ FI .
+
+compute int result :
+ INT VAR result := 0, digit ,i ;
+ REAL VAR mantissa := value ;
+
+ FOR i FROM 0 UPTO decimal exponent (value) REP
+ sld (0, mantissa, digit) ;
+ result := result * 10 + digit
+ PER .
+
+minint value : - 32768.0 .
+minint : - 32767 - 1 .
+
+ENDPROC int ;
+
+REAL PROC real (INT CONST value) :
+
+ IF value < 0
+ THEN - real (-value)
+ ELIF value < 10
+ THEN real digit (value+1)
+ ELSE split value into head and last digit ;
+ real (head) * 10.0 + real digit (last digit+1)
+ FI .
+
+split value into head and last digit :
+ INT CONST
+ head := value DIV 10 ,
+ last digit := value - head * 10 .
+
+ENDPROC real ;
+
+ENDPACKET real ;
+
diff --git a/system/base/1.7.5/src/scanner b/system/base/1.7.5/src/scanner
new file mode 100644
index 0000000..35a632c
--- /dev/null
+++ b/system/base/1.7.5/src/scanner
@@ -0,0 +1,325 @@
+(* ------------------- VERSION 4 14.05.86 ------------------- *)
+PACKET scanner DEFINES (* Autor: J.Liedtke *)
+
+ scan ,
+ continue scan ,
+ next symbol :
+
+
+LET tag = 1 ,
+ bold = 2 ,
+ number = 3 ,
+ text = 4 ,
+ operator= 5 ,
+ delimiter = 6 ,
+ end of file = 7 ,
+ within comment = 8 ,
+ within text = 9 ;
+
+LET digit 0 = 48 ,
+ digit 9 = 57 ,
+ upper case a = 65 ,
+ upper case z = 90 ,
+ lower case a = 97 ,
+ lower case z = 122;
+
+
+TEXT VAR line := "" ,
+ char := "" ,
+ chars:= "" ;
+
+INT VAR position := 0 ,
+ comment depth ;
+BOOL VAR continue text ;
+
+
+PROC scan (TEXT CONST scan text) :
+
+ comment depth := 0 ;
+ continue text := FALSE ;
+ continue scan (scan text)
+
+ENDPROC scan ;
+
+PROC continue scan (TEXT CONST scan text) :
+
+ line := scan text ;
+ position := 0 ;
+ nextchar
+
+ENDPROC continue scan ;
+
+PROC next symbol (TEXT VAR symbol) :
+
+ INT VAR type ;
+ next symbol (symbol, type)
+
+ENDPROC next symbol ;
+
+PROC next symbol (TEXT VAR symbol, INT VAR type) :
+
+ skip blanks ;
+ IF is begin comment THEN process comment
+ ELIF comment depth > 0 THEN comment depth DECR 1 ;
+ process comment
+ ELIF is quote OR continue text THEN process text
+ ELIF is lower case letter THEN process tag
+ ELIF is upper case letter THEN process bold
+ ELIF is digit THEN process number
+ ELIF is delimiter THEN process delimiter
+ ELIF is niltext THEN eof
+ ELSE process operator
+ FI .
+
+
+process comment :
+ read comment ;
+ IF comment depth = 0
+ THEN next symbol (symbol, type)
+ ELSE type := within comment ;
+ symbol := ""
+ FI .
+
+process tag :
+ type := tag ;
+ assemble chars (lower case a, lower case z) ;
+ symbol := chars ;
+ REP
+ skip blanks ;
+ IF is lower case letter
+ THEN assemble chars (lower case a, lower case z)
+ ELIF is digit
+ THEN assemble chars (digit 0, digit 9)
+ ELSE LEAVE process tag
+ FI ;
+ symbol CAT chars
+ PER ;
+ nextchar .
+
+process bold :
+ type := bold ;
+ assemble chars (upper case a, upper case z) ;
+ symbol := chars .
+
+process number :
+ type := number ;
+ assemble chars (digit 0, digit 9) ;
+ symbol := chars ;
+ IF char = "." AND ahead char is digit
+ THEN process fraction ;
+ IF char = "e"
+ THEN process exponent
+ FI
+ FI .
+
+ahead char is digit :
+ digit 0 <= code (ahead char) AND code (ahead char) <= digit 9 .
+
+process fraction :
+ symbol CAT char ;
+ nextchar ;
+ assemble chars (digit 0, digit 9) ;
+ symbol CAT chars .
+
+process exponent :
+ symbol CAT char ;
+ nextchar ;
+ IF char = "+" OR char = "-"
+ THEN symbol CAT char ;
+ nextchar
+ FI ;
+ assemble chars (digit 0, digit 9) ;
+ symbol CAT chars .
+
+process text :
+ type := text ;
+ symbol := "" ;
+ IF continue text
+ THEN continue text := FALSE
+ ELSE next char
+ FI ;
+ WHILE not end of text REP
+ assemble chars (35, 254) ;
+ symbol CAT chars ;
+ IF NOT is quote
+ THEN symbol CAT char ;
+ nextchar
+ FI
+ ENDREP .
+
+not end of text :
+ IF is niltext
+ THEN continue text := TRUE ; type := within text ; FALSE
+ ELIF is quote
+ THEN end of text or exception
+ ELSE TRUE
+ FI .
+
+end of text or exception :
+ next char ;
+ IF is quote
+ THEN get quote ; TRUE
+ ELIF is digit
+ THEN get special char ; TRUE
+ ELSE FALSE
+ FI .
+
+get quote :
+ symbol CAT char ;
+ nextchar .
+
+get special char :
+ assemble chars (digit 0, digit 9) ;
+ symbol CAT code (int (chars) ) ;
+ nextchar .
+
+process delimiter :
+ type := delimiter ;
+ symbol := char ;
+ nextchar .
+
+process operator :
+ type := operator ;
+ symbol := char ;
+ nextchar ;
+ IF symbol = ":"
+ THEN IF char = "=" OR char = ":"
+ THEN symbol := ":=" ;
+ nextchar
+ ELSE type := delimiter
+ FI
+ ELIF is relational double char
+ THEN symbol CAT char ;
+ nextchar
+ ELIF symbol = "*" AND char = "*"
+ THEN symbol := "**" ;
+ next char
+ FI .
+
+eof :
+ type := end of file ;
+ symbol := "" .
+
+is lower case letter :
+ lower case a <= code (char) AND code (char) <= lower case z .
+
+is upper case letter :
+ upper case a <= code (char) AND code (char) <= upper case z .
+
+is digit :
+ digit 0 <= code (char) AND code (char) <= digit 9 .
+
+is delimiter : pos ( "()[].,;" , char ) > 0 .
+
+is relational double char :
+ TEXT VAR double := symbol + char ;
+ double = "<>" OR double = "<=" OR double = ">=" .
+
+is quote : char = """" .
+
+is niltext : char = "" .
+
+is begin comment : char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC next symbol ;
+
+PROC next char :
+
+ position INCR 1 ;
+ char := line SUB position
+
+ENDPROC next char ;
+
+PROC skip blanks :
+
+ position := pos (line, ""33"", ""254"", position) ;
+ IF position = 0
+ THEN position := LENGTH line + 1
+ FI ;
+ char := line SUB position .
+
+ENDPROC skip blanks ;
+
+TEXT PROC ahead char :
+
+ line SUB position+1
+
+ENDPROC ahead char ;
+
+PROC assemble chars (INT CONST low, high) :
+
+ INT CONST begin := position ;
+ position behind valid text ;
+ chars := subtext (line, begin, position-1) ;
+ char := line SUB position .
+
+position behind valid text :
+ position := pos (line, ""32"", code (low-1), begin) ;
+ IF position = 0
+ THEN position := LENGTH line + 1
+ FI ;
+ INT CONST higher pos := pos (line, code (high+1), ""254"", begin) ;
+ IF higher pos <> 0 AND higher pos < position
+ THEN position := higher pos
+ FI .
+
+ENDPROC assemble chars ;
+
+
+PROC read comment :
+
+ TEXT VAR last char ;
+ comment depth INCR 1 ;
+ REP
+ last char := char ;
+ nextchar ;
+ IF is begin comment
+ THEN read comment
+ FI ;
+ IF char = ""
+ THEN LEAVE read comment
+ FI
+ UNTIL is end comment PER ;
+ comment depth DECR 1 ;
+ next char ;
+ skip blanks .
+
+is end comment :
+ char = "}" OR char = ")" AND last char = "*" .
+
+is begin comment :
+ char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC read comment ;
+
+
+PROC scan (FILE VAR f) :
+
+ getline (f, line) ;
+ scan (line)
+
+ENDPROC scan ;
+
+PROC next symbol (FILE VAR f, TEXT VAR symbol) :
+
+ INT VAR type ;
+ next symbol (f, symbol, type)
+
+ENDPROC next symbol ;
+
+TEXT VAR scanned ;
+
+PROC next symbol (FILE VAR f, TEXT VAR symbol, INT VAR type) :
+
+ next symbol (symbol, type) ;
+ WHILE type >= 7 AND NOT eof (f) REP
+ getline (f, line) ;
+ continue scan (line) ;
+ next symbol (scanned, type) ;
+ symbol CAT scanned
+ PER .
+
+ENDPROC next symbol ;
+
+ENDPACKET scanner ;
+
diff --git a/system/base/1.7.5/src/screen b/system/base/1.7.5/src/screen
new file mode 100644
index 0000000..7e64961
--- /dev/null
+++ b/system/base/1.7.5/src/screen
@@ -0,0 +1,33 @@
+
+PACKET screen description DEFINES
+
+ xsize, ysize, marksize, mark refresh line mode :
+
+
+INT VAR xs := 80, ys := 24, ms := 1;
+
+INT PROC xsize: xs END PROC xsize;
+
+INT PROC ysize: ys END PROC ysize;
+
+INT PROC marksize: ms END PROC marksize;
+
+PROC xsize (INT CONST i): xs := i END PROC xsize;
+
+PROC ysize (INT CONST i): ys := i END PROC ysize;
+
+PROC marksize (INT CONST i): ms := i END PROC marksize;
+
+
+BOOL VAR line mode := FALSE;
+
+BOOL PROC mark refresh line mode:
+ line mode
+END PROC mark refresh line mode;
+
+PROC mark refresh line mode (BOOL CONST b):
+ line mode := b
+END PROC mark refresh line mode;
+
+END PACKET screen description ;
+
diff --git a/system/base/1.7.5/src/std transput b/system/base/1.7.5/src/std transput
new file mode 100644
index 0000000..94c51db
--- /dev/null
+++ b/system/base/1.7.5/src/std transput
@@ -0,0 +1,264 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET std transput DEFINES
+
+ sysout ,
+ sysin ,
+ put ,
+ putline ,
+ line ,
+ page ,
+ write ,
+ get ,
+ getline ,
+ get secret line :
+
+
+LET cr = ""13"" ,
+ cr lf = ""13""10"" ,
+ home clear = ""1""4"" ,
+ esc = ""27"" ,
+ rubout = ""12"" ,
+ bell = ""7"" ,
+ back blank back = ""8" "8"" ,
+ del line cr lf = ""5""13""10"" ;
+
+TEXT VAR number word , exit char ;
+
+BOOL VAR console output := TRUE, console input := TRUE ;
+
+FILE VAR outfile, infile ;
+TEXT VAR outfile name := "", infile name := "" ;
+
+
+PROC sysout (TEXT CONST file name) :
+
+ outfile name := file name ;
+ IF file name = ""
+ THEN console output := TRUE
+ ELSE outfile := sequential file (output, file name) ;
+ console output := FALSE
+ FI
+
+ENDPROC sysout ;
+
+TEXT PROC sysout :
+ outfile name
+ENDPROC sysout ;
+
+PROC sysin (TEXT CONST file name) :
+
+ infile name := file name ;
+ IF file name = ""
+ THEN console input := TRUE
+ ELSE infile := sequential file (input, file name) ;
+ console input := FALSE
+ FI
+
+ENDPROC sysin ;
+
+TEXT PROC sysin :
+ infile name
+ENDPROC sysin ;
+
+
+PROC put (TEXT CONST word) :
+
+ IF console output
+ THEN out (word) ; out (" ")
+ ELSE put (outfile, word)
+ FI
+
+ENDPROC put ;
+
+PROC put (INT CONST number) :
+
+ put (text (number))
+
+ENDPROC put ;
+
+PROC put (REAL CONST number) :
+
+ put (text (number))
+
+ENDPROC put ;
+
+PROC putline (TEXT CONST textline) :
+
+ IF console output
+ THEN out (textline) ; out (cr lf)
+ ELSE putline (outfile, textline)
+ FI
+
+ENDPROC putline ;
+
+PROC line :
+
+ IF console output
+ THEN out (cr lf)
+ ELSE line (outfile)
+ FI
+
+ENDPROC line ;
+
+PROC line (INT CONST times) :
+
+ INT VAR i ;
+ FOR i FROM 1 UPTO times REP
+ line
+ PER
+
+ENDPROC line ;
+
+PROC page :
+
+ IF console output
+ THEN out (home clear)
+ FI
+
+ENDPROC page ;
+
+PROC write (TEXT CONST word) :
+
+ IF console output
+ THEN out (word)
+ ELSE write (outfile, word)
+ FI
+
+ENDPROC write ;
+
+
+PROC get (TEXT VAR word) :
+
+ IF console input
+ THEN get from console
+ ELSE get (infile, word)
+ FI .
+
+get from console :
+ REP
+ word := "" ;
+ editget (word, " ", "", exit char) ;
+ echoe exit char
+ UNTIL word <> "" AND word <> " " PER ;
+ delete leading blanks .
+
+delete leading blanks :
+ WHILE (word SUB 1) = " " REP
+ word := subtext (word,2)
+ PER .
+
+ENDPROC get ;
+
+PROC get (TEXT VAR word, TEXT CONST separator) :
+
+ IF console input
+ THEN get from console
+ ELSE get (infile, word, separator)
+ FI .
+
+get from console :
+ word := "" ;
+ editget (word, separator, "", exit char) ;
+ echoe exit char .
+
+ENDPROC get ;
+
+PROC echoe exit char :
+
+ IF exit char = ""13""
+ THEN out (""13""10"")
+ ELSE out (exit char)
+ FI
+
+ENDPROC echoe exit char ;
+
+PROC get (INT VAR number) :
+
+ get (number word) ;
+ number := int (number word)
+
+ENDPROC get ;
+
+PROC get (REAL VAR number) :
+
+ get (number word) ;
+ number := real (number word)
+
+ENDPROC get ;
+
+PROC get (TEXT VAR word, INT CONST length) :
+
+ IF console input
+ THEN get from console
+ ELSE get (infile, word, length)
+ FI .
+
+get from console :
+ word := "" ;
+ editget (word, length, exit char) ;
+ echoe exit char .
+
+ENDPROC get ;
+
+PROC getline (TEXT VAR textline) :
+
+ IF console input
+ THEN get from console
+ ELSE getline (infile, textline)
+ FI .
+
+get from console :
+ textline := "" ;
+ editget (textline, "", "", exit char) ;
+ echoe exit char
+
+ENDPROC getline ;
+
+PROC get secret line (TEXT VAR textline) :
+
+ TEXT VAR char ;
+ textline := "" ;
+ get start cursor position ;
+ get line very secret ;
+ IF char = esc
+ THEN get line little secret
+ FI ;
+ cursor to start position ;
+ out (del line cr lf) .
+
+get line very secret :
+ REP
+ inchar (char) ;
+ IF char = esc OR char = cr
+ THEN LEAVE get line very secret
+ ELIF char = rubout
+ THEN delete last char
+ ELIF char >= " "
+ THEN textline CAT char ;
+ out (".")
+ ELSE out (bell)
+ FI
+ PER .
+
+delete last char :
+ IF LENGTH textline = 0
+ THEN out (bell)
+ ELSE out (back blank back) ;
+ delete char (textline, LENGTH textline)
+ FI .
+
+get line little secret :
+ cursor to start position ;
+ editget (textline, "", "", exit char) .
+
+get start cursor position :
+ INT VAR x, y;
+ get cursor (x, y) .
+
+cursor to start position :
+ cursor (x, y) .
+
+ENDPROC get secret line ;
+
+ENDPACKET std transput ;
+
diff --git a/system/base/1.7.5/src/tasten b/system/base/1.7.5/src/tasten
new file mode 100644
index 0000000..752303b
--- /dev/null
+++ b/system/base/1.7.5/src/tasten
@@ -0,0 +1,113 @@
+
+PACKET tasten verwaltung DEFINES (* #009 *)
+ (***************)
+
+ lernsequenz auf taste legen,
+ lernsequenz auf taste,
+ kommando auf taste legen,
+ kommando auf taste,
+ taste enthaelt kommando,
+ std tastenbelegung :
+
+
+
+LET kommandoidentifikation = ""0"" ,
+ esc = ""27"" ,
+ niltext = "" ,
+ hop right left up down cr tab rubin rubout mark esc
+ = ""1""2""8""3""10""13""9""11""12""16""27"" ;
+
+
+ROW 256 TEXT VAR belegung;
+INT VAR i; FOR i FROM 1 UPTO 256 REP belegung (i) := "" PER;
+
+std tastenbelegung;
+
+
+PROC lernsequenz auf taste legen (TEXT CONST taste, lernsequenz) :
+
+ belege (belegung (code (taste) + 1), taste, lernsequenz)
+
+ENDPROC lernsequenz auf taste legen ;
+
+PROC belege (TEXT VAR tastenpuffer, TEXT CONST taste, lernsequenz) :
+ tastenpuffer := lernsequenz ;
+ verhindere rekursives lernen .
+
+verhindere rekursives lernen :
+ loesche alle folgen esc taste aber nicht esc esc taste ;
+ IF taste ist freies sonderzeichen
+ THEN change all (tastenpuffer, taste, niltext)
+ FI .
+
+loesche alle folgen esc taste aber nicht esc esc taste :
+ INT VAR i := pos (tastenpuffer, esc + taste) ;
+ WHILE i > 0 REP
+ IF ist esc esc taste
+ THEN i INCR 1
+ ELSE change (tastenpuffer, i, i+1, niltext)
+ FI ;
+ i := pos (tastenpuffer, esc + taste, i)
+ PER .
+
+ist esc esc taste :
+ (tastenpuffer SUB i-1) = esc AND (tastenpuffer SUB i-2) <> esc .
+
+taste ist freies sonderzeichen :
+ taste < ""32"" AND
+ pos (hop right left up down cr tab rubin rubout mark esc, taste) = 0 .
+
+END PROC belege ;
+
+
+TEXT PROC lernsequenz auf taste (TEXT CONST taste) :
+ IF taste enthaelt kommando (taste)
+ THEN ""
+ ELSE belegung (code (taste) + 1)
+ FI
+END PROC lernsequenz auf taste;
+
+
+PROC kommando auf taste legen (TEXT CONST taste, kommando) :
+
+ belegung (code (taste) + 1) := kommandoidentifikation;
+ belegung (code (taste) + 1) CAT kommando
+
+END PROC kommando auf taste legen;
+
+
+TEXT PROC kommando auf taste (TEXT CONST taste) :
+ IF taste enthaelt kommando (taste)
+ THEN subtext (belegung (code (taste) + 1), 2)
+ ELSE ""
+ FI
+END PROC kommando auf taste;
+
+
+BOOL PROC taste enthaelt kommando (TEXT CONST taste) :
+ (belegung (code (taste) + 1) SUB 1) = kommandoidentifikation
+END PROC taste enthaelt kommando;
+
+
+PROC std tastenbelegung:
+ lernsequenz auf taste legen ("(", ""91"");
+ lernsequenz auf taste legen (")", ""93"");
+ lernsequenz auf taste legen ("<", ""123"");
+ lernsequenz auf taste legen (">", ""125"");
+ lernsequenz auf taste legen ("A", ""214"");
+ lernsequenz auf taste legen ("O", ""215"");
+ lernsequenz auf taste legen ("U", ""216"");
+ lernsequenz auf taste legen ("a", ""217"");
+ lernsequenz auf taste legen ("o", ""218"");
+ lernsequenz auf taste legen ("u", ""219"");
+ lernsequenz auf taste legen ("k", ""220"");
+ lernsequenz auf taste legen ("-", ""221"");
+ lernsequenz auf taste legen ("#", ""222"");
+ ler�sequenz auf taste legen (" ", ""223"");
+ lernsequenz auf taste legen ("B", ""251"");
+ lernsequenz auf taste legen ("s", ""251"");
+END PROC std tastenbelegung;
+
+
+END PACKET tasten verwaltung;
+
diff --git a/system/base/1.7.5/src/text b/system/base/1.7.5/src/text
new file mode 100644
index 0000000..4c659cf
--- /dev/null
+++ b/system/base/1.7.5/src/text
@@ -0,0 +1,391 @@
+(* ------------------- VERSION 3 06.03.86 ------------------- *)
+PACKET text DEFINES
+
+ max text length ,
+ SUB ,
+ subtext ,
+ text ,
+ length , LENGTH ,
+ CAT ,
+ + ,
+ * ,
+ replace ,
+ change ,
+ change all ,
+ compress ,
+ pos ,
+ code ,
+ ISUB ,
+ RSUB ,
+ delete char ,
+ insert char ,
+ delete int ,
+ insert int ,
+ heap size ,
+ collect heap garbage ,
+ stranalyze ,
+ LEXEQUAL ,
+ LEXGREATER ,
+ LEXGREATEREQUAL :
+
+
+
+TEXT VAR text buffer , tail buffer ;
+
+INT CONST max text length := 32000 ;
+
+TEXT OP SUB (TEXT CONST text, INT CONST pos ) :
+ EXTERNAL 48
+END OP SUB ;
+
+TEXT PROC subtext (TEXT CONST source, INT CONST from, to ):
+ EXTERNAL 49
+ENDPROC subtext ;
+
+TEXT PROC subtext (TEXT CONST source, INT CONST from ) :
+ EXTERNAL 50
+ENDPROC subtext ;
+
+INT PROC code (TEXT CONST text) :
+ EXTERNAL 46
+END PROC code ;
+
+TEXT PROC code (INT CONST code) :
+ EXTERNAL 47
+ENDPROC code ;
+
+INT OP ISUB (TEXT CONST text, INT CONST index) :
+ EXTERNAL 44
+ENDOP ISUB ;
+
+PROC replace (TEXT VAR text, INT CONST index, value) :
+ EXTERNAL 45
+ENDPROC replace ;
+
+REAL OP RSUB (TEXT CONST text, INT CONST index) :
+ EXTERNAL 100
+ENDOP RSUB ;
+
+PROC replace (TEXT VAR text, INT CONST index, REAL CONST code) :
+ EXTERNAL 101
+ENDPROC replace ;
+
+
+PROC replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) :
+ EXTERNAL 51
+ENDPROC replace ;
+
+TEXT PROC text (TEXT CONST source, INT CONST length ) :
+
+ IF length < LENGTH source
+ THEN text buffer := subtext (source,1,length)
+ ELSE text buffer := source ;
+ mit blanks auffuellen
+ FI ;
+ text buffer .
+
+mit blanks auffuellen :
+ INT VAR i ;
+ FOR i FROM 1 UPTO length - LENGTH source REP
+ text buffer CAT " "
+ PER .
+
+ENDPROC text ;
+
+TEXT PROC text (TEXT CONST source, INT CONST length, from) :
+ text ( subtext (source, from) , length )
+ENDPROC text ;
+
+OP CAT (TEXT VAR right, TEXT CONST left ) :
+ EXTERNAL 52
+ENDOP CAT ;
+
+TEXT OP + (TEXT CONST left, right) :
+ text buffer := left ;
+ text buffer CAT right ;
+ text buffer
+ENDOP + ;
+
+TEXT OP * (INT CONST times, TEXT CONST source ) :
+
+ text buffer := "" ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO times REP
+ text buffer CAT source
+ PER ;
+ text buffer
+
+ENDOP * ;
+
+INT PROC length (TEXT CONST text ) :
+ EXTERNAL 53
+ENDPROC length ;
+
+INT OP LENGTH (TEXT CONST text ) :
+ EXTERNAL 53
+ENDOP LENGTH ;
+
+INT PROC pos (TEXT CONST source, pattern) :
+ EXTERNAL 54
+ENDPROC pos ;
+
+INT PROC pos (TEXT CONST source, pattern, INT CONST from) :
+ EXTERNAL 55
+ENDPROC pos ;
+
+INT PROC pos (TEXT CONST source, pattern, INT CONST from, to) :
+ EXTERNAL 56
+ENDPROC pos ;
+
+INT PROC pos (TEXT CONST source, low, high, INT CONST from) :
+ EXTERNAL 58
+ENDPROC pos ;
+
+TEXT PROC compress (TEXT CONST text) :
+
+ INT VAR begin, end ;
+
+ search first non blank ;
+ search last non blank ;
+ text buffer := subtext (text, begin, end) ;
+ text buffer .
+
+search first non blank :
+ begin := 1 ;
+ WHILE (text SUB begin) = " " REP
+ begin INCR 1
+ PER .
+
+search last non blank :
+ end := LENGTH text ;
+ WHILE (text SUB end) = " " REP
+ end DECR 1
+ PER .
+
+ENDPROC compress ;
+
+PROC change (TEXT VAR destination, INT CONST from, to, TEXT CONST new) :
+
+ IF LENGTH new = to - from + 1 AND to <= LENGTH destination
+ THEN replace (destination, from, new)
+ ELSE change via buffer
+ FI .
+
+change via buffer :
+ text buffer := subtext (destination, 1, from-1) ;
+ text buffer CAT new ;
+ tail buffer := subtext (destination, to + 1) ;
+ text buffer CAT tail buffer ;
+ destination := text buffer
+
+ENDPROC change ;
+
+PROC change (TEXT VAR destination, TEXT CONST old, new) :
+
+ INT CONST position := pos (destination, old) ;
+ IF position > 0
+ THEN change (destination, position, position + LENGTH old -1, new)
+ FI
+
+ENDPROC change ;
+
+PROC change all (TEXT VAR destination, TEXT CONST old, new) :
+
+ INT VAR position := pos (destination, old) ;
+ IF LENGTH old = LENGTH new
+ THEN change by replace
+ ELSE change by change
+ FI .
+
+change by replace :
+ WHILE position > 0 REP
+ replace (destination, position, new) ;
+ position := pos (destination, old, position + LENGTH new)
+ PER .
+
+change by change :
+ WHILE position > 0 REP
+ change (destination, position, position + LENGTH old - 1 , new) ;
+ position := pos (destination, old, position + LENGTH new)
+ PER .
+
+ENDPROC change all ;
+
+PROC delete char (TEXT VAR string, INT CONST delete pos) :
+
+ IF delete pos > 0
+ THEN tail buffer := subtext (string, delete pos + 1) ;
+ string := subtext (string, 1, delete pos - 1) ;
+ string CAT tail buffer
+ FI
+
+END PROC delete char ;
+
+PROC insert char (TEXT VAR string, TEXT CONST char,
+ INT CONST insert pos) :
+
+ IF insert pos > 0 AND insert pos <= LENGTH string + 1
+ THEN tail buffer := subtext (string, insert pos) ;
+ string := subtext (string, 1, insert pos - 1) ;
+ string CAT char ;
+ string CAT tail buffer
+ FI
+
+END PROC insert char ;
+
+INT PROC heap size :
+ EXTERNAL 93
+ENDPROC heap size ;
+
+PROC collect heap garbage :
+ EXTERNAL 94
+ENDPROC collect heap garbage ;
+
+PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum,
+ TEXT CONST string, INT VAR index, INT CONST to,
+ INT VAR exit code) :
+ EXTERNAL 57
+ENDPROC stranalyze ;
+
+(*******************************************************************)
+(* lexikographische Vergleiche *)
+(* Nach DIN 5007, Abschnitt 1 und Abschnitt 3.2 (Bindestrich) *)
+(* Autor: Rainer Hahn, Jochen Liedtke *)
+(* Stand: 1.7.4 (Jan. 1985) *)
+(*******************************************************************)
+LET first umlaut = ""214"" ,
+ umlauts = ""214""215""216""217""218""219""251"" ;
+
+
+TEXT VAR left letter, right letter;
+
+BOOL OP LEXEQUAL (TEXT CONST left, right) :
+
+ compare (left, right) ;
+ left letter = right letter
+
+ENDOP LEXEQUAL ;
+
+BOOL OP LEXGREATER (TEXT CONST left, right) :
+
+ compare (left, right) ;
+ left letter > right letter
+
+ENDOP LEXGREATER ;
+
+BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) :
+
+ compare (left, right) ;
+ left letter >= right letter
+
+ENDOP LEXGREATEREQUAL ;
+
+PROC compare (TEXT CONST left, right) :
+
+ to begin of lex relevant text ;
+ REP
+ get left letter ;
+ get right letter
+ UNTIL NOT letter match OR both ended PER .
+
+to begin of lex relevant text :
+ INT VAR
+ left pos := pos (left, ""65"",""254"", 1) ,
+ right pos := pos (right,""65"",""254"", 1) ;
+ IF left pos = 0
+ THEN left pos := LENGTH left + 1
+ FI ;
+ IF right pos = 0
+ THEN right pos := LENGTH right + 1
+ FI .
+
+get left letter :
+ left letter := left SUB left pos ;
+ left pos INCR 1 .
+
+get right letter :
+ right letter := right SUB right pos ;
+ right pos INCR 1 .
+
+letter match :
+ IF left letter = right letter
+ THEN TRUE
+ ELSE dine (left, left letter, left pos) ;
+ dine (right, right letter, right pos) ;
+ IF exactly one letter is double letter
+ THEN expand other letter
+ FI ;
+ left letter = right letter
+ FI .
+
+exactly one letter is double letter :
+ LENGTH left letter <> LENGTH right letter.
+
+expand other letter :
+ IF LENGTH left letter = 1
+ THEN left letter CAT (left SUB left pos) ;
+ left pos INCR 1
+ ELSE right letter CAT (right SUB right pos) ;
+ right pos INCR 1
+ FI .
+
+both ended : left letter = "" .
+
+ENDPROC compare ;
+
+PROC dine (TEXT CONST string, TEXT VAR char, INT VAR string pos) :
+
+ skip non letter chars ;
+ IF is capital letter
+ THEN translate to small letter
+ ELIF char >= first umlaut
+ THEN translate umlaut
+ FI .
+
+skip non letter chars :
+ WHILE NOT (is letter OR end of string) REP
+ char := string SUB string pos ;
+ string pos INCR 1
+ PER .
+
+translate to small letter :
+ char := code (code (char) + 32) .
+
+translate umlaut :
+ SELECT pos (umlauts, char) OF
+ CASE 1,4 : char := "ae"
+ CASE 2,5 : char := "oe"
+ CASE 3,6 : char := "ue"
+ CASE 7 : char := "ss"
+ ENDSELECT .
+
+is capital letter :
+ INT VAR char code := code (char) ;
+ 65 <= char code AND char code <= 90 .
+
+is letter :
+ char code := code (char) OR 32 ;
+ (97 <= char code AND char code <= 122) OR char code >= 128 .
+
+end of string : char = "" .
+
+ENDPROC dine ;
+
+OP CAT (TEXT VAR result, INT CONST number) :
+ result CAT " ";
+ replace (result, LENGTH result DIV 2, number);
+END OP CAT;
+
+PROC insert int (TEXT VAR result, INT CONST insert pos, number) :
+ INT VAR pos := insert pos * 2 - 1;
+ change (result, pos, pos - 1, " ");
+ replace (result, insert pos, number);
+END PROC insert int;
+
+PROC delete int (TEXT VAR result, INT CONST delete pos) :
+ INT VAR pos := delete pos * 2;
+ change (result, pos - 1, pos, "")
+END PROC delete int;
+
+ENDPACKET text ;
+
diff --git a/system/base/1.7.5/src/texter errors b/system/base/1.7.5/src/texter errors
new file mode 100644
index 0000000..9c4383d
--- /dev/null
+++ b/system/base/1.7.5/src/texter errors
@@ -0,0 +1,284 @@
+(* ------------------- VERSION 66 vom 06.03.86 -------------------- *)
+PACKET texter errors and common DEFINES
+ only command line,
+ skip input,
+ char pos move,
+ begin of this char,
+ number chars,
+ display and pause,
+ report text processing error,
+ report text processing warning:
+
+(* Programm zur zentralen Haltung aller Fehlermeldungen der Textkosmetik
+ Autor: Rainer Hahn
+ Stand: 1.7.1 Febr. 1984
+ 1.7.3 Juli "
+ 1.7.4 Febr. 1985
+ *)
+
+LET escape = ""27"";
+
+TEXT VAR fehlerdummy;
+
+BOOL PROC only command line (TEXT CONST zeile):
+INT VAR anfang, ende;
+LET kommando zeichen = "#";
+ IF pos (zeile, kommando zeichen) = 1
+ THEN ende := pos (zeile, kommando zeichen, 2);
+ IF ende > 0
+ THEN zaehle kommandos durch;
+ LEAVE only command line WITH richtiges kommandoende
+ FI
+ FI;
+ FALSE.
+
+zaehle kommandos durch:
+ WHILE ende + 1 = pos (zeile, kommando zeichen, ende +1) REP
+ anfang := pos (zeile, kommando zeichen, ende + 1);
+ ende := pos (zeile, kommando zeichen, anfang + 1)
+ END REP.
+
+richtiges kommandoende:
+ ende > 0 AND
+ (ende = length (zeile) OR (ende = length (zeile) - 1 AND absatzzeile)).
+
+absatzzeile:
+ (zeile SUB length (zeile)) = " ".
+END PROC only command line;
+
+PROC skip input:
+ REP
+ TEXT CONST zeichen :: incharety;
+ IF zeichen = escape
+ THEN errorstop ("Abbruch durch ESC")
+ FI
+ UNTIL zeichen = "" END REP
+END PROC skip input;
+
+PROC char pos move (TEXT CONST ein text, INT VAR zpos, INT CONST richtung):
+ zpos INCR richtung;
+ IF within kanji (ein text, zpos)
+ THEN zpos INCR richtung
+ FI
+END PROC char pos move;
+
+PROC begin of this char (TEXT CONST ein text, INT VAR zpos):
+ IF zpos < 1 OR zpos > length (ein text)
+ THEN display and pause (7)
+ ELSE suche zeichenposition
+ FI.
+
+suche zeichenposition:
+ IF within kanji (ein text, zpos)
+ THEN zpos DECR 1
+ FI.
+END PROC begin of this char;
+
+INT PROC number chars (TEXT CONST ein text, INT CONST von pos, bis pos):
+ INT VAR index :: von pos, anz :: 0;
+ WHILE index <= bis pos REP
+ IF index > length (ein text) OR index > bis pos
+ THEN display and pause (5); LEAVE number chars WITH 0
+ FI;
+ IF is kanji esc (ein text SUB index)
+ THEN index INCR 2
+ ELSE index INCR 1
+ FI;
+ anz INCR 1
+ END REP;
+ anz
+END PROC number chars;
+
+PROC display and pause (INT CONST nr):
+ line ; put ("LINER ERROR"); put (nr); pause
+END PROC display and pause;
+
+PROC report text processing error (INT CONST error nr,
+ INT CONST line nr,
+ TEXT VAR message,
+ TEXT CONST addition):
+
+ einfache meldung aufbauen;
+ meldung in fehlerdatei ausgeben.
+
+einfache meldung aufbauen:
+ message := "FEHLER Zeile ";
+ message CAT text (line nr);
+ message CAT ": ";
+ message CAT simple message;
+ message CAT " ";
+ message CAT addition.
+
+meldung in fehlerdatei ausgeben:
+ note (message);
+ note line;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1: "Unbekannter Schriftyp ignoriert:"
+ CASE 2: "#-Zeichen fehlt"
+ CASE 3: "foot in Fußnote (ignoriert)"
+ CASE 4: "cm-Angabe fehlt (REAL) (ignoriert):"
+ CASE 5: "INT-Parameter erwartet (ignoriert):"
+ CASE 6: "(versuchte) Trennung in Macro-Text"
+ CASE 7: "ie-Anweisung fehlt bei Seitenende"
+ CASE 8: "Unbekannte Anweisung (ignoriert):"
+ CASE 9: "Nicht kompilierbares Programm:"
+ CASE 10: "Einrückung (Leerzeichen am Zeilenanfang) zu groß"
+ CASE 11: "Anweisung hier nicht erlaubt (ignoriert):"
+ CASE 12: "Tabellen-Position liegt innerhalb eines b pos:"
+ CASE 13: "free-Wert > Textteil der Seite (ignoriert)"
+ CASE 14: "Mehr als 1 Zeichen in pagenr (ignoriert)"
+ CASE 15: "Macro innerhalb eines Macros definiert (ignoriert):"
+ CASE 16: "Mehr als drei Seitenzeichen"
+ CASE 17: "Mehr als zehn Zeilen im Index"
+ CASE 18: "Index Parameter inkorrekt (ignoriert): "
+ CASE 19: "Hinter Anweisung darf nichts mehr stehen (ignoriert):"
+ CASE 20: "Doppelter Index ignoriert:"
+ CASE 21: "ib(..) fehlt:"
+ CASE 22: "Inkorrekte Anweisung:"
+ CASE 23: "2 Byte Zeichen ohne zweites Zeichen am Zeilenende"
+ CASE 24: "free-Wert größer Seitenlänge (ignoriert):"
+ CASE 25: "Seitenende in head, bottom oder foot-Bereich plaziert"
+ CASE 26: "Anzahl columns < 2 ignoriert"
+ CASE 27: "INT-Parameter <= 0 ignoriert:"
+ CASE 28: "Kein Textzeichen vor oder hinter b"
+ CASE 29: "Nochmaliges columns ohne columns end (ignoriert)"
+ CASE 30: "set count-Parameter inkorrekt (ignoriert):"
+ CASE 31: "end ohne vorangehendes head, bottom oder foot"
+ CASE 32: "Max. Anzahl von Tabellen-Positionen überschritten"
+ CASE 33: "Macro-Aufruf oder -Definition in einem Macro (ignoriert):"
+ CASE 34: "counter nicht initialisiert (ignoriert):"
+ CASE 35: "store counter Kennung bereits vorhanden (ignoriert):"
+ CASE 36: "Spaltenbreite > limit"
+ CASE 37: "Zentimeter-Angabe in limit = 0 (ignoriert)"
+ CASE 38: "Zentimeter-Angabe inkorrekt (ignoriert):"
+ CASE 39: "Zentimeter-Angabe > als eingestelltes limit (ignoriert):"
+ CASE 40: "Makro-Definition (ignoriert):"
+ CASE 41: "Nochmaliges table ohne table end (ignoriert)"
+ CASE 42: "pos bereits hier gesetzt (ignoriert):"
+ CASE 43: "Druckposition (pos) nicht vorhanden:"
+ CASE 44: "Text breiter als Spalte bei:"
+ CASE 45: "rpos überschreibt vorherige Spalte bei:"
+ CASE 46: "cpos überschreibt vorherige Spalte bei:"
+ CASE 47: "dpos überschreibt vorherige Spalte bei:"
+ CASE 48: "Geblockter Text breiter als Spalte bei:"
+ CASE 49: "table end fehlt"
+ CASE 50: "Zentrierzeichen für dpos fehlt bei:"
+ CASE 51: "e-Anweisung ohne vorangehendes d oder u"
+ CASE 52: "fehlendes e auf dieser Zeile"
+ CASE 53: "Wort mit Exponent oder Index zu lang"
+ CASE 54: "Modifikation bereits angeschaltet bei on:"
+ CASE 55: "Modifikation nicht angeschaltet bei off:"
+ CASE 56: "Index bereits angeschaltet bei ib:"
+ CASE 57: "Index nicht angeschaltet bei ie:"
+ CASE 58: "Inkorrekte direkte Drucker-Anweisung (TEXT-Denoter):"
+ CASE 59: "tableend ohne vorangehendes table"
+ CASE 60: "put counter fehlt für:"
+ CASE 61: "store counter fehlt für:"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 1: "type-Anweisung korrigieren"
+ CASE 2: "Bitte Einfügen"
+ CASE 3: "Geschachtelte Fußnoten sind nicht möglich"
+ CASE 4: "Beispiel: limit(16.0)"
+ CASE 5: "Beispiele: page(4), pagenr(""%"",4)"
+ CASE 6: "Trennung erscheint nicht im Ausdruck!"
+ CASE 7: "Index in Indexdatei ggf. vervollständigen"
+ CASE 10: "für Zeilenbreite (limit): Leerzeichen entfernen"
+ CASE 11: "(In head-, bottom- und foot-Bereichen)"
+ CASE 13: "Parameterwert verkleinern"
+ CASE 14: "Beispiel: pagenr(""$"",5)"
+ CASE 15: "Macros kontrollieren und ggf. neu laden"
+ CASE 16: "sind z.Z. nicht zugelassen"
+ CASE 17: "ie(..) vergessen?"
+ CASE 18: "1.Parameter gibt die Index-Nummer (1-10) an. Beispiel: ie(9)"
+ CASE 19: "Anweisung muß alleine oder am Zeilenende stehen"
+ CASE 24: "in einem head, bottom oder foot-Bereich"
+ CASE 25: "Vor oder hinter den Bereich plazieren"
+ CASE 26: "1.Parameter in columns korrigieren"
+ CASE 27: "Beispiel: page(20)"
+ CASE 29: "page und columnsend vorher einfügen"
+ CASE 30: "Beispiele: setcount(0); setcount(27)"
+ CASE 31: "end ggf. entfernen"
+ CASE 34: "Bitte set counter einfuegen"
+ CASE 37: "Muß positiv sein"
+ CASE 38: "Beispiel: limit(16.0)"
+ CASE 40: "pos-Anweisungen vor table plazieren"
+ CASE 41: "tableend vergessen?"
+ CASE 42: "Bitte pos-Anweisungen überprüfen"
+ CASE 43: "in clear pos-Anweisung"
+ CASE 48: "Ggf. lineform über die Spalte"
+ CASE 49: "Bitte vor Dateiende einfügen"
+ CASE 51, 52: "Bitte u und d-Anweisungen kontrollieren"
+ CASE 53: "e-Anweisung vergessen?"
+ CASE 54, 55, 56, 57: "Anweisung in angegebener Zeilennummer überprüfen"
+ CASE 60: "Bitte store counter Anweisungen überprüfen"
+ OTHERWISE "Bitte Korrigieren"
+ END SELECT.
+END PROC report text processing error;
+
+PROC report text processing warning (INT CONST error nr,
+ INT CONST line nr,
+ TEXT VAR message,
+ TEXT CONST addition):
+
+ einfache meldung aufbauen;
+ meldung in fehlerdatei ausgeben.
+
+einfache meldung aufbauen:
+ message := "WARNUNG Zeile ";
+ message CAT text (line nr);
+ message CAT ": ";
+ message CAT simple message;
+ message CAT " ";
+ message CAT addition.
+
+meldung in fehlerdatei ausgeben:
+ note (message);
+ note line;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1, 2: ""
+ CASE 3: "Nicht referenziert:"
+ CASE 4: "Ziel-Referenz fehlt:"
+ CASE 5: "Modifikation bei Dateiende nicht ausgeschaltet:"
+ CASE 6: "Index bei Dateiende nicht ausgeschaltet:"
+ CASE 7: "Nicht getrenntes Wort zu lang für Zeilenbreite:"
+ CASE 8: "Umschaltung auf gleichen Schrifttyp:"
+ CASE 9: "Kennzeichen schon vorhanden (Duplikat ignoriert):"
+ CASE 10: "Tabellenzeile breiter als limit"
+ CASE 11: "Mehr Spalten als Tabellen-Positionen bei:"
+ CASE 12: "Überschreibung nach"
+ CASE 13: "Leerzeichen vor:"
+ CASE 14: "Weniger Spalten als Tabellen-Positionen"
+ CASE 15: "counter mit dieser Kennung bereits initialisiert:"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 3: "topage oder value fehlt"
+ CASE 4: "goalpage oder value fehlt"
+ CASE 7: "Bitte nachträglich trennen!"
+ CASE 8: "Schrifttyp wurde darum nicht verändert!"
+ CASE 9: "count und goalpage überprüfen"
+ CASE 12: "Bitte fehlende Leerzeichen einfügen"
+ CASE 13: "erzeugt ggf. zusätzliche Leerzeile"
+ OTHERWISE "Bitte überprüfen"
+ END SELECT.
+END PROC report text processing warning;
+END PACKET texter errors and common;
+
diff --git a/system/base/1.7.5/src/thesaurus b/system/base/1.7.5/src/thesaurus
new file mode 100644
index 0000000..5ef7251
--- /dev/null
+++ b/system/base/1.7.5/src/thesaurus
@@ -0,0 +1,332 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET thesaurus handling (* Autor: J.Liedtke *)
+
+ DEFINES THESAURUS ,
+ := ,
+ empty thesaurus ,
+ insert, (* fuegt ein Element ein *)
+ delete, (* loescht ein Element falls vorhanden*)
+ rename, (* aendert ein Element falls vorhanden*)
+ CONTAINS , (* stellt fest, ob enthalten *)
+ link , (* index in thesaurus *)
+ name , (* name of entry *)
+ get , (* get next entry ("" is eof)*)
+ highest entry : (* highest valid index of thes*)
+
+
+TYPE THESAURUS = TEXT ;
+
+LET thesaurus size = 200 ,
+ nil = 0 ,
+ niltext = "" ,
+ max name length = 80 ,
+
+ begin entry char = ""0"" ,
+ end entry char = ""1"" ,
+
+ nil entry = ""0""1"" ,
+ nil name = "" ,
+
+ quote = """" ;
+
+TEXT VAR entry ;
+INT VAR cache index := 0 ,
+ cache pos ;
+
+
+PROC access (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ construct entry ;
+ IF NOT cache identifies entry
+ THEN search through thesaurus list
+ FI ;
+ IF entry found
+ THEN cache index := code (list SUB (cache pos - 1))
+ ELSE cache index := 0
+ FI .
+
+construct entry :
+ entry := begin entry char ;
+ entry CAT name ;
+ decode invalid chars (entry, 2) ;
+ entry CAT end entry char .
+
+search through thesaurus list :
+ cache pos := pos (list, entry) .
+
+cache identifies entry :
+ cache pos <> 0 AND
+ pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+PROC access (THESAURUS CONST thesaurus, INT CONST index) :
+
+ IF cache identifies index
+ THEN cache index := index ;
+ construct entry
+ ELSE cache pos := pos (list, code (index) + begin entry char) ;
+ IF entry found
+ THEN cache pos INCR 1 ;
+ cache index := index ;
+ construct entry
+ ELSE cache index := 0 ;
+ entry := niltext
+ FI
+ FI .
+
+construct entry :
+ entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) .
+
+cache identifies index :
+ subtext (list, cache pos-1, cache pos) = code (index) + begin entry char .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+
+
+THESAURUS PROC empty thesaurus :
+
+ THESAURUS : (""1"")
+
+ENDPROC empty thesaurus ;
+
+
+OP := (THESAURUS VAR dest, THESAURUS CONST source ) :
+
+ CONCR (dest) := CONCR (source) .
+
+ENDOP := ;
+
+TEXT VAR insert name ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ insert name := name ;
+ decode invalid chars (insert name, 1) ;
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN index := nil ; errorstop ("Name unzulaessig")
+ ELSE insert element
+ FI .
+
+insert element :
+ search free entry ;
+ IF entry found
+ THEN insert into directory
+ ELSE add entry to directory if possible
+ FI .
+
+search free entry :
+ access (thesaurus, nil name) .
+
+insert into directory :
+ change (list, cache pos + 1, cache pos, insert name) ;
+ index := cache index .
+
+add entry to directory if possible :
+ INT CONST next free index := code (list SUB LENGTH list) ;
+ IF next free index <= thesaurus size
+ THEN add entry to directory
+ ELSE directory overflow
+ FI .
+
+add entry to directory :
+ list CAT begin entry char ;
+ cache pos := LENGTH list ;
+ cache index := next free index ;
+ list CAT insert name ;
+ list CAT end entry char + code (next free index + 1) ;
+ index := cache index .
+
+directory overflow :
+ index := nil .
+
+entry found : cache index > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC insert ;
+
+PROC decode invalid chars (TEXT VAR name, INT CONST start pos) :
+
+ INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ;
+ WHILE invalid char pos > 0 REP
+ change (name, invalid char pos, invalid char pos, decoded char) ;
+ invalid char pos := pos (name, ""0"", ""31"", invalid char pos)
+ PER .
+
+decoded char : quote + text(code(name SUB invalid char pos)) + quote.
+
+ENDPROC decode invalid chars ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) :
+
+ INT VAR index ;
+ insert (thesaurus, name, index) ;
+ IF index = nil AND NOT is error
+ THEN errorstop ("THESAURUS-Ueberlauf")
+ FI .
+
+ENDPROC insert ;
+
+PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ access (thesaurus, name) ;
+ index := cache index ;
+ delete (thesaurus, index) .
+
+ENDPROC delete ;
+
+PROC delete (THESAURUS VAR thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ IF entry found
+ THEN delete entry
+ FI .
+
+delete entry :
+ IF is last entry of thesaurus
+ THEN cut off as much as possible
+ ELSE set to nil entry
+ FI .
+
+set to nil entry :
+ change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) .
+
+cut off as much as possible :
+ WHILE predecessor is also nil entry REP
+ set cache to this entry
+ PER ;
+ list := subtext (list, 1, cache pos - 1) ;
+ erase cache .
+
+predecessor is also nil entry :
+ subtext (list, cache pos - 3, cache pos - 2) = nil entry .
+
+set cache to this entry :
+ cache pos DECR 3 .
+
+erase cache :
+ cache pos := 0 ;
+ cache index := 0 .
+
+is last entry of thesaurus :
+ pos (list, end entry char, cache pos) = LENGTH list - 1 .
+
+list : CONCR (thesaurus) .
+
+entry found : cache index > nil .
+
+ENDPROC delete ;
+
+
+BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) :
+
+ IF name = niltext OR LENGTH name > max name length
+ THEN FALSE
+ ELSE access (thesaurus, name) ; entry found
+ FI .
+
+entry found : cache index > nil .
+
+ENDOP CONTAINS ;
+
+PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) :
+
+ rename (thesaurus, link (thesaurus, old), new)
+
+ENDPROC rename ;
+
+PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) :
+
+ insert name := new ;
+ decode invalid chars (insert name, 1) ;
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN errorstop ("Name unzulaessig")
+ ELSE change to new name
+ FI .
+
+change to new name :
+ access (thesaurus, index) ;
+ IF cache index <> 0 AND entry <> ""
+ THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name)
+ FI .
+
+list : CONCR (thesaurus) .
+
+ENDPROC rename ;
+
+INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ access (thesaurus, name) ;
+ cache index .
+
+ENDPROC link ;
+
+TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ subtext (entry, 2, LENGTH entry - 1) .
+
+ENDPROC name ;
+
+PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) :
+
+ identify index ;
+ REP
+ to next entry
+ UNTIL end of list COR valid entry found PER .
+
+identify index :
+ IF index = 0
+ THEN cache index := 0 ;
+ cache pos := 1
+ ELSE access (thesaurus, index)
+ FI .
+
+to next entry :
+ cache pos := pos (list, begin entry char, cache pos + 1) ;
+ IF cache pos > 0
+ THEN get entry
+ ELSE get nil entry
+ FI .
+
+get entry :
+ cache index INCR 1 ;
+ index := cache index ;
+ name := subtext (list, cache pos + 1, end entry pos - 1) .
+
+get nil entry :
+ cache index := 0 ;
+ cache pos := 0 ;
+ index := 0 ;
+ name := "" .
+
+end entry pos : pos (list, end entry char, cache pos) .
+
+end of list : index = 0 .
+
+valid entry found : name <> "" .
+
+list : CONCR (thesaurus) .
+
+ENDPROC get ;
+
+INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*)
+
+ code (list SUB LENGTH list) - 1 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC highest entry ;
+
+ENDPACKET thesaurus handling ;
+