ffi: support explicit external link names

compiler/run_tests.sh

@@ -169,6 +169,7 @@ expect_run t_chain.mod 42
 expect_run t_goto.mod 42
 expect_fail t_gotobad.mod "undeclared identifier"
 expect_run t_under.mod 42
+expect_run t_extern_alias.mod 42
 expect_run t_with.mod 114
 expect_run t_set.mod 131
 expect_run t_setchar.mod 77
@@ -345,6 +346,7 @@ expect_run_files CForeignProg 42 c_foreign.def c_foreign.mod c_foreign_prog.mod
 expect_run_files TCStringProg 42 t_cstring.def t_cstring_prog.mod
 expect_run_files TCStringQualProg 42 t_cstring.def t_cstring_qual_prog.mod
 expect_run_files CStrProg 42 ../runtime/syslib/CStr.def ../runtime/syslib/CStr.mod tests/cstr_test.def tests/cstr_prog.mod
+expect_run_files LinkNameProg 42 linkname.def linkname_prog.mod
 expect_run_files EEnumProg 42 e_enum.def e_enum_re.def e_enum_prog.mod
 expect_run_files TClassDefProg 8 t_classdef.def t_classdef_prog.mod
 expect_run_files DQualProg 46 d_basic.def d_basic.mod d_qual_prog.mod

compiler/src/Lower.mod

@@ -1281,6 +1281,7 @@ PROCEDURE AppendArgL (val: ARRAY OF CHAR; ft: SymTab.TypeIndex;
 PROCEDURE LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
                      VAR q: QbeGen.QVal; want: BOOLEAN);
   VAR nm, pn, cqn, cm: SymTab.Name;
+      ln: SymTab.LinkName;
       i, ai: CARDINAL; at, ft, res: SymTab.TypeIndex;
       qa, qt, qe, mg, qres, qb, qn: QbeGen.QVal;
       conv, isV, qual, ind, isC, va, cabi: BOOLEAN;
@@ -1313,7 +1314,7 @@ PROCEDURE LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
          the exact proc entry by the alias's uid. *)
       pi := FindProcByUid(qualUid);
       IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN
-        IF ext THEN QbeGen.CopyOp(nm, mg) ELSE QbeGen.Mangled(nm, uid, mg) END;
+        QbeGen.Mangled(nm, uid, mg);
         QbeGen.CallBegin(mg, res, depth, ext)
       ELSE
         res := SymTab.InvalidType;
@@ -1332,14 +1333,9 @@ PROCEDURE LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
         QbeGen.CallBeginInd(qa, res, FALSE)
       ELSIF ProcInfo(nm, uid, res, depth, ext, np) THEN
         pi := FindProc(nm);
