polish: UString concat/LEN + IOChan position/seek

- UString: U"a" + U"b" concatenates descriptors (QbeGen.UStrCat ->
  shim m2ustrcat); a single-codepoint operand (UCHAR) becomes a
  1-codepoint UString via a rotating-pool m2ustrfrom. LEN/LENGTH/HIGH
  of a UString literal read the descriptor header (UStrLen/DecQ).
- IOChan: Position/Seek/Rewind over SysShim.ftell/fseek (shim
  m2ftell/m2fseek with clearerr on rewind).
- tests: t_ustrcat (63), IOChanSeekProg (15) -> 137/137.
- Fixpoint OK (2,156,095 bytes).

compiler/run_tests.sh

@@ -99,6 +99,7 @@ expect_run t_strcat.mod 63
 expect_run t_variant.mod 31
 expect_run t_ustrassign.mod 63
 expect_run t_ustrformal.mod 3
+expect_run t_ustrcat.mod 63
 expect_run t_proc.mod 0
 expect_run t_forward.mod 0
 expect_run t_call.mod 125
@@ -261,6 +262,9 @@ expect_run_files_in IOChanProg 0 "hello 42" "Z" ../runtime/syslib/SysShim.def ..
 rm -f gen_ssa/_iochan_tmp.txt
 expect_run_files IOChanFileProg 3 ../runtime/syslib/SysShim.def ../runtime/syslib/SysShim.mod ../stdlib/strings.def ../stdlib/strings.mod ../stdlib/iochan.def ../stdlib/iochan.mod iochanfile_prog.mod
 rm -f gen_ssa/_iochan_tmp.txt
+rm -f gen_ssa/_iochanseek.txt
+expect_run_files IOChanSeekProg 15 ../runtime/syslib/SysShim.def ../runtime/syslib/SysShim.mod ../stdlib/strings.def ../stdlib/strings.mod ../stdlib/iochan.def ../stdlib/iochan.mod iochanseek_prog.mod
+rm -f gen_ssa/_iochanseek.txt
 expect_run_files FilesProg 42 ../runtime/syslib/SysShim.def ../runtime/syslib/SysShim.mod ../stdlib/iochan.def ../stdlib/iochan.mod ../stdlib/files.def ../stdlib/files.mod files_prog.mod
 expect_run_files TBadFile 42 ../runtime/syslib/SysShim.def ../runtime/syslib/SysShim.mod ../stdlib/iochan.def ../stdlib/iochan.mod ../stdlib/files.def ../stdlib/files.mod t_badfile.mod
 rm -f gen_ssa/_files_tmp.txt

compiler/src/M2.atg

@@ -1816,7 +1816,7 @@ PRODUCTIONS
                                         (. VAR t2, res2, lt, rt:
                                                SymTab.TypeIndex;
                                              op: INTEGER;
-                                             q2, qt, wq, qf:
+                                             q2, qt, wq, qf, q2a, q2b:
                                                QbeGen.QVal;
                                              neg, isR, isL, folded:
                                                BOOLEAN;
@@ -1862,6 +1862,31 @@ PRODUCTIONS
                QbeGen.CopyOp(qr, q)
              ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q)
              END
