1 files changed, 391 insertions, 0 deletions
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 ;
+