-        IF ext THEN
-          (* External callee: bind to its C link name (the procedure's
-             own name); SymTab.ProcLink cannot be consulted after
-             EndUnit. *)
-          QbeGen.CopyOp(nm, mg)
-        ELSE
-          QbeGen.Mangled(nm, uid, mg)
-        END;
+        (* Mangled resolves an explicit external link name by uid, then
+           falls back to the module-qualified internal symbol. *)
+        QbeGen.Mangled(nm, uid, mg);
         QbeGen.CallBegin(mg, res, depth, ext)
       ELSE
         (* not in Lower's table: a predef C proc (SYSTEM.TRANSFER,
@@ -1348,8 +1344,8 @@ PROCEDURE LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
           isC := TRUE;
           res := SymTab.ProcRes(nm);
           np := SymTab.ProcNPar(nm);
-          IF SymTab.ProcLink(nm, pn) THEN
-            QbeGen.CallBegin(pn, res, 0, TRUE)
+          IF SymTab.ProcLink(nm, ln) THEN
+            QbeGen.CallBegin(ln, res, 0, TRUE)
           ELSE
             QbeGen.CallBegin(nm, res, 0, FALSE)
           END
@@ -1607,7 +1603,7 @@ PROCEDURE LowerProcAddr (nm: ARRAY OF CHAR; VAR q: QbeGen.QVal);
       END
     END;
     IF ok THEN
-      IF ext THEN QbeGen.CopyOp(nm, mg) ELSE QbeGen.Mangled(nm, uid, mg) END;
+      QbeGen.Mangled(nm, uid, mg);
       QbeGen.ProcAddr(mg, q)
     ELSE QbeGen.CopyOp("0", q)
     END

compiler/src/M2.atg

@@ -207,6 +207,20 @@ PROCEDURE CopyNm (src: ARRAY OF CHAR; VAR dst: SymTab.Name);
     IF i <= HIGH(dst) THEN dst[i] := CHR(0) END
   END CopyNm;
 
+PROCEDURE CLink (tok: ARRAY OF CHAR; VAR link: SymTab.LinkName);
+(* Strip the quotes from a string token and copy it as a C link name. *)
+  VAR n, i, j: CARDINAL;
+  BEGIN
+    n := SymTab.StrLen(tok);
+    link[0] := CHR(0);
+    IF n < 2 THEN RETURN END;
+    i := 1; j := 0;
+    WHILE (i < n - 1) AND (j < HIGH(link)) DO
+      link[j] := tok[i]; INC(i); INC(j)
+    END;
+    IF j <= HIGH(link) THEN link[j] := CHR(0) END
+  END CLink;
+
 PROCEDURE WrapExcept (body, handler: AST.Node): AST.Node;
 (* M1: a body with an EXCEPT part is represented as one node so Lower
    can add handler codegen in one place later.  The handler is retained
@@ -862,6 +876,8 @@ PRODUCTIONS
      table; imports materialize exported names. *)
   DefUnit                               (. VAR m1, m2, pn: SymTab.Name;
                                              g: SymTab.Name;
+                                             ln, raw: SymTab.LinkName;
+                                             procIsExt: BOOLEAN;
                                              astSeq, astTail, astProc: AST.Node; .)
     =                                   (. refN := 0; refSeen := FALSE; .)
       "DEFINITION" "MODULE"
@@ -892,13 +908,18 @@ PRODUCTIONS
         GetIdent<pn> { "," GetIdent<pn> } ";" ]
                                         (. astSeq := AST.NoNode;
                                            astTail := AST.NoNode; .)
-      { ConstBlock                      (. AstAppend(AST.NkDeclSeq,
+      {                                 (. ln[0] := CHR(0);
+                                           procIsExt := FALSE; .)
+        ( ConstBlock                    (. AstAppend(AST.NkDeclSeq,
                                              astSeq, astTail, astDecl); .)
       | TypeBlock<TRUE>                 (. AstAppend(AST.NkDeclSeq,
                                              astSeq, astTail, astDecl); .)
       | VarBlock                        (. AstAppend(AST.NkDeclSeq,
                                              astSeq, astTail, astDecl); .)
       | ProcHeading<pn, SymTab.InvalidType> ";"
+        [ "EXTERNAL"                    (. procIsExt := TRUE; .)
+          [ string                      (. LexString(raw);
+                                             CLink(raw, ln); .) ] ";" ]
                                         (. (* a heading only: record it so
                                               Lower can replay it *)
                                            astProc := AST.MakeNode(AST.NkProcDecl);
@@ -908,13 +929,14 @@ PRODUCTIONS
                                            AstAppend(AST.NkDeclSeq,
                                              astSeq, astTail, astProc);
                                            Lower.NoteProcNode(astProc);
-                                           IF foreignUnit THEN
+                                           IF foreignUnit OR procIsExt THEN
                                              Lower.MarkProcExternal;
-                                             SymTab.MarkExternal("")
+                                             SymTab.MarkExternal(ln)
                                            END;
                                            Lower.ScopeLeave;
                                            SymTab.CloseProc;
-                                           QbeGen.AbortFunc; .) }
+                                           QbeGen.AbortFunc; .) )
+      }
                                         (. astUnit := AST.MakeNode(AST.NkUnit);
                                            AST.SetChild(astUnit, 0,
                                              AST.MakeLeaf(AST.NkIdent, m1));
@@ -2316,6 +2338,7 @@ PRODUCTIONS
      static link gives them their parent's frame. Methods keep
      parse-now/230-later. *)
   ProcDecl                              (. VAR pn: SymTab.Name;
+                                             ln, raw: SymTab.LinkName;
                                              saveFun: SymTab.Name;
                                              astNode: AST.Node; .)
     = ProcHeading<pn, SymTab.InvalidType> ";"
@@ -2330,11 +2353,13 @@ PRODUCTIONS
                                            SymTab.MarkFwd;
                                            SymTab.CloseProc;
                                            QbeGen.AbortFunc; .)