+           ELSIF (op = SymTab.OpAdd)
+             AND (SymTab.UStrCompat(t, t2)
+               OR ((SymTab.ClassOf(t) = SymTab.ClUChar)
+                 AND (SymTab.ClassOf(t2) = SymTab.ClUStr))
+               OR ((SymTab.ClassOf(t) = SymTab.ClUStr)
+                 AND (SymTab.ClassOf(t2) = SymTab.ClUChar))
+               OR ((SymTab.ClassOf(t) = SymTab.ClUChar)
+                 AND (SymTab.ClassOf(t2) = SymTab.ClUChar))) THEN
+             (* UString concatenation: a UCHAR operand becomes a
+                1-codepoint UString; the result is a descriptor in the
+                shim's concat buffer.  Work on copies so neither
+                operand is clobbered. *)
+             IF SymTab.ClassOf(t) = SymTab.ClUStr THEN
+               QbeGen.CopyOp(q, q2a)
+             ELSE
+               QbeGen.UStrFrom(q, q2a)
+             END;
+             IF SymTab.ClassOf(t2) = SymTab.ClUStr THEN
+               QbeGen.UStrCat(q2a, q2, qt)
+             ELSE
+               QbeGen.UStrFrom(q2, q2b);
+               QbeGen.UStrCat(q2a, q2b, qt)
+             END;
+             t := SymTab.NewUStr();
+             QbeGen.CopyOp(qt, q)
            ELSIF (op = SymTab.OpAdd)
              AND (SymTab.StrCompat(t, t2)
                OR (SymTab.IsStrType(t)
@@ -2178,9 +2203,11 @@ PRODUCTIONS
                                            END; .)
     | ( "HIGH"                          (. isHigh := TRUE; .)
       | ( "LEN" | "LENGTH" )            (. isHigh := FALSE; .) )
-      "(" ( Design<dt, dk, qd, qn, sfx> (. isStr := FALSE; .)
+      "(" ( Design<dt, dk, qd, qn, sfx> (. isStr := FALSE;
+                                            isU := FALSE; .)
           | string                       (. LexString(s);
                                             isStr := TRUE;
+                                            isU := FALSE;
                                             IF SymTab.StrLen(s) = 3 THEN
                                               dt := SymTab.CharType();
                                               QbeGen.IntStr(QbeGen.CharVal(s),
@@ -2191,9 +2218,49 @@ PRODUCTIONS
                                               QbeGen.NoteAddr(qd, qd)
                                             END;
                                             dk := -1;
+                                            qn[0] := CHR(0); .)
+          | ustring                      (. LexString(s);
+                                            QbeGen.DeclUStr(s, qd, isU, ucp,
+                                              uok);
+                                            isStr := FALSE;
+                                            IF NOT uok THEN
+                                              SemError(234);
+                                              dt := SymTab.InvalidType
+                                            ELSIF isU THEN
+                                              (* one codepoint: a UCHAR;
+                                                 LEN is 1, HIGH is 0 *)
+                                              dt := SymTab.UCharType();
+                                              QbeGen.IntStr(ucp, qd)
+                                            ELSE
+                                              dt := SymTab.NewUStr();
+                                              QbeGen.NoteAddr(qd, qd)
+                                            END;
+                                            dk := -1;
                                             qn[0] := CHR(0); .) )
       ")"
-                                        (. IF isStr THEN
+                                        (. IF (dt # SymTab.InvalidType)
+  AND (SymTab.ClassOf(dt) = SymTab.ClUStr) THEN
+                                             (* UString: the count is
+                                                the descriptor header *)
+                                             IF isHigh THEN
+                                               QbeGen.UStrLen(qd, qr);
+                                               QbeGen.DecQ(qr)
+                                             ELSE
+                                               QbeGen.UStrLen(qd, qr)
+                                             END;
+                                             t := SymTab.IntType();
+                                             QbeGen.CopyOp(qr, q)
+                                           ELSIF (dt # SymTab.InvalidType)
+  AND (SymTab.ClassOf(dt) = SymTab.ClUChar) THEN
+                                             (* single UCHAR codepoint *)
+                                             IF isHigh THEN
+                                               QbeGen.CopyOp("0", qr)
+                                             ELSE
+                                               QbeGen.CopyOp("1", qr)
+                                             END;
+                                             t := SymTab.IntType();
+                                             QbeGen.CopyOp(qr, q)
+                                           ELSIF isStr THEN
                                              (* fold: content length at
                                                 compile time *)
                                              IF SymTab.StrLen(s) = 3 THEN

compiler/src/QbeGen.def

@@ -358,6 +358,18 @@ PROCEDURE StrAssign (dst, src: ARRAY OF CHAR);
 PROCEDURE UAssign (dst, src: ARRAY OF CHAR);
 (* Content copy of a U"..." descriptor into a UCHAR array. *)
 
+PROCEDURE UStrLen (s: ARRAY OF CHAR; VAR q: QVal);
+(* q := the UString codepoint count (INTEGER). *)
+
+PROCEDURE DecQ (VAR q: QVal);
+(* q := q - 1 (l domain). *)
+
+PROCEDURE UStrCat (a, b: ARRAY OF CHAR; VAR q: QVal);
+(* q := a + b in the shim's UString concat buffer. *)
+
+PROCEDURE UStrFrom (cp: ARRAY OF CHAR; VAR q: QVal);
+(* q := a 1-codepoint UString descriptor for the UCHAR value cp. *)
+
 PROCEDURE StrCat (a, b: ARRAY OF CHAR; VAR q: QVal);
 (* q := a + b in the shim's concat buffer (a descriptor address). *)
 

compiler/src/QbeGen.mod

@@ -1623,6 +1623,38 @@ PROCEDURE UAssign (dst, src: ARRAY OF CHAR);
     W("  call $m2uassign(l "); W(dst); W(", l "); W(src); WL(")")
   END UAssign;
 
+PROCEDURE UStrLen (s: ARRAY OF CHAR; VAR q: QVal);
+(* q := the UString codepoint count (INTEGER). *)
+  VAR t: QVal;
+  BEGIN
+    NewTemp(t);
+    W("  "); W(t); W(" =w call $m2ustrlen(l "); W(s); WL(")");
+    Cpy(q, t)
+  END UStrLen;
+
+PROCEDURE DecQ (VAR q: QVal);
+(* q := q - 1 (w domain; q is an INTEGER count). *)
+  VAR t: QVal;
+  BEGIN
+    NewTemp(t);
+    Op3("sub", t, q, "1", FALSE);
+    Cpy(q, t)
+  END DecQ;
+
+PROCEDURE UStrCat (a, b: ARRAY OF CHAR; VAR q: QVal);
+(* q := a + b (a UString descriptor in the shim's concat buffer). *)
+  BEGIN
+    NewTemp(q);
+    W("  "); W(q); W(" =l call $m2ustrcat(l "); W(a); W(", l "); W(b); WL(")")
+  END UStrCat;
+
+PROCEDURE UStrFrom (cp: ARRAY OF CHAR; VAR q: QVal);
+(* q := a 1-codepoint UString descriptor for the UCHAR value cp. *)
+  BEGIN
+    NewTemp(q);
+    W("  "); W(q); W(" =l call $m2ustrfrom(l "); W(cp); WL(")")
+  END UStrFrom;
+
 PROCEDURE StrCat (a, b: ARRAY OF CHAR; VAR q: QVal);
 (* q := a + b (a descriptor in the shim's concat buffer). *)
   BEGIN

compiler/src/SymTab.def

@@ -489,6 +489,9 @@ PROCEDURE RelCheck (l, r: TypeIndex; op: INTEGER): BOOLEAN;
 PROCEDURE IsStrType (t: TypeIndex): BOOLEAN;
 (* A string literal (ClStr) or a 1-D ARRAY OF CHAR. *)
 
+PROCEDURE UStrCompat (l, r: TypeIndex): BOOLEAN;
+(* Both operands are UString literals (U"..."): `+` concatenates. *)
+
 PROCEDURE IsUCharArray (t: TypeIndex): BOOLEAN;
 (* A 1-D ARRAY OF UCHAR (a U"..." content-copy destination). *)
 

compiler/src/SymTab.mod

@@ -2193,6 +2193,13 @@ PROCEDURE IsStrType (t: TypeIndex): BOOLEAN;
     RETURN FALSE
   END IsStrType;
 
+PROCEDURE UStrCompat (l, r: TypeIndex): BOOLEAN;
+(* Both operands are UString literals (ClUStr): `+` concatenates. *)
+  BEGIN
+    RETURN (l # InvalidType) AND (r # InvalidType)
+      AND (ClassOf(l) = ClUStr) AND (ClassOf(r) = ClUStr)
+  END UStrCompat;
+
 PROCEDURE IsUCharArray (t: TypeIndex): BOOLEAN;
 (* A 1-D ARRAY OF UCHAR: a destination for U"..." content copy. *)
   VAR c: TypeIndex;

compiler/tests/iochanseek_prog.mod

@@ -0,0 +1,34 @@
+MODULE IOChanSeekProg;
+(* IOChan positioning: Position / Seek / Rewind on a file channel.
+   Write 6 bytes, reopen, seek and read back.  Exit 15. *)
+IMPORT IOChan, Strings;
+VAR ExitCode : INTEGER;
+VAR f : IOChan.ChanId;
+VAR name, line : ARRAY [0 .. 63] OF CHAR;
+BEGIN
+  Strings.Assign("gen_ssa/_iochanseek.txt", name);
+
+  f := IOChan.OpenWrite(name);
+  IOChan.WriteString(f, "abc");
+  IOChan.WriteString(f, "def");
+  IF IOChan.Position(f) = 6 THEN
+    ExitCode := ExitCode + 1
+  ELSE ExitCode := 100 END;
+  IOChan.Close(f);
+
+  f := IOChan.OpenRead(name);
+  IF IOChan.ReadChar(f) = "a" THEN ExitCode := ExitCode + 0 END;
+  IF IOChan.ReadChar(f) = "b" THEN ExitCode := ExitCode + 0 END;
+  IF IOChan.Position(f) = 2 THEN
+    ExitCode := ExitCode + 2
+  ELSE ExitCode := 101 END;
+  IF IOChan.Rewind(f) THEN
+    IF IOChan.ReadChar(f) = "a" THEN ExitCode := ExitCode + 0 END;
+    IF IOChan.Position(f) = 1 THEN ExitCode := ExitCode + 4 END;
+    IF IOChan.Seek(f, 3) THEN
+      IOChan.ReadString(f, line);
+      IF line = "def" THEN ExitCode := ExitCode + 8 ELSE ExitCode := 102 END
+    END
+  END;
+  IOChan.Close(f)
+END IOChanSeekProg.

compiler/tests/t_ustrcat.mod

@@ -0,0 +1,17 @@
+MODULE TUStrCat;
+(* UString concatenation (`+`, including single-codepoint operands)
+   and LEN/LENGTH/HIGH of a UString literal. Exit 63. *)
+VAR ExitCode : INTEGER;
+VAR a : ARRAY [0 .. 31] OF UCHAR;
+BEGIN
+  IF LEN(U"hello") = 5 THEN ExitCode := ExitCode + 1 ELSE ExitCode := 100 END;
+  IF LENGTH(U"abc") = 3 THEN ExitCode := ExitCode + 2 ELSE ExitCode := 101 END;
+  IF HIGH(U"hello") = 4 THEN ExitCode := ExitCode + 4 ELSE ExitCode := 102 END;
+
+  a := U"ab" + U"cd";
+  IF a[0] = U'a' THEN ExitCode := ExitCode + 8 ELSE ExitCode := 103 END;
+  IF a[3] = U'd' THEN ExitCode := ExitCode + 16 ELSE ExitCode := 104 END;
+
+  a := U"x" + U"é";                 (* single-codepoint operands *)
+  IF a[1] = U'é' THEN ExitCode := ExitCode + 32 ELSE ExitCode := 105 END
+END TUStrCat.

runtime/syslib/SysShim.def

@@ -30,6 +30,11 @@ PROCEDURE stdin () : ADDRESS;
 PROCEDURE stdout () : ADDRESS;
 PROCEDURE stderr () : ADDRESS;
 
+PROCEDURE ftell (h : ADDRESS) : INTEGER;
+(* Byte offset of the current position (-1 on error). *)
+PROCEDURE fseek (h : ADDRESS; pos : INTEGER) : BOOLEAN;
+(* Seek to absolute byte offset pos; FALSE on failure. *)
+
 PROCEDURE fgetc (h : ADDRESS) : CHAR;
 (* Reads one byte from h; 0C at end of file. *)
 PROCEDURE freadint (h : ADDRESS) : INTEGER;

runtime/syslib/SysShim.mod

@@ -29,6 +29,10 @@ PROCEDURE m2stderr () : ADDRESS;
   EXTERNAL;
 PROCEDURE m2stdin () : ADDRESS;
   EXTERNAL;
+PROCEDURE m2ftell (h : ADDRESS) : INTEGER;
+  EXTERNAL;
+PROCEDURE m2fseek (h : ADDRESS; pos : INTEGER) : BOOLEAN;
+  EXTERNAL;
 PROCEDURE m2fgetc (h : ADDRESS) : CHAR;
   EXTERNAL;
 PROCEDURE m2freadint (h : ADDRESS) : INTEGER;
@@ -103,6 +107,16 @@ BEGIN
   RETURN m2stdin()
 END stdin;
 
+PROCEDURE ftell (h : ADDRESS) : INTEGER;
+BEGIN
+  RETURN m2ftell(h)
+END ftell;
+
+PROCEDURE fseek (h : ADDRESS; pos : INTEGER) : BOOLEAN;
+BEGIN
+  RETURN m2fseek(h, pos)
+END fseek;
+
 PROCEDURE fgetc (h : ADDRESS) : CHAR;
 BEGIN
   RETURN m2fgetc(h)

runtime/syslib/shim.c

@@ -201,6 +201,23 @@ long m2fwriteintw(long h, long v, long wid)
     return 0;
 }
 
+/* Byte offset of the current position in h (-1 on error). */
+long m2ftell(long h)
+{
+    if (h == 0) return -1;
+    return (long)ftell((FILE *)h);
+}
+
+/* Seek h to absolute byte offset pos; 1 on success, 0 on failure.
+   Rewinding also clears the stdio error/EOF state. */
+long m2fseek(long h, long pos)
+{
+    if (h == 0) return 0;
+    if (fseek((FILE *)h, (long)pos, SEEK_SET) != 0) return 0;
+    clearerr((FILE *)h);
+    return 1;
+}
+
 /* Standard streams as file handles. */
 long m2stdout(void) { return (long)stdout; }
 long m2stderr(void) { return (long)stderr; }
@@ -310,6 +327,45 @@ long m2strlen(long *s)
     return (long)strlen((char *)(s + 1));
 }
 
+/* UString length: the codepoint count is the descriptor's header. */
+long m2ustrlen(long *s)
+{
+    return s[0];
+}
+
+/* Build a 1-codepoint UString descriptor from a UCHAR value; returns
+   its address.  A small rotating pool lets an expression supply both
+   operands to m2ustrcat before it reads them. */
+long m2ustrfrom(long cp)
+{
+    static struct { long count; int cp; } pool[16];
+    static int next = 0;
+    long *d = (long *)&pool[next];
+    pool[next].count = 1;
+    pool[next].cp = (int)cp;
+    next = (next + 1) & 15;
+    return (long)d;
+}
+
+/* Concatenate two UString descriptors into a static buffer; returns
+   the result descriptor address.  The value is valid until the next
+   m2ustrcat call. */
+long m2ustrcat(long *a, long *b)
+{
+    static struct { long count; int cp[4096]; } buf;
+    int *pa = (int *)(a + 1);
+    int *pb = (int *)(b + 1);
+    long na = a[0], nb = b[0], i;
+    if (na < 0) na = 0;
+    if (nb < 0) nb = 0;
+    if (na > 4096) na = 4096;
+    if (nb > 4096 - na) nb = 4096 - na;
+    for (i = 0; i < na; i++) buf.cp[i] = pa[i];
+    for (i = 0; i < nb; i++) buf.cp[na + i] = pb[i];
+    buf.count = na + nb;
+    return (long)&buf;
+}
+
 /* Copy a UString descriptor (count + 4-byte codepoints) into the
    UCHAR array at dst (capacity dst[0]): min(count, capacity)
    codepoints, followed by a 0 codepoint terminator.  Returns the

stdlib/iochan.def

@@ -36,4 +36,12 @@ PROCEDURE WriteString(cid : ChanId; VAR s : ARRAY OF CHAR);
 PROCEDURE WriteInt(cid : ChanId; n : INTEGER);
 PROCEDURE WriteLn(cid : ChanId);
 
+(* --- positioning (seekable channels) --- *)
+PROCEDURE Position(cid : ChanId) : INTEGER;
+(* Current byte offset (-1 when unknown/closed). *)
+PROCEDURE Seek(cid : ChanId; pos : INTEGER) : BOOLEAN;
+(* Absolute seek; FALSE on failure. *)
+PROCEDURE Rewind(cid : ChanId) : BOOLEAN;
+(* Seek to offset 0. *)
+
 END IOChan.

stdlib/iochan.mod

@@ -89,4 +89,19 @@ BEGIN
   SysShim.fwriteln(cid)
 END WriteLn;
 
+PROCEDURE Position(cid : ChanId) : INTEGER;
+BEGIN
+  RETURN SysShim.ftell(cid)
+END Position;
+
+PROCEDURE Seek(cid : ChanId; pos : INTEGER) : BOOLEAN;
+BEGIN
+  RETURN SysShim.fseek(cid, pos)
+END Seek;
+
+PROCEDURE Rewind(cid : ChanId) : BOOLEAN;
+BEGIN
+  RETURN SysShim.fseek(cid, 0)
+END Rewind;
+
 END IOChan.