(* varargs.mod provides a basic vararg facility for GNU Modula-2.

Copyright (C) 2015-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE varargs ;

FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM libc IMPORT memcpy ;
FROM SYSTEM IMPORT ADDRESS, TSIZE, ADR, BYTE ;


CONST
   MaxArg = 4 ;

TYPE
   vararg = POINTER TO RECORD
                          nArgs   : CARDINAL ;
			  i       : CARDINAL ;
			  contents: ADDRESS ;
			  size    : CARDINAL ;
			  arg     : ARRAY [0..MaxArg] OF argDesc ;
                       END ;

   argDesc = RECORD
                ptr: ADDRESS ;
                len: CARDINAL ;
             END ;

   ptrToByte = POINTER TO BYTE ;


(*
   arg - fills in, a, with the next argument.  The size of, a, must be an exact
         match with the original vararg parameter.
*)

PROCEDURE arg (v: vararg; VAR a: ARRAY OF BYTE) ;
VAR
   p: POINTER TO BYTE ;
   j: CARDINAL ;
BEGIN
   WITH v^ DO
      IF i=nArgs
      THEN
         HALT  (* too many calls to arg.  *)
      ELSE
         IF HIGH(a)+1=arg[i].len
         THEN
            p := arg[i].ptr ;
            j := 0 ;
            WHILE j<=HIGH (a) DO
               a[j] := p^ ;
               INC (p) ;
               INC (j)
            END
         ELSE
            HALT  (* parameter mismatch.  *)
         END ;
         INC (i)
      END
   END
END arg ;


(*
   nargs - returns the number of arguments wrapped in, v.
*)

PROCEDURE nargs (v: vararg) : CARDINAL ;
BEGIN
   RETURN v^.nArgs
END nargs ;


(*
   copy - returns a copy of, v.
*)

PROCEDURE copy (v: vararg) : vararg ;
VAR
   c     : vararg ;
   j,
   offset: CARDINAL ;
BEGIN
   NEW (c) ;
   WITH c^ DO
      i := v^.i ;
      nArgs := v^.nArgs ;
      size := v^.size ;
      ALLOCATE (contents, size) ;
      contents := memcpy (contents, v^.contents, size) ;
      FOR j := 0 TO nArgs DO
         offset := VAL (CARDINAL, VAL (ptrToByte, v^.contents) - VAL (ptrToByte, v^.arg[j].ptr)) ;
         arg[j].ptr := VAL (ptrToByte, VAL (ptrToByte, contents) + offset) ;
         arg[j].len := v^.arg[j].len ;
      END
   END ;
   RETURN c
END copy ;


(*
   replace - fills the next argument with, a.  The size of, a,
             must be an exact match with the original vararg
             parameter.
*)

PROCEDURE replace (v: vararg; VAR a: ARRAY OF BYTE) ;
VAR
   p: POINTER TO BYTE ;
   j: CARDINAL ;
BEGIN
   WITH v^ DO
      IF i=nArgs
      THEN
         HALT  (* too many calls to arg.  *)
      ELSE
         IF HIGH(a)+1=arg[i].len
         THEN
            p := arg[i].ptr ;
            j := 0 ;
            WHILE j<=HIGH (a) DO
               p^ := a[j] ;
               INC (p) ;
               INC (j)
            END
         ELSE
            HALT  (* parameter mismatch.  *)
         END
      END
   END
END replace ;


(*
   next - assigns the next arg to be collected as, i.
*)

PROCEDURE next (v: vararg; i: CARDINAL) ;
BEGIN
   v^.i := i
END next ;


(*
   end - destructor for vararg, v.
*)

PROCEDURE end (VAR v: vararg) ;
BEGIN
   IF v#NIL
   THEN
      DEALLOCATE (v^.contents, TSIZE (vararg)) ;
      DISPOSE (v)
   END
END end ;


(*
   start1 - wraps up argument, a, into a vararg.
*)

PROCEDURE start1 (a: ARRAY OF BYTE) : vararg ;
VAR
   v: vararg ;
BEGIN
   NEW (v) ;
   WITH v^ DO
      i := 0 ;
      nArgs := 1 ;
      size := HIGH (a) + 1;
      ALLOCATE (contents, size) ;
      contents := memcpy (contents, ADR (a), size) ;
      arg[0].ptr := contents ;
      arg[0].len := size
   END ;
   RETURN v
END start1 ;


(*
   start2 - wraps up arguments, a, b, into a vararg.
*)

PROCEDURE start2 (a, b: ARRAY OF BYTE) : vararg ;
VAR
   v: vararg ;
   p: POINTER TO BYTE ;
BEGIN
   NEW (v) ;
   WITH v^ DO
      i := 0 ;
      nArgs := 2 ;
      size := HIGH (a) + HIGH (b) + 2 ;
      ALLOCATE (contents, size) ;
      p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
      arg[0].ptr := p ;
      arg[0].len := HIGH (a) + 1 ;
      INC (p, arg[0].len) ;
      p := memcpy (p, ADR (b), HIGH (b) + 1) ;
      arg[1].ptr := p ;
      arg[1].len := HIGH (b) + 1
   END ;
   RETURN v
END start2 ;


(*
   start3 - wraps up arguments, a, b, c, into a vararg.
*)

PROCEDURE start3 (a, b, c: ARRAY OF BYTE) : vararg ;
VAR
   v: vararg ;
   p: POINTER TO BYTE ;
BEGIN
   NEW (v) ;
   WITH v^ DO
      i := 0 ;
      nArgs := 3 ;
      size := HIGH (a) + HIGH (b) + HIGH (c) + 3 ;
      ALLOCATE (contents, size) ;
      p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
      arg[0].ptr := p ;
      arg[0].len := HIGH (a) + 1 ;
      INC (p, arg[0].len) ;
      p := memcpy (p, ADR (b), HIGH (b) + 1) ;
      arg[1].ptr := p ;
      arg[1].len := HIGH (b) + 1 ;
      INC (p, arg[1].len) ;
      p := memcpy (p, ADR (c), HIGH (c) + 1) ;
      arg[2].ptr := p ;
      arg[2].len := HIGH (c) + 1
   END ;
   RETURN v
END start3 ;


(*
   start4 - wraps up arguments, a, b, c, d, into a vararg.
*)

PROCEDURE start4 (a, b, c, d: ARRAY OF BYTE) : vararg ;
VAR
   v: vararg ;
   p: POINTER TO BYTE ;
BEGIN
   NEW (v) ;
   WITH v^ DO
      i := 0 ;
      nArgs := 4 ;
      size := HIGH (a) + HIGH (b) + HIGH (c) + HIGH (d) + 4 ;
      ALLOCATE (contents, size) ;
      p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
      arg[0].len := HIGH (a) + 1 ;
      INC (p, arg[0].len) ;
      p := memcpy (p, ADR (b), HIGH (b) + 1) ;
      arg[1].ptr := p ;
      arg[1].len := HIGH (b) + 1 ;
      INC (p, arg[1].len) ;
      p := memcpy (p, ADR (c), HIGH (c) + 1) ;
      arg[2].ptr := p ;
      arg[2].len := HIGH (c) + 1 ;
      INC (p, arg[2].len) ;
      p := memcpy (p, ADR (c), HIGH (c) + 1) ;
      arg[3].ptr := p ;
      arg[3].len := HIGH (c) + 1
   END ;
   RETURN v
END start4 ;


END varargs.