-      | "EXTERNAL"                      (. AST.SetOp(astNode, 2);
+      | "EXTERNAL"                      (. ln[0] := CHR(0); .)
+        [ string                        (. LexString(raw); CLink(raw, ln); .) ]
+                                        (. AST.SetOp(astNode, 2);
                                            astDecl := astNode;
                                            Lower.MarkProcExternal;
                                            Lower.ScopeLeave;
-                                           SymTab.MarkExternal("");
+                                           SymTab.MarkExternal(ln);
                                            SymTab.CloseProc;
                                            QbeGen.AbortFunc; .)
       |                                 

compiler/src/QbeGen.def

@@ -12,7 +12,7 @@ DEFINITION MODULE QbeGen;
    $main return its value as the process exit code, else return 0. *)
 
 TYPE
-  QVal = ARRAY [0 .. 63] OF CHAR;
+  QVal = ARRAY [0 .. 255] OF CHAR;
 
 PROCEDURE OpenModule (name: ARRAY OF CHAR);
 (* Opens gen_ssa/<name>.ssa, resets counters. *)

compiler/src/QbeGen.mod

@@ -1098,9 +1098,14 @@ PROCEDURE Mangled (pname: ARRAY OF CHAR; uid: CARDINAL; VAR q: QVal);
    so objects compiled in separate sessions agree.  Nested procedures
    are local to their module object; they keep a deterministic uid
    suffix, prefixed by the module to avoid cross-object collisions. *)
-  VAR link, base, mod : SymTab.Name;
+  VAR link : SymTab.LinkName;
+      base, mod, tmod, tname : SymTab.Name;
       depth : CARDINAL; classIdx : INTEGER; num : QVal;
   BEGIN
+    IF SymTab.ProcLinkByUidName(uid, pname, link) THEN
+      Cpy(q, link);
+      RETURN
+    END;
     IF SymTab.ProcLink(pname, link) THEN
       Cpy(q, link);
       RETURN
@@ -1121,8 +1126,8 @@ PROCEDURE Mangled (pname: ARRAY OF CHAR; uid: CARDINAL; VAR q: QVal);
       App(q, base);
       classIdx := SymTab.ProcClassByUid(uid);
       IF classIdx # SymTab.InvalidType THEN
-        IF SymTab.TypeStableName(classIdx, link, base) THEN
-          App(q, "_"); App(q, link); App(q, "__"); App(q, base)
+        IF SymTab.TypeStableName(classIdx, tmod, tname) THEN
+          App(q, "_"); App(q, tmod); App(q, "__"); App(q, tname)
         ELSE
           App(q, "_c");
           IntStr(classIdx, num);

compiler/src/SymTab.def

@@ -62,6 +62,7 @@ CONST
 
 TYPE
   Name = ARRAY [0 .. 63] OF CHAR;
+  LinkName = ARRAY [0 .. 255] OF CHAR;  (* external C symbol *)
   TypeIndex = INTEGER;
   BoundsArr = ARRAY [0 .. 7] OF INTEGER;
 (* Per-dimension bounds for array index lists (grammar locals). *)
@@ -187,7 +188,15 @@ PROCEDURE DeclareCProc (name: ARRAY OF CHAR): BOOLEAN;
    result): FROM libc IMPORT. *)
 PROCEDURE Varargs (name: ARRAY OF CHAR): BOOLEAN;
 (* TRUE when the named procedure is a C-varargs intrinsic. *)
-PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: Name): BOOLEAN;
+PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: LinkName): BOOLEAN;
+
+PROCEDURE ProcLinkByUid (uid: CARDINAL; VAR link: LinkName): BOOLEAN;
+(* External link name by procedure uid; useful for qualified aliases. *)
+
+PROCEDURE ProcLinkByUidName (uid: CARDINAL; name: ARRAY OF CHAR;
+                             VAR link: LinkName): BOOLEAN;
+(* As ProcLinkByUid, but only when uid's base name matches name.  This
+   disambiguates uid 0 and aliases from unrelated predef procedures. *)
 (* External-procedure query/link lookup (link name of the named
    visible procedure). *)
 

compiler/src/SymTab.mod

@@ -52,7 +52,7 @@ TYPE
     vslot : INTEGER;    (* KindProc VIRTUAL: vtable slot (-1 = none) *)
     hasBody : BOOLEAN;  (* KindProc: a body was resumed/emitted *)
     ext   : BOOLEAN;    (* KindProc: EXTERNAL (no body emitted) *)
-    link  : Name;       (* KindProc: external link (C) name *)
+    link  : LinkName;   (* KindProc: external link (C) name *)
     varargs : BOOLEAN;  (* KindProc: C varargs (FROM libc IMPORT) *)
     sym   : Name;       (* base symbol name (differs from name for
                            qualified aliases) *)
@@ -109,6 +109,7 @@ VAR
   uidMod  : ARRAY [0 .. 1023] OF Name;  (* uid -> defining module *)
   uidDepth : ARRAY [0 .. 1023] OF CARDINAL; (* uid -> lexical depth *)
   uidClass : ARRAY [0 .. 1023] OF TypeIndex; (* uid -> class method owner *)
+  uidLink : ARRAY [0 .. 1023] OF LinkName;  (* uid -> external C link *)
   nDefer : CARDINAL;
   deferProc : ARRAY [0 .. MaxDefer - 1] OF SymPtr;
   deferScope : ARRAY [0 .. MaxDefer - 1] OF ScopePtr;
@@ -2605,6 +2606,9 @@ PROCEDURE DeclareCProc (name: ARRAY OF CHAR): BOOLEAN;
       uidDepth[node^.uid] := nProc;
       uidClass[node^.uid] := InvalidType
     END;
+    IF node^.uid <= HIGH(uidLink) THEN
+      Assign(uidLink[node^.uid], name)
+    END;
     node^.fdep := nProc;
     node^.vslot := -1;
     node^.hasBody := TRUE;
@@ -2766,10 +2770,13 @@ PROCEDURE MarkExternal (link: ARRAY OF CHAR);
     curProc^.ext := TRUE;
     IF link[0] = CHR(0) THEN Assign(curProc^.link, curProc^.name)
     ELSE Assign(curProc^.link, link)
+    END;
+    IF curProc^.uid <= HIGH(uidLink) THEN
+      Assign(uidLink[curProc^.uid], curProc^.link)
     END
   END MarkExternal;
 
-PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: Name): BOOLEAN;
+PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: LinkName): BOOLEAN;
   VAR node: SymPtr;
   BEGIN
     node := Find(name);
@@ -2779,6 +2786,30 @@ PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: Name): BOOLEAN;
     RETURN TRUE
   END ProcLink;
 
+PROCEDURE ProcLinkByUid (uid: CARDINAL; VAR link: LinkName): BOOLEAN;
+  BEGIN
+    link[0] := CHR(0);
+    IF (uid > HIGH(uidLink)) OR (uidLink[uid][0] = CHR(0)) THEN
+      RETURN FALSE
+    END;
+    Assign(link, uidLink[uid]);
+    RETURN TRUE
+  END ProcLinkByUid;
+
+PROCEDURE ProcLinkByUidName (uid: CARDINAL; name: ARRAY OF CHAR;
+                             VAR link: LinkName): BOOLEAN;
+  BEGIN
+    link[0] := CHR(0);
+    IF (uid > HIGH(uidLink)) OR (uidLink[uid][0] = CHR(0)) THEN
+      RETURN FALSE
+    END;
+    IF (uidBase[uid][0] = CHR(0)) OR NOT Equal(uidBase[uid], name) THEN
+      RETURN FALSE
+    END;
+    Assign(link, uidLink[uid]);
+    RETURN TRUE
+  END ProcLinkByUidName;
+
 PROCEDURE CloseProc;
   BEGIN
     IF nProc > 0 THEN DEC(nProc) END;
