gcc/m2/mc/varargs.mod

   1 (* varargs.mod provides a basic vararg facility for GNU Modula-2.
   2
   3 Copyright (C) 2015-2023 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, VAL (ptrToByte, contents) + offset) ;
 112          arg[j].len := v^.arg[j].len ;
 113       END
 114    END ;
 115    RETURN c
 116 END copy ;
 117
 118
 119 (*
 120    replace - fills the next argument with, a.  The size of, a,
 121              must be an exact match with the original vararg
 122              parameter.
 123 *)
 124
 125 PROCEDURE replace (v: vararg; VAR a: ARRAY OF BYTE) ;
 126 VAR
 127    p: POINTER TO BYTE ;
 128    j: CARDINAL ;
 129 BEGIN
 130    WITH v^ DO
 131       IF i=nArgs
 132       THEN
 133          HALT  (* too many calls to arg.  *)
 134       ELSE
 135          IF HIGH(a)+1=arg[i].len
 136          THEN
 137             p := arg[i].ptr ;
 138             j := 0 ;
 139             WHILE j<=HIGH (a) DO
 140                p^ := a[j] ;
 141                INC (p) ;
 142                INC (j)
 143             END
 144          ELSE
 145             HALT  (* parameter mismatch.  *)
 146          END
 147       END
 148    END
 149 END replace ;
 150
 151
 152 (*
 153    next - assigns the next arg to be collected as, i.
 154 *)
 155
 156 PROCEDURE next (v: vararg; i: CARDINAL) ;
 157 BEGIN
 158    v^.i := i
 159 END next ;
 160
 161
 162 (*
 163    end - destructor for vararg, v.
 164 *)
 165
 166 PROCEDURE end (VAR v: vararg) ;
 167 BEGIN
 168    IF v#NIL
 169    THEN
 170       DEALLOCATE (v^.contents, TSIZE (vararg)) ;
 171       DISPOSE (v)
 172    END
 173 END end ;
 174
 175
 176 (*
 177    start1 - wraps up argument, a, into a vararg.
 178 *)
 179
 180 PROCEDURE start1 (a: ARRAY OF BYTE) : vararg ;
 181 VAR
 182    v: vararg ;
 183 BEGIN
 184    NEW (v) ;
 185    WITH v^ DO
 186       i := 0 ;
 187       nArgs := 1 ;
 188       size := HIGH (a) + 1;
 189       ALLOCATE (contents, size) ;
 190       contents := memcpy (contents, ADR (a), size) ;
 191       arg[0].ptr := contents ;
 192       arg[0].len := size
 193    END ;
 194    RETURN v
 195 END start1 ;
 196
 197
 198 (*
 199    start2 - wraps up arguments, a, b, into a vararg.
 200 *)
 201
 202 PROCEDURE start2 (a, b: ARRAY OF BYTE) : vararg ;
 203 VAR
 204    v: vararg ;
 205    p: POINTER TO BYTE ;
 206 BEGIN
 207    NEW (v) ;
 208    WITH v^ DO
 209       i := 0 ;
 210       nArgs := 2 ;
 211       size := HIGH (a) + HIGH (b) + 2 ;
 212       ALLOCATE (contents, size) ;
 213       p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
 214       arg[0].ptr := p ;
 215       arg[0].len := HIGH (a) + 1 ;
 216       INC (p, arg[0].len) ;
 217       p := memcpy (p, ADR (b), HIGH (b) + 1) ;
 218       arg[1].ptr := p ;
 219       arg[1].len := HIGH (b) + 1
 220    END ;
 221    RETURN v
 222 END start2 ;
 223
 224
 225 (*
 226    start3 - wraps up arguments, a, b, c, into a vararg.
 227 *)
 228
 229 PROCEDURE start3 (a, b, c: ARRAY OF BYTE) : vararg ;
 230 VAR
 231    v: vararg ;
 232    p: POINTER TO BYTE ;
 233 BEGIN
 234    NEW (v) ;
 235    WITH v^ DO
 236       i := 0 ;
 237       nArgs := 3 ;
 238       size := HIGH (a) + HIGH (b) + HIGH (c) + 3 ;
 239       ALLOCATE (contents, size) ;
 240       p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
 241       arg[0].ptr := p ;
 242       arg[0].len := HIGH (a) + 1 ;
 243       INC (p, arg[0].len) ;
 244       p := memcpy (p, ADR (b), HIGH (b) + 1) ;
 245       arg[1].ptr := p ;
 246       arg[1].len := HIGH (b) + 1 ;
 247       INC (p, arg[1].len) ;
 248       p := memcpy (p, ADR (c), HIGH (c) + 1) ;
 249       arg[2].ptr := p ;
 250       arg[2].len := HIGH (c) + 1
 251    END ;
 252    RETURN v
 253 END start3 ;
 254
 255
 256 (*
 257    start4 - wraps up arguments, a, b, c, d, into a vararg.
 258 *)
 259
 260 PROCEDURE start4 (a, b, c, d: ARRAY OF BYTE) : vararg ;
 261 VAR
 262    v: vararg ;
 263    p: POINTER TO BYTE ;
 264 BEGIN
 265    NEW (v) ;
 266    WITH v^ DO
 267       i := 0 ;
 268       nArgs := 4 ;
 269       size := HIGH (a) + HIGH (b) + HIGH (c) + HIGH (d) + 4 ;
 270       ALLOCATE (contents, size) ;
 271       p := memcpy (contents, ADR (a), HIGH (a) + 1) ;
 272       arg[0].len := HIGH (a) + 1 ;
 273       INC (p, arg[0].len) ;
 274       p := memcpy (p, ADR (b), HIGH (b) + 1) ;
 275       arg[1].ptr := p ;
 276       arg[1].len := HIGH (b) + 1 ;
 277       INC (p, arg[1].len) ;
 278       p := memcpy (p, ADR (c), HIGH (c) + 1) ;
 279       arg[2].ptr := p ;
 280       arg[2].len := HIGH (c) + 1 ;
 281       INC (p, arg[2].len) ;
 282       p := memcpy (p, ADR (c), HIGH (c) + 1) ;
 283       arg[3].ptr := p ;
 284       arg[3].len := HIGH (c) + 1
 285    END ;
 286    RETURN v
 287 END start4 ;
 288
 289
 290 END varargs.