This is apply.c in view mode; [Download] [Up]
/* SCHEME->C */
/* Copyright 1989 Digital Equipment Corporation
* All Rights Reserved
*
* Permission to use, copy, and modify this software and its documentation is
* hereby granted only under the following terms and conditions. Both the
* above copyright notice and this permission notice must appear in all copies
* of the software, derivative works or modified versions, and any portions
* thereof, and both notices must appear in supporting documentation.
*
* Users of this software agree to the terms and conditions set forth herein,
* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
* right and license under any changes, enhancements or extensions made to the
* core functions of the software, including but not limited to those affording
* compatibility with other hardware or software environments, but excluding
* applications which incorporate this software. Users further agree to use
* their best efforts to return to Digital any such changes, enhancements or
* extensions that they make and inform Digital of noteworthy uses of this
* software. Correspondence should be provided to Digital at:
*
* Director of Licensing
* Western Research Laboratory
* Digital Equipment Corporation
* 100 Hamilton Avenue
* Palo Alto, California 94301
*
* This software may be distributed (but not offered for sale or transferred
* for compensation) to third parties, provided such third parties agree to
* abide by the terms and conditions of this notice.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
* SOFTWARE.
*/
/* This module defines the APPLY and UNKNOWNCALL functions. APPLY is as
defined in Revised**3 and UNKNOWNCALL is a variant of APPLY which is used
by the compiler to call unknown functions.
*/
/* External declarations */
#include "objects.h"
#include "scinit.h"
#include "heap.h"
#include "apply.h"
#include <varargs.h>
/* Data structures used by UNKNOWNCALL. These values must be pushed on the
stack and then restored by interrupt handlers or when calling finalization
procedures.
*/
TSCP sc_unknownproc[ 4 ]; /* Procedure pointers */
int sc_unknownargc; /* Procedure argument count */
TSCP sc_arg[MAXARGS]; /* Array for the required arguments */
/* APPLY as defined in Revised**3. It expects a procedure and an argument
list. It returns the result of applying that procedure to the arguments.
*/
TSCP sc_apply_2dtwo( proc, argl )
TSCP proc, argl;
{
int i;
int req; /* # of required arguments */
int opt; /* true iff required arguments */
TSCP arg[MAXARGS]; /* argument array */
TSCP closure; /* closure pointer */
SCP utproc; /* untagged version of tproc */
SCP utargl;
utproc = T_U( proc );
if ((TSCPTAG( proc ) != EXTENDEDTAG) ||
(utproc->procedure.tag != PROCEDURETAG))
sc_error( "APPLY", "Argument is not a PROCEDURE ~s", 1, proc );
req = utproc->procedure.required;
opt = utproc->procedure.optional;
i = 0;
while ((i < req) && (TSCPTAG( argl ) == PAIRTAG)) {
utargl = T_U( argl );
arg[ i++ ] = utargl->pair.car;
argl = utargl->pair.cdr;
}
if (i < req)
sc_error( "APPLY", "PROCEDURE requires ~s arguments, ~s supplied",
2, C_FIXED( req ), C_FIXED( i ) );
if (opt)
closure = utproc->procedure.closure;
else {
if (argl != EMPTYLIST)
sc_error( "APPLY", "PROCEDURE accepts only ~s arguments",
1, C_FIXED( req ) );
argl = utproc->procedure.closure;
}
switch (req) {
case 0: return( (*utproc->procedure.code)
( argl, closure ) );
case 1: return( (*utproc->procedure.code)
( arg[0], argl, closure ) );
case 2: return( (*utproc->procedure.code)
( arg[0], arg[1], argl, closure ) );
case 3: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], argl,
closure ) );
case 4: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
argl, closure ));
case 5: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], argl, closure ) );
case 6: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], argl, closure ) );
case 7: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], argl,
closure ) );
case 8: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
argl, closure ) );
case 9: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], argl, closure ) );
case 10: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], argl, closure ) );
case 11: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], argl,
closure ) );
case 12: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
argl, closure ) );
case 13: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], argl, closure ) );
case 14: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], argl, closure ) );
case 15: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], argl,
closure ) );
case 16: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
argl, closure ) );
#if (MAXARGS >= 17)
case 17: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], argl, closure ) );
#endif
#if (MAXARGS >= 18)
case 18: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], argl, closure ) );
#endif
#if (MAXARGS >= 19)
case 19: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], argl,
closure ) );
#endif
#if (MAXARGS >= 20)
case 20: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], arg[19],
argl, closure ) );
#endif
#if (MAXARGS >= 21)
case 21: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], arg[19],
arg[20], argl, closure ) );
#endif
#if (MAXARGS >= 22)
case 22: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], arg[19],
arg[20], arg[21], argl, closure ) );
#endif
#if (MAXARGS >= 23)
case 23: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], arg[19],
arg[20], arg[21], arg[22], argl,
closure ) );
#endif
#if (MAXARGS >= 24)
case 24: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], arg[19],
arg[20], arg[21], arg[22], arg[23],
argl, closure ) );
#endif
#if (MAXARGS >= 25)
case 25: return( (*utproc->procedure.code)
( arg[0], arg[1], arg[2], arg[3],
arg[4], arg[5], arg[6], arg[7],
arg[8], arg[9], arg[10], arg[11],
arg[12], arg[13], arg[14], arg[15],
arg[16], arg[17], arg[18], arg[19],
arg[20], arg[21], arg[22], arg[23],
arg[24], argl, closure ) );
#endif
}
}
/* UNKNOWNCALL is a variant of apply where the function's arguments are
are passed as arguments to the function. Before the call, the procedure
pointer is placed in SC_UNKNOWNPROC[ 1 ], and the argument count is placed
in SC_UNKNOWNARGC. This procedure is only entered, when there is an error
in the call, or the procedure takes a variable number of arguments.
*/
TSCP sc_unknowncall( va_alist )
va_dcl
{
va_list argl; /* List of arguments on stack */
int req; /* # of required arguments */
int i; /* Loop index */
TSCP optl; /* Optional argument list */
TSCP tail; /* Tail of optional argument list */
SCP utproc; /* Untagged version of proc */
va_start( argl );
utproc = T_U( sc_unknownproc[ 1 ] );
if ((TSCPTAG( sc_unknownproc[ 1 ] ) != EXTENDEDTAG) ||
(utproc->procedure.tag != PROCEDURETAG))
sc_error( "APPLY", "Argument is not a PROCEDURE: ~s", 1,
sc_unknownproc[ 1 ] );
req = utproc->procedure.required;
if ((sc_unknownargc < req) ||
((utproc->procedure.optional == 0) && (sc_unknownargc != req)))
sc_error( "APPLY", "PROCEDURE requires ~s arguments, ~s supplied",
2, C_FIXED( req ), C_FIXED( sc_unknownargc ) );
for (i = 0; i < req; i++) sc_arg[ i ] = va_arg( argl, TSCP );
optl = EMPTYLIST;
if (i++ < sc_unknownargc) {
tail = (optl = sc_cons( va_arg( argl, TSCP ), EMPTYLIST ));
while (i++ < sc_unknownargc)
tail = (TP_U( tail )->pair.cdr = sc_cons( va_arg( argl, TSCP ),
EMPTYLIST ));
}
switch (req) {
case 0: return( (*utproc->procedure.code)
( optl, utproc->procedure.closure ) );
case 1: return( (*utproc->procedure.code)
( sc_arg[0], optl,
utproc->procedure.closure ) );
case 2: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], optl,
utproc->procedure.closure ) );
case 3: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
optl, utproc->procedure.closure ) );
case 4: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], optl,
utproc->procedure.closure ));
case 5: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], optl,
utproc->procedure.closure ) );
case 6: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
optl, utproc->procedure.closure ) );
case 7: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], optl,
utproc->procedure.closure ) );
case 8: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], optl,
utproc->procedure.closure ) );
case 9: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
optl, utproc->procedure.closure ) );
case 10: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], optl,
utproc->procedure.closure ) );
case 11: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], optl,
utproc->procedure.closure ) );
case 12: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
optl, utproc->procedure.closure ) );
case 13: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], optl,
utproc->procedure.closure ) );
case 14: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], optl,
utproc->procedure.closure ) );
case 15: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
optl, utproc->procedure.closure ) );
case 16: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], optl,
utproc->procedure.closure ) );
#if (MAXARGS >= 17)
case 17: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], optl,
utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 18)
case 18: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 19)
case 19: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 20)
case 20: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18], sc_arg[19],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 21)
case 21: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18], sc_arg[19], sc_arg[20],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 22)
case 22: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18], sc_arg[19], sc_arg[20],
sc_arg[21],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 23)
case 23: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18], sc_arg[19], sc_arg[20],
sc_arg[21], sc_arg[22],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 24)
case 24: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18], sc_arg[19], sc_arg[20],
sc_arg[21], sc_arg[22], sc_arg[23],
optl, utproc->procedure.closure ) );
#endif
#if (MAXARGS >= 25)
case 25: return( (*utproc->procedure.code)
( sc_arg[0], sc_arg[1], sc_arg[2],
sc_arg[3], sc_arg[4], sc_arg[5],
sc_arg[6], sc_arg[7], sc_arg[8],
sc_arg[9], sc_arg[10], sc_arg[11],
sc_arg[12], sc_arg[13], sc_arg[14],
sc_arg[15], sc_arg[16], sc_arg[17],
sc_arg[18], sc_arg[19], sc_arg[20],
sc_arg[21], sc_arg[22], sc_arg[23],
sc_arg[24],
optl, utproc->procedure.closure ) );
#endif
}
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.