stk/Src/proc.c

160 lines
3.4 KiB
C
Raw Normal View History

1996-09-27 06:29:02 -04:00
/*
*
* p r o c . c --
*
1999-09-05 07:16:41 -04:00
* Copyright <EFBFBD> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1996-09-27 06:29:02 -04:00
*
*
1999-09-05 07:16:41 -04:00
* Permission to use, copy, modify, distribute,and license this
* software and its documentation for any purpose is hereby granted,
* provided that existing copyright notices are retained in all
* copies and that this notice is included verbatim in any
* distributions. No written agreement, license, or royalty fee is
* required for any of the authorized uses.
* This software is provided ``AS IS'' without express or implied
* warranty.
1996-09-27 06:29:02 -04:00
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 15-Nov-1993 22:02
1999-09-05 07:16:41 -04:00
* Last file update: 3-Sep-1999 20:22 (eg)
1996-09-27 06:29:02 -04:00
*/
#include "stk.h"
#include "extend.h"
1999-09-05 07:16:41 -04:00
#ifdef USE_STKLOS
# include "stklos.h"
#endif
1996-09-27 06:29:02 -04:00
/**** Section 6.9 ****/
int STk_is_thunk(SCM obj)
{
switch (TYPE(obj)) {
#ifdef USE_STKLOS
1999-09-05 07:16:41 -04:00
case tc_instance: return STk_methodp(obj);
1996-09-27 06:29:02 -04:00
#endif
1999-09-05 07:16:41 -04:00
case tc_closure: /* We can be more clever here.... */
1998-04-10 06:59:06 -04:00
case tc_lsubr:
1996-09-27 06:29:02 -04:00
case tc_subr_0:
case tc_subr_0_or_1: return TRUE;
}
return FALSE;
}
1998-04-10 06:59:06 -04:00
SCM STk_makeclosure(SCM code, SCM env)
{
SCM z, tmp;
register int arity = 0;
/* Find procedure arity */
for (tmp = CAR(code); CONSP(tmp); tmp = CDR(tmp))
arity += 1;
if (NNULLP(tmp)) arity = -(arity+1);
NEWCELL(z, tc_closure);
CLOSCODE(z) = code;
CLOSENV(z) = env;
CLOSARITY(z) = arity;
return z;
}
1996-09-27 06:29:02 -04:00
PRIMITIVE STk_procedurep(SCM obj)
{
switch (TYPE(obj)) {
case tc_subr_0:
case tc_subr_1:
case tc_subr_2:
case tc_subr_3:
case tc_subr_0_or_1:
case tc_subr_1_or_2:
case tc_subr_2_or_3:
case tc_lambda:
case tc_lsubr:
case tc_ssubr:
case tc_closure:
case tc_cont:
case tc_apply:
case tc_call_cc:
1999-09-05 07:16:41 -04:00
case tc_dynwind: return Truth;
1996-09-27 06:29:02 -04:00
#ifdef USE_STKLOS
1999-09-05 07:16:41 -04:00
case tc_instance: return STk_methodp(obj) ? Truth: Ntruth;
case tc_next_method:return Truth;
1996-09-27 06:29:02 -04:00
#endif
#ifdef USE_TK
1999-09-05 07:16:41 -04:00
case tc_tkcommand: return Truth;
1996-09-27 06:29:02 -04:00
#endif
default: if (EXTENDEDP(obj))
return STk_extended_procedurep(obj) ? Truth : Ntruth;
else
return Ntruth;
}
}
static SCM general_map(SCM l, int map, int len)
{
register int i;
SCM res = NIL,*tmp = &res;
SCM fct, args;
1998-04-10 06:59:06 -04:00
if (len <= 1) goto error;
1996-09-27 06:29:02 -04:00
fct = CAR(l);
len -= 1;
args = STk_vector(CDR(l), len);
for ( ; ; ) {
/* Build parameter list */
for (l=NIL, i=len-1; i >= 0; i--) {
if (NULLP(VECT(args)[i])) return res;
if (NCONSP(VECT(args)[i])) goto error;
l = Cons(CAR(VECT(args)[i]), l);
VECT(args)[i] = CDR(VECT(args)[i]);
}
/* See if it's a map or a for-each call */
if (map) {
*tmp = Cons(Apply(fct, l), NIL);
tmp = &CDR(*tmp);
}
else Apply(fct, l);
}
error:
{
char buff[50];
sprintf(buff, "%s: malformed list", map? "map" : "for-each");
Err(buff, l);
}
1998-09-30 07:11:02 -04:00
return UNDEFINED; /* never reached */
1996-09-27 06:29:02 -04:00
}
PRIMITIVE STk_map(SCM l, int len)
{
return general_map(l, 1, len);
}
PRIMITIVE STk_for_each(SCM l, int len)
{
1998-04-10 06:59:06 -04:00
general_map(l, 0, len);
return UNDEFINED;
1996-09-27 06:29:02 -04:00
}
PRIMITIVE STk_procedure_body(SCM proc)
{
1998-04-10 06:59:06 -04:00
return TYPEP(proc, tc_closure) ? Cons(Sym_lambda, CLOSCODE(proc)) : Ntruth;
1996-09-27 06:29:02 -04:00
}
PRIMITIVE STk_procedure_environment(SCM proc)
{
1998-04-10 06:59:06 -04:00
return TYPEP(proc, tc_closure) ? STk_makeenv(CLOSENV(proc), 0) : Ntruth;
}
PRIMITIVE STk_procedure_arity(SCM proc)
{
if (NTYPEP(proc, tc_closure)) Err("%procedure-arity: bad closure", proc);
return STk_makeinteger(CLOSARITY(proc));
1996-09-27 06:29:02 -04:00
}