gcc/m2/mc/varargs.mod

   1 (* varargs.mod provides a basic vararg facility for GNU Modula-2.
   2
   3 Copyright (C) 2015-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius@glam.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE varargs ;
  23
  24 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  25 FROM libc IMPORT memcpy ;
  26 FROM SYSTEM IMPORT ADDRESS, TSIZE, ADR, BYTE ;
  27
  28
  29 CONST
  30    MaxArg = 4 ;
  31
  32 TYPE
  33    vararg = POINTER TO RECORD
  34                           nArgs   : CARDINAL ;
  35                           i       : CARDINAL ;
  36                           contents: ADDRESS ;
  37                           size    : CARDINAL ;
  38                           arg     : ARRAY [0..MaxArg] OF argDesc ;
  39                        END ;
  40
  41    argDesc = RECORD
  42                 ptr: ADDRESS ;
  43                 len: CARDINAL ;
  44              END ;
  45
  46    ptrToByte = POINTER TO BYTE ;
  47
  48
  49 (*
  50    arg - fills in, a, with the next argument.  The size of, a, must be an exact
  51          match with the original vararg parameter.
  52 *)
  53
  54 PROCEDURE arg (v: vararg; VAR a: ARRAY OF BYTE) ;
  55 VAR
  56    p: POINTER TO BYTE ;
  57    j: CARDINAL ;
  58 BEGIN
  59    WITH v^ DO
  60       IF i=nArgs
  61       THEN
  62          HALT  (* too many calls to arg.  *)
  63       ELSE
  64          IF HIGH(a)+1=arg[i].len
  65          THEN
  66             p := arg[i].ptr ;
  67             j := 0 ;
  68             WHILE j<=HIGH (a) DO
  69                a[j] := p^ ;
  70                INC (p) ;
  71                INC (j)
  72             END
  73          ELSE
  74             HALT  (* parameter mismatch.  *)
  75          END ;
  76          INC (i)
  77       END
  78    END
  79 END arg ;
  80
  81
  82 (*
  83    nargs - returns the number of arguments wrapped in, v.
  84 *)
  85
  86 PROCEDURE nargs (v: vararg) : CARDINAL ;
  87 BEGIN
  88    RETURN v^.nArgs
  89 END nargs ;
  90
  91
  92 (*
  93    copy - returns a copy of, v.
  94 *)
  95
  96 PROCEDURE copy (v: vararg) : vararg ;
  97 VAR
  98    c     : vararg ;
  99    j,
 100    offset: CARDINAL ;
 101 BEGIN
 102    NEW (c) ;
 103    WITH c^ DO
 104       i := v^.i ;
 105       nArgs := v^.nArgs ;
 106       size := v^.size ;
 107       ALLOCATE (contents, size) ;
 108       contents := memcpy (contents, v^.contents, size) ;
 109       FOR j := 0 TO nArgs DO
 110          offset := VAL (CARDINAL, VAL (ptrToByte, v^.contents) - VAL (ptrToByte, v^.arg[j].ptr)) ;
 111          arg[j].ptr := VAL (ptrToByte, contents) ;
 112          INC (arg[j].ptr, offset) ;
 113          arg[j].len := v^.arg[j].len ;
 114       END
 115    END ;
 116    RETURN c
 117 END copy ;
 118
 119
 120 (*
 121    replace - fills the next argument with, a.  The size of, a,
 122              must be an exact match with the original vararg
 123              parameter.
 124 *)
 125
 126 PROCEDURE replace (v: vararg; VAR a: ARRAY OF BYTE) ;
 127 VAR
 128    p: POINTER TO BYTE ;
 129    j: CARDINAL ;
 130 BEGIN
 131    WITH v^ DO
 132       IF i=nArgs
 133       THEN
 134          HALT  (* too many calls to arg.  *)
 135       ELSE
 136          IF HIGH(a)+1=arg[i].len
 137          THEN
 138             p := arg[i].ptr ;
 139             j := 0 ;
 140             WHILE j<=HIGH (a) DO
 141                p^ := a[j] ;
 142                INC (p) ;
 143                INC (j)
 144             END
 145          ELSE
 146             HALT  (* parameter mismatch.  *)
 147          END
 148       END
 149    END
 150 END replace ;
 151
 152
 153 (*
 154    next - assigns the next arg to be collected as, i.
 155 *)
 156
 157 PROCEDURE next (v: vararg; i: CARDINAL) ;
 158 BEGIN
 159    v^.i := i
 160 END next ;
 161
 162
 163 (*
 164    end - destructor for vararg, v.
 165 *)
 166
 167 PROCEDURE end (VAR v: vararg) ;
 168 BEGIN
 169    IF v#NIL
 170    THEN
 171       DEALLOCATE (v^.contents, TSIZE (vararg)) ;
 172       DISPOSE (v)
 173    END
 174 END end ;
 175
 176
 177 (*
 178    start1 - wraps up argument, a, into a vararg.
 179 *)
 180
 181 PROCEDURE start1 (a: ARRAY OF BYTE) : vararg ;
 182 VAR
 183    v: vararg ;
 184 BEGIN
 185    NEW (v) ;
 186    WITH v^ DO
 187       i := 0 ;
 188       nArgs := 1 ;
 189       size := HIGH (a) + 1;
 190       ALLOCATE (contents, size) ;
 191       contents := memcpy (contents, ADR (a), size) ;
 192       arg[0].ptr := contents ;
 193       arg[0].len := size
 194    END ;
 195    RETURN v
 196 END start1 ;
 197
 198
 199 (*
 200    start2 - wraps up arguments, a, b, into a vararg.
 201 *)
 202
 203 PROCEDURE start2 (a, b: ARRAY OF BYTE) : vararg ;
 204 VAR
 205    v: vararg ;
 206    p: POINTER TO BYTE ;
 207 BEGIN
 208    NEW (v) ;
 209    WITH v^ DO
 210       i := 0 ;
 211       nArgs := 2 ;
 212       size := HIGH (a) + HIGH (b) + 2 ;
 213       ALLOCATE (contents, size) ;
 214       p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
 215       arg[0].ptr := p ;
 216       arg[0].len := HIGH (a) + 1 ;
 217       INC (p, arg[0].len) ;
 218       p := memcpy (p, ADR (b), HIGH (b) + 1) ;
 219       arg[1].ptr := p ;
 220       arg[1].len := HIGH (b) + 1
 221    END ;
 222    RETURN v
 223 END start2 ;
 224
 225
 226 (*
 227    start3 - wraps up arguments, a, b, c, into a vararg.
 228 *)
 229
 230 PROCEDURE start3 (a, b, c: ARRAY OF BYTE) : vararg ;
 231 VAR
 232    v: vararg ;
 233    p: POINTER TO BYTE ;
 234 BEGIN
 235    NEW (v) ;
 236    WITH v^ DO
 237       i := 0 ;
 238       nArgs := 3 ;
 239       size := HIGH (a) + HIGH (b) + HIGH (c) + 3 ;
 240       ALLOCATE (contents, size) ;
 241       p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
 242       arg[0].ptr := p ;
 243       arg[0].len := HIGH (a) + 1 ;
 244       INC (p, arg[0].len) ;
 245       p := memcpy (p, ADR (b), HIGH (b) + 1) ;
 246       arg[1].ptr := p ;
 247       arg[1].len := HIGH (b) + 1 ;
 248       INC (p, arg[1].len) ;
 249       p := memcpy (p, ADR (c), HIGH (c) + 1) ;
 250       arg[2].ptr := p ;
 251       arg[2].len := HIGH (c) + 1
 252    END ;
 253    RETURN v
 254 END start3 ;
 255
 256
 257 (*
 258    start4 - wraps up arguments, a, b, c, d, into a vararg.
 259 *)
 260
 261 PROCEDURE start4 (a, b, c, d: ARRAY OF BYTE) : vararg ;
 262 VAR
 263    v: vararg ;
 264    p: POINTER TO BYTE ;
 265 BEGIN
 266    NEW (v) ;
 267    WITH v^ DO
 268       i := 0 ;
 269       nArgs := 4 ;
 270       size := HIGH (a) + HIGH (b) + HIGH (c) + HIGH (d) + 4 ;
 271       ALLOCATE (contents, size) ;
 272       p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
 273       arg[0].len := HIGH (a) + 1 ;
 274       INC (p, arg[0].len) ;
 275       p := memcpy (p, ADR (b), HIGH (b) + 1) ;
 276       arg[1].ptr := p ;
 277       arg[1].len := HIGH (b) + 1 ;
 278       INC (p, arg[1].len) ;
 279       p := memcpy (p, ADR (c), HIGH (c) + 1) ;
 280       arg[2].ptr := p ;
 281       arg[2].len := HIGH (c) + 1 ;
 282       INC (p, arg[2].len) ;
 283       p := memcpy (p, ADR (c), HIGH (c) + 1) ;
 284       arg[3].ptr := p ;
 285       arg[3].len := HIGH (c) + 1
 286    END ;
 287    RETURN v
 288 END start4 ;
 289
 290
 291 END varargs.