@@ -3793,6 +3824,9 @@ PROCEDURE PredefCProc (name, cname: ARRAY OF CHAR; res: TypeIndex): SymPtr;
     node^.fsnap := FALSE;
     Assign(node^.link, cname);
     node^.uid := nextUid; INC(nextUid);
+    IF node^.uid <= HIGH(uidLink) THEN
+      Assign(uidLink[node^.uid], cname)
+    END;
     node^.fdep := 0;
     node^.vslot := -1;
     node^.hasBody := TRUE;

compiler/tests/linkname.def

@@ -0,0 +1,9 @@
+DEFINITION MODULE FOR "C" LinkNameTest;
+(* Short Modula-2 name, long explicit C link name. *)
+
+EXPORT UNQUALIFIED long_sum;
+
+PROCEDURE long_sum (a, b : INTEGER) : INTEGER;
+  EXTERNAL "m2_this_is_a_very_long_c_symbol_name_for_link_alias_test_0123456789";
+
+END LinkNameTest.

compiler/tests/linkname_prog.mod

@@ -0,0 +1,15 @@
+MODULE LinkNameProg;
+(* The FOR "C" definition maps long_sum to a C symbol longer than the
+   old 64-character V3 name limit.  Expected exit code: 42. *)
+
+FROM LinkNameTest IMPORT long_sum;
+
+VAR ExitCode : INTEGER;
+
+BEGIN
+  IF long_sum(19, 23) = 42 THEN
+    ExitCode := 42
+  ELSE
+    ExitCode := 1
+  END
+END LinkNameProg.

compiler/tests/t_extern_alias.mod

@@ -0,0 +1,15 @@
+MODULE TExternAlias;
+(* Implementation-side EXTERNAL alias with a long C symbol. *)
+
+PROCEDURE long_sum (a, b : INTEGER) : INTEGER;
+  EXTERNAL "m2_this_is_a_very_long_c_symbol_name_for_link_alias_test_0123456789";
+
+VAR ExitCode : INTEGER;
+
+BEGIN
+  IF long_sum(20, 22) = 42 THEN
+    ExitCode := 42
+  ELSE
+    ExitCode := 1
+  END
+END TExternAlias.

docs/features.md

@@ -89,6 +89,9 @@ Legend: ✅ done · 🔄 partial · ⏸ not started / deferred.
   `CString` results and `VAR CString` (`char **`) outputs cover C
   string returns and out-parameters; writable C buffers can still be
   declared as `VAR ARRAY OF CHAR`.
+- ✅ `EXTERNAL "c_symbol"` link aliases, in implementations and
+  `FOR "C"` definitions; external link names use a 256-character
+  `SymTab.LinkName`, so short Modula-2 names can bind long C symbols.
 - ✅ Set builtins `INCL`/`EXCL` and `SHIFT`/`ROTATE`; `SET OF <enum>`
   and `SET OF <char-range>`; bounded sets up to 1,000,000 bits;
   `SET OF CARDINAL` and `SET OF INTEGER` use a sorted range-list

runtime/syslib/shim.c

@@ -422,6 +422,13 @@ long m2_cstr_fill(char *buf, long cap)
     return (long)n;
 }
 
+/* Deliberately longer than the old 64-character V3 symbol limit. */
+long m2_this_is_a_very_long_c_symbol_name_for_link_alias_test_0123456789(
+    long a, long b)
+{
+    return a + b;
+}
+
 /* UString length: the codepoint count is the descriptor's header. */
 long m2ustrlen(long *s)
 {