/* fns1.c Copyright (C) 1989-2002 Codemist Ltd */
/*
* Basic functions part 1.
*/
/*
* This code may be used and modified, and redistributed in binary
* or source form, subject to the "CCL Public License", which should
* accompany it. This license is a variant on the BSD license, and thus
* permits use of code derived from this in either open and commercial
* projects: but it does require that updates to this code be made
* available back to the originators of the package.
* Before merging other code in with this or linking this code
* with other packages or libraries please check that the license terms
* of the other material are compatible with those of this.
*/
/* Signature: 7c43b906 10-Oct-2002 */
#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include "machine.h"
#include "tags.h"
#include "cslerror.h"
#include "externs.h"
#include "entries.h"
#include "arith.h"
#ifdef TIMEOUT
#include "timeout.h"
#endif
/*****************************************************************************/
/* Some basic functions */
/*****************************************************************************/
Lisp_Object integerp(Lisp_Object p)
{
Lisp_Object nil = C_nil;
int tag = ((int)p) & TAG_BITS;
if (tag == TAG_FIXNUM) return lisp_true;
if (tag == TAG_NUMBERS)
{ Header h = *(Header *)((char *)p - TAG_NUMBERS);
if (type_of_header(h) == TYPE_BIGNUM) return lisp_true;
}
return nil;
}
/*****************************************************************************/
/* Storage allocation. */
/*****************************************************************************/
Lisp_Object cons(Lisp_Object a, Lisp_Object b)
{
nil_as_base
Lisp_Object r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = b;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return reclaim((Lisp_Object)((char *)r + TAG_CONS),
"internal cons", GC_CONS, 0);
else return (Lisp_Object)((char *)r + TAG_CONS);
}
Lisp_Object cons_no_gc(Lisp_Object a, Lisp_Object b)
{
nil_as_base
Lisp_Object r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = b;
fringe = r;
return (Lisp_Object)((char *)r + TAG_CONS);
}
/*
* cons_gc_test() MUST be called after any sequence of cons_no_gc() calls.
*/
Lisp_Object cons_gc_test(Lisp_Object p)
{
nil_as_base
if ((char *)fringe <= (char *)heaplimit)
return reclaim(p, "cons gc test", GC_CONS, 0);
else return p;
}
Lisp_Object ncons(Lisp_Object a)
{
Lisp_Object nil = C_nil;
Lisp_Object r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = nil;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return reclaim((Lisp_Object)((char *)r + TAG_CONS),
"internal ncons", GC_CONS, 0);
else return (Lisp_Object)((char *)r + TAG_CONS);
}
Lisp_Object list2(Lisp_Object a, Lisp_Object b)
{
/* Note that building two cons cells at once saves some overhead here */
Lisp_Object nil = C_nil;
Lisp_Object r = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
qcar((char *)r+sizeof(Cons_Cell)) = b;
qcdr((char *)r+sizeof(Cons_Cell)) = nil;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return reclaim((Lisp_Object)((char *)r + TAG_CONS),
"internal list2", GC_CONS, 0);
else return (Lisp_Object)((char *)r + TAG_CONS);
}
Lisp_Object list2star(Lisp_Object a, Lisp_Object b, Lisp_Object c)
{
nil_as_base
Lisp_Object r = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
qcar((char *)r+sizeof(Cons_Cell)) = b;
qcdr((char *)r+sizeof(Cons_Cell)) = c;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return reclaim((Lisp_Object)((char *)r + TAG_CONS),
"internal list2*", GC_CONS, 0);
else return (Lisp_Object)((char *)r + TAG_CONS);
}
Lisp_Object acons(Lisp_Object a, Lisp_Object b, Lisp_Object c)
{
nil_as_base
Lisp_Object r = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell));
qcar(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
qcdr(r) = c;
qcar((char *)r+sizeof(Cons_Cell)) = a;
qcdr((char *)r+sizeof(Cons_Cell)) = b;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return reclaim((Lisp_Object)((char *)r + TAG_CONS),
"internal acons", GC_CONS, 0);
else return (Lisp_Object)((char *)r + TAG_CONS);
}
Lisp_Object list3(Lisp_Object a, Lisp_Object b, Lisp_Object c)
{
Lisp_Object nil = C_nil;
Lisp_Object r = (Lisp_Object)((char *)fringe - 3*sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
qcar((char *)r+sizeof(Cons_Cell)) = b;
qcdr((char *)r+sizeof(Cons_Cell)) =
(Lisp_Object)((char *)r + 2*sizeof(Cons_Cell) + TAG_CONS);
qcar((char *)r+2*sizeof(Cons_Cell)) = c;
qcdr((char *)r+2*sizeof(Cons_Cell)) = nil;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return reclaim((Lisp_Object)((char *)r + TAG_CONS),
"internal list3", GC_CONS, 0);
else return (Lisp_Object)((char *)r + TAG_CONS);
}
/*****************************************************************************/
/*****************************************************************************/
/*** Lisp-callable versions of all the above ***/
/*****************************************************************************/
/*****************************************************************************/
/*
* The set of car/cdr combinations here seem pretty dull, but they
* are fairly important for performance...
*/
Lisp_Object Lcar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
/*
* (car* a) = (car a) if a is non-atomic, but just a otherwise.
*/
Lisp_Object Lcar_star(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return onevalue(a);
else return onevalue(qcar(a));
}
Lisp_Object Lcdr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcdar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcaaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcaadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcadar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcaddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcdaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcdadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcddar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcdddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcaaaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcaaadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcaadar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcaaddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcadaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcadadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcaddar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcadddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else return onevalue(qcar(a));
}
Lisp_Object Lcdaaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcdaadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcdadar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcdaddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcddaar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcddadr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcdddar(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_car, a);
else a = qcar(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lcddddr(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else a = qcdr(a);
if (!car_legal(a)) return error(1, err_bad_cdr, a);
else return onevalue(qcdr(a));
}
Lisp_Object Lrplaca(Lisp_Object nil,
Lisp_Object a, Lisp_Object b)
{
CSL_IGNORE(nil);
if (!consp(a)) return error(1, err_bad_rplac, a);
qcar(a) = b;
return onevalue(a);
}
Lisp_Object Lrplacd(Lisp_Object nil,
Lisp_Object a, Lisp_Object b)
{
CSL_IGNORE(nil);
if (!consp(a)) return error(1, err_bad_rplac, a);
qcdr(a) = b;
return onevalue(a);
}
Lisp_Object Lsymbolp(Lisp_Object nil, Lisp_Object a)
{
return onevalue(Lispify_predicate(symbolp(a)));
}
Lisp_Object Latom(Lisp_Object nil, Lisp_Object a)
{
return onevalue(Lispify_predicate(!consp(a)));
}
Lisp_Object Lconsp(Lisp_Object nil, Lisp_Object a)
{
return onevalue(Lispify_predicate(consp(a)));
}
Lisp_Object Lconstantp(Lisp_Object nil, Lisp_Object a)
/*
* This version is as required for Standard Lisp - it is inadequate
* for Common Lisp.
*/
{
/*
* Standard Lisp requires that I report that "Function Pointers" are
* "constant" here. It is not at all clear that I have a way of
* doing that. I will go some way my ensuring that code-vectors are.
*/
#ifdef COMMON
return onevalue(Lispify_predicate(
a == nil || a == lisp_true ||
is_char(a) ||
is_number(a) ||
is_vector(a) ||
is_bps(a)));
#else
return onevalue(Lispify_predicate(
is_number(a) ||
is_vector(a) || /* Vectors include strings here */
is_bps(a)));
#endif
}
Lisp_Object Lidentity(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
return onevalue(a);
}
#ifdef COMMON
Lisp_Object Llistp(Lisp_Object nil, Lisp_Object a)
{
return onevalue(Lispify_predicate(is_cons(a)));
}
#endif
Lisp_Object Lnumberp(Lisp_Object nil, Lisp_Object a)
{
return onevalue(Lispify_predicate(is_number(a)));
}
Lisp_Object Lintegerp(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
return onevalue(integerp(a));
}
Lisp_Object Leq_safe(Lisp_Object nil, Lisp_Object a)
{
/*
* True if you can safely use EQ tests to check equality. Thus true for
* things that are represented in "immediate" form...
*/
#ifdef COMMON
return onevalue(is_fixnum(a) ||
is_sfloat(a) ||
is_odds(a) ? lisp_true : nil);
#else
return onevalue(is_fixnum(a) ||
is_odds(a) ? lisp_true : nil);
#endif
}
Lisp_Object Lfixp(Lisp_Object nil, Lisp_Object a)
{
#ifdef COMMON
return onevalue(is_fixnum(a) ? lisp_true : nil);
#else
/*
* Standard Lisp defines fixp to say yes to bignums as well as
* fixnums.
*/
CSL_IGNORE(nil);
return onevalue(integerp(a));
#endif
}
Lisp_Object Lfloatp(Lisp_Object nil, Lisp_Object p)
{
int tag = TAG_BITS & (int)p;
#ifdef COMMON
if (tag == TAG_SFLOAT) return onevalue(lisp_true);
#endif
if (tag == TAG_BOXFLOAT) return onevalue(lisp_true);
else return onevalue(nil);
}
#ifdef COMMON
static Lisp_Object Lshort_floatp(Lisp_Object nil, Lisp_Object p)
{
int tag = TAG_BITS & (int)p;
if (tag == TAG_SFLOAT) return onevalue(lisp_true);
else return onevalue(nil);
}
static Lisp_Object Lsingle_floatp(Lisp_Object nil, Lisp_Object p)
{
int tag = TAG_BITS & (int)p;
if (tag == TAG_BOXFLOAT &&
type_of_header(flthdr(p)) == TYPE_SINGLE_FLOAT)
return onevalue(lisp_true);
else return onevalue(nil);
}
static Lisp_Object Ldouble_floatp(Lisp_Object nil, Lisp_Object p)
{
int tag = TAG_BITS & (int)p;
if (tag == TAG_BOXFLOAT &&
type_of_header(flthdr(p)) == TYPE_DOUBLE_FLOAT)
return onevalue(lisp_true);
else return onevalue(nil);
}
static Lisp_Object Llong_floatp(Lisp_Object nil, Lisp_Object p)
{
int tag = TAG_BITS & (int)p;
if (tag == TAG_BOXFLOAT &&
type_of_header(flthdr(p)) == TYPE_LONG_FLOAT)
return onevalue(lisp_true);
else return onevalue(nil);
}
Lisp_Object Lrationalp(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
return onevalue(
Lispify_predicate(
is_fixnum(a) ||
(is_numbers(a) &&
(is_bignum(a) || is_ratio(a)))));
}
Lisp_Object Lcomplexp(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
return onevalue(Lispify_predicate(is_numbers(a) && is_complex(a)));
}
CSLbool complex_stringp(Lisp_Object a)
/*
* true if the arg is a string, but NOT a simple string. In general
* when this is true simplify_string() will then be called to do
* an adjustment.
*/
{
Header h;
Lisp_Object w, nil = C_nil;
if (!is_vector(a)) return NO;
h = vechdr(a);
if (type_of_header(h) != TYPE_ARRAY) return NO;
/*
* Note that the cheery Common Lisp Committee decided the abolish the
* separate type 'string-char, so the test here is maybe dubious...
*/
else if (elt(a, 0) != string_char_sym) return NO;
w = elt(a, 1);
if (!consp(w) || consp(qcdr(w))) return NO;
else return YES;
}
#endif
Lisp_Object Lwarn_about_protected_symbols(Lisp_Object nil, Lisp_Object a)
{
Lisp_Object retval = Lispify_predicate(warn_about_protected_symbols);
warn_about_protected_symbols = (a != nil);
return onevalue(retval);
}
Lisp_Object Lprotect_symbols(Lisp_Object nil, Lisp_Object a)
{
Lisp_Object retval = Lispify_predicate(symbol_protect_flag);
symbol_protect_flag = (a != nil);
return onevalue(retval);
}
CSLbool stringp(Lisp_Object a)
/*
* True if arg is a simple OR a general string
*/
{
Header h;
#ifdef COMMON
Lisp_Object w, nil = C_nil;
#endif
if (!is_vector(a)) return NO;
h = vechdr(a);
if (type_of_header(h) == TYPE_STRING) return YES;
#ifdef COMMON
else if (type_of_header(h) != TYPE_ARRAY) return NO;
/*
* Beware abolition of 'string-char
*/
else if (elt(a, 0) != string_char_sym) return NO;
w = elt(a, 1);
if (!consp(w) || consp(qcdr(w))) return NO;
else return YES;
#else
else return NO;
#endif
}
Lisp_Object Lstringp(Lisp_Object nil, Lisp_Object a)
/*
* simple-string-p
*/
{
if (!(is_vector(a)) || type_of_header(vechdr(a)) != TYPE_STRING)
return onevalue(nil);
else return onevalue(lisp_true);
}
#ifdef COMMON
static Lisp_Object Lc_stringp(Lisp_Object nil, Lisp_Object a)
{
return onevalue(Lispify_predicate(stringp(a)));
}
#endif
Lisp_Object Lhash_table_p(Lisp_Object nil, Lisp_Object a)
/*
* hash-table-p
*/
{
if (!(is_vector(a)) || type_of_header(vechdr(a)) != TYPE_HASH)
return onevalue(nil);
else return onevalue(lisp_true);
}
#ifdef COMMON
static Lisp_Object Lsimple_bit_vector_p(Lisp_Object nil,
Lisp_Object a)
/*
* simple-bit-vector-p
*/
{
if (!(is_vector(a))) return onevalue(nil);
else return onevalue(Lispify_predicate(header_of_bitvector(vechdr(a))));
}
#endif
Lisp_Object Lsimple_vectorp(Lisp_Object nil, Lisp_Object a)
/*
* simple-vector-p
*/
{
if (!(is_vector(a))) return onevalue(nil);
else return onevalue(Lispify_predicate(
type_of_header(vechdr(a))==TYPE_SIMPLE_VEC));
}
Lisp_Object Lbpsp(Lisp_Object nil, Lisp_Object a)
{
if (!(is_bps(a))) return onevalue(nil);
else return onevalue(lisp_true);
}
Lisp_Object Lthreevectorp(Lisp_Object nil, Lisp_Object a)
/*
* This is useful for REDUCE - it checks if something is a vector
* of size 3!
*/
{
if (!(is_vector(a))) return onevalue(nil);
return onevalue(Lispify_predicate(
vechdr(a) == (TAG_ODDS + TYPE_SIMPLE_VEC + ((4*CELL)<<10))));
}
#ifdef COMMON
static Lisp_Object Larrayp(Lisp_Object nil, Lisp_Object a)
{
Header h;
if (!(is_vector(a))) return onevalue(nil);
h = vechdr(a);
/*
* I could consider accepting TYPE_VEC16 and TYPE_VEC32 etc here...
*/
if (type_of_header(h)==TYPE_ARRAY ||
type_of_header(h)==TYPE_STRING ||
type_of_header(h)==TYPE_SIMPLE_VEC ||
header_of_bitvector(h)) return onevalue(lisp_true);
else return onevalue(nil);
}
static Lisp_Object Lcomplex_arrayp(Lisp_Object nil, Lisp_Object a)
{
if (!(is_vector(a))) return onevalue(nil);
else return onevalue(Lispify_predicate(
type_of_header(vechdr(a))==TYPE_ARRAY));
}
static Lisp_Object Lconvert_to_array(Lisp_Object nil, Lisp_Object a)
{
if (!(is_vector(a))) return onevalue(nil);
vechdr(a) = TYPE_ARRAY + (vechdr(a) & ~header_mask);
return onevalue(a);
}
#endif
static Lisp_Object Lstructp(Lisp_Object nil, Lisp_Object a)
/*
* structp
*/
{
if (!(is_vector(a))) return onevalue(nil);
else return onevalue(Lispify_predicate(
type_of_header(vechdr(a))==TYPE_STRUCTURE));
}
static Lisp_Object Lconvert_to_struct(Lisp_Object nil, Lisp_Object a)
{
if (!(is_vector(a))) return onevalue(nil);
vechdr(a) = TYPE_STRUCTURE + (vechdr(a) & ~header_mask);
return onevalue(a);
}
Lisp_Object Lcons(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
Lisp_Object r;
CSL_IGNORE(nil);
r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = b;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return onevalue(reclaim((Lisp_Object)((char *)r + TAG_CONS),
"cons", GC_CONS, 0));
else return onevalue((Lisp_Object)((char *)r + TAG_CONS));
}
Lisp_Object Lxcons(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
Lisp_Object r;
CSL_IGNORE(nil);
r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
qcar(r) = b;
qcdr(r) = a;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return onevalue(reclaim((Lisp_Object)((char *)r + TAG_CONS),
"xcons", GC_CONS, 0));
else return onevalue((Lisp_Object)((char *)r + TAG_CONS));
}
Lisp_Object Lncons(Lisp_Object nil, Lisp_Object a)
{
Lisp_Object r;
r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
qcar(r) = a;
qcdr(r) = nil;
fringe = r;
if ((char *)r <= (char *)heaplimit)
return onevalue(reclaim((Lisp_Object)((char *)r + TAG_CONS),
"ncons", GC_CONS, 0));
else return onevalue((Lisp_Object)((char *)r + TAG_CONS));
}
Lisp_Object Llist2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
a = list2(a, b);
errexit();
return onevalue(a);
}
Lisp_Object Lmkquote(Lisp_Object nil, Lisp_Object a)
{
a = list2(quote_symbol, a);
errexit();
return onevalue(a);
}
Lisp_Object MS_CDECL Llist2star(Lisp_Object nil, int nargs, ...)
{
va_list aa;
Lisp_Object a, b, c;
argcheck(nargs, 3, "list2*");
va_start(aa, nargs);
a = va_arg(aa, Lisp_Object);
b = va_arg(aa, Lisp_Object);
c = va_arg(aa, Lisp_Object);
va_end(aa);
a = list2star(a,b,c);
errexit();
return onevalue(a);
}
Lisp_Object MS_CDECL Lacons(Lisp_Object nil, int nargs, ...)
{
va_list aa;
Lisp_Object a, b, c;
argcheck(nargs, 3, "acons");
va_start(aa, nargs);
a = va_arg(aa, Lisp_Object);
b = va_arg(aa, Lisp_Object);
c = va_arg(aa, Lisp_Object);
va_end(aa);
a = acons(a,b,c);
errexit();
return onevalue(a);
}
Lisp_Object MS_CDECL Llist3(Lisp_Object nil, int nargs, ...)
{
va_list aa;
Lisp_Object a, b, c;
argcheck(nargs, 3, "list3");
va_start(aa, nargs);
a = va_arg(aa, Lisp_Object);
b = va_arg(aa, Lisp_Object);
c = va_arg(aa, Lisp_Object);
va_end(aa);
a = list3(a,b,c);
errexit();
return onevalue(a);
}
#ifdef COMMON
/*
* In non-COMMON mode I implement list and list* as special forms
* rather than as functions, guessing that that will be more efficient.
*/
Lisp_Object MS_CDECL Llist(Lisp_Object nil, int nargs, ...)
{
Lisp_Object r = nil, w, w1;
va_list a;
va_start(a, nargs);
push_args(a, nargs);
while (nargs > 1)
{ pop2(w, w1);
nargs-=2;
r = list2star(w1, w, r);
errexitn(nargs);
}
while (nargs > 0)
{ pop(w);
nargs--;
r = cons(w, r);
errexitn(nargs);
}
return onevalue(r);
}
static Lisp_Object MS_CDECL Lliststar(Lisp_Object nil, int nargs, ...)
{
Lisp_Object r, w, w1;
va_list a;
if (nargs == 0) return onevalue(nil);
va_start(a, nargs);
push_args(a, nargs);
pop(r);
nargs--;
while (nargs > 1)
{ pop2(w, w1);
nargs-=2;
r = list2star(w1, w, r);
errexitn(nargs);
}
while (nargs > 0)
{ pop(w);
nargs--;
r = cons(w, r);
errexitn(nargs);
}
return onevalue(r);
}
/*
* fill-vector is used for open-compilation of (vector ...) to avoid
* passing grossly unreasonable numbers of arguments. The expansion of
* (vector e1 ... en) should be
* (let ((v (mkvect <n-1>)) (i 0))
* (setq i (fill-vector v i e1 e2 ... e10))
* (setq i (fill-vector v i e11 e12 ... ))
* ...
* v)
*/
static Lisp_Object MS_CDECL Lfill_vector(Lisp_Object nil, int nargs, ...)
{
va_list a;
Lisp_Object v, il;
int32 i;
CSL_IGNORE(nil);
if (nargs < 3) return aerror("fill-vector");
va_start(a, nargs);
v = va_arg(a, Lisp_Object);
il = va_arg(a, Lisp_Object);
if (!is_vector(v) || !is_fixnum(il)) return aerror("fill-vector");
i = int_of_fixnum(il);
nargs -= 2;
while (nargs != 0)
{ elt(v, i++) = va_arg(a, Lisp_Object);
nargs--;
}
return onevalue(fixnum_of_int(i));
}
#endif
Lisp_Object Lpair(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
Lisp_Object r = nil;
while (consp(a) && consp(b))
{ push2(a, b);
r = acons(qcar(a), qcar(b), r);
pop2(b, a);
errexit();
a = qcdr(a);
b = qcdr(b);
}
a = nil;
while (r != nil)
{ b = qcdr(r);
qcdr(r) = a;
a = r;
r = b;
}
return onevalue(a);
}
static int32 membercount(Lisp_Object a, Lisp_Object b)
/*
* Counts how many times a is a member of the list b
*/
{
int32 r = 0;
#ifdef COMMON
Lisp_Object nil = C_nil;
#endif
if (is_symbol(a) || is_fixnum(a))
{ while (consp(b))
{ if (a == qcar(b)) r++;
b = qcdr(b);
}
return r;
}
while (consp(b))
{ Lisp_Object cb = qcar(b);
if (equal(a, cb)) r++;
b = qcdr(b);
}
return r;
}
/*
* INTERSECTION(A,B)
* The result will have its items in the order that they occur in A.
* If lists A and B contain duplicate items these will appear in the
* output if and only if the items involved are duplicated in both
* input lists.
*/
Lisp_Object Lintersect(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
Lisp_Object r = nil, w;
push(b);
while (consp(a))
{ push2(a, r);
w = Lmember(nil, qcar(a), stack[-2]);
errexitn(3);
/* Here I ignore any item in a that is not also in b */
if (w != nil)
{ int32 n1 = membercount(qcar(stack[-1]), stack[0]);
errexitn(3);
/*
* Here I want to arrange that items only appear in the result list multiple
* times if they occur multipl times in BOTH the input lists.
*/
if (n1 != 0)
{ int32 n2 = membercount(qcar(stack[-1]), stack[-2]);
errexitn(3);
if (n2 > n1) n1 = 0;
}
if (n1 == 0)
{ pop(r);
a = stack[0];
r = cons(qcar(a), r);
errexitn(2);
pop(a);
}
else pop2(r, a);
}
else pop2(r, a);
a = qcdr(a);
}
popv(1);
a = nil;
while (consp(r))
{ b = r;
r = qcdr(r);
qcdr(b) = a;
a = b;
}
return onevalue(a);
}
/*
* UNION(A, B)
* This works by consing onto the front of B each element of A that
* is not already in B. Thus items in A (but not already in B) get
* added in reversed order. Duplicates in B remain there, and but
* duplicates in A are dropped.
*/
Lisp_Object Lunion(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
while (consp(a))
{ Lisp_Object c;
push2(a, b);
c = Lmember(nil, qcar(a), b);
errexitn(2);
pop(b);
if (c == nil)
{ b = cons(qcar(stack[0]), b);
errexitn(1);
}
pop(a);
a = qcdr(a);
}
return onevalue(b);
}
Lisp_Object Lenable_backtrace(Lisp_Object nil, Lisp_Object a)
{
int32 n = miscflags;
if (a == nil) miscflags &= ~MESSAGES_FLAG;
else miscflags |= MESSAGES_FLAG;
return onevalue(Lispify_predicate((n & MESSAGES_FLAG) != 0));
}
#ifdef NAG
Lisp_Object MS_CDECL Lunwind(Lisp_Object nil, int nargs, ...)
{
argcheck(nargs, 0, "unwind");
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_count = 0;
exit_tag = nil;
flip_exception();
return nil;
}
#endif
/*
* If the variable *break-function* has as its value a symbol, and that
* symbol names a function, then the function concerned will be called
* with one argument after the headline for the diagnostic. When it returns
* the system will unwind in the usual manner.
*/
Lisp_Object MS_CDECL Lerror(Lisp_Object nil, int nargs, ...)
{
va_list a;
Lisp_Object w;
#ifdef COMMON
Lisp_Object r = nil, w1;
#else
int i;
#endif
if (nargs == 0) return aerror("error");
va_start(a, nargs);
push_args(a, nargs);
#ifdef COMMON
while (nargs > 1)
{ pop2(w, w1);
nargs -= 2;
w = list2star(w1, w, r);
nil = C_nil;
if (exception_pending()) flip_exception();
else r = w;
}
while (nargs > 0)
{ pop(w);
nargs--;
w = cons(w, r);
nil = C_nil;
if (exception_pending()) flip_exception();
else r = w;
}
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
{ push(r);
err_printf("\n+++ error: ");
/*
* I will use FORMAT to handle error messages provided the first arg
* to error had been a string and also provided (for bootstrapping) that
* the function FORMAT seems to be defined.
*/
if (qfn1(format_symbol) == undefined1 ||
!consp(r) ||
!stringp(qcar(r))) loop_print_error(r);
else Lapply_n(nil, 3, format_symbol, qvalue(error_output), r);
ignore_exception();
err_printf("\n");
pop(r);
ignore_exception();
}
qvalue(emsg_star) = r; /* "Error message" in CL world */
exit_value = fixnum_of_int(0); /* "Error number" in CL world */
#else
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
{ err_printf("\n+++ error: ");
loop_print_error(stack[1-nargs]);
for (i=1; i<nargs; i++)
{ err_printf(" ");
loop_print_error(stack[1+i-nargs]);
}
err_printf("\n");
}
if (nargs == 1)
{ push(nil);
nargs++;
}
qvalue(emsg_star) = stack[2-nargs]; /* "Error message" in SL world */
exit_value = stack[1-nargs]; /* "Error number" in SL world */
popv(nargs);
#endif
if ((w = qvalue(break_function)) != nil &&
symbolp(w) &&
qfn1(w) != undefined1)
{ (*qfn1(w))(qenv(w), qvalue(emsg_star));
ignore_exception();
}
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_count = 0;
exit_tag = nil;
flip_exception();
return nil;
}
Lisp_Object Lerror1(Lisp_Object nil, Lisp_Object a1)
{
return Lerror(nil, 1, a1);
}
Lisp_Object Lerror2(Lisp_Object nil, Lisp_Object a1, Lisp_Object a2)
{
return Lerror(nil, 2, a1, a2);
}
Lisp_Object MS_CDECL Lerror0(Lisp_Object nil, int nargs, ...)
{
/*
* Silently provoked error - unwind to surrounding errorset level. Note that
* this will NEVER enter a user-provided break loop...
*/
argcheck(nargs, 0, "error0");
miscflags &= ~(MESSAGES_FLAG | HEADLINE_FLAG);
exit_reason = UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
return nil;
}
Lisp_Object Lstop(Lisp_Object env, Lisp_Object code)
{
/*
* I ignore "env" and set up nil for myself here to make it easier to call
* this function from random places in my interface code...
*/
Lisp_Object nil = C_nil;
CSL_IGNORE(env);
if (!is_fixnum(code)) return aerror("stop");
exit_value = code;
exit_tag = fixnum_of_int(0); /* Flag to say "stop" */
exit_reason = UNWIND_RESTART;
exit_count = 1;
flip_exception();
return nil;
}
Lisp_Object Lmake_special(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!symbolp(a)) return aerror1("make-special", a);
qheader(a) |= SYM_SPECIAL_VAR;
return onevalue(a);
}
Lisp_Object Lmake_global(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!symbolp(a)) return aerror("make-global");
qheader(a) |= (SYM_SPECIAL_VAR | SYM_GLOBAL_VAR);
return onevalue(a);
}
Lisp_Object Lunmake_special(Lisp_Object nil, Lisp_Object a)
{
if (!symbolp(a)) return onevalue(nil);
qheader(a) &= ~(SYM_SPECIAL_VAR | SYM_GLOBAL_VAR);
return onevalue(a);
}
Lisp_Object Lunmake_global(Lisp_Object nil, Lisp_Object a)
{
if (!symbolp(a)) return onevalue(nil);
qheader(a) &= ~(SYM_SPECIAL_VAR | SYM_GLOBAL_VAR);
return onevalue(a);
}
Lisp_Object Lsymbol_specialp(Lisp_Object nil, Lisp_Object a)
{
if (!symbolp(a)) return onevalue(nil);
else if ((qheader(a) & (SYM_SPECIAL_VAR | SYM_GLOBAL_VAR)) ==
SYM_SPECIAL_VAR) return onevalue(lisp_true);
else return onevalue(nil);
}
Lisp_Object Lsymbol_globalp(Lisp_Object nil, Lisp_Object a)
{
if (!symbolp(a)) return onevalue(nil);
else if ((qheader(a) & SYM_GLOBAL_VAR) != 0) return onevalue(lisp_true);
else return onevalue(nil);
}
Lisp_Object Lboundp(Lisp_Object nil, Lisp_Object a)
{
if (!symbolp(a)) return onevalue(nil);
#ifndef COMMON
/*
* In COMMON Lisp it seems that this is intended to just check if the
* value cell in a shallow-bound implementation contains some marker value
* that stands for "junk". In Standard Lisp mode I deem that variables
* that have not been declared fluid are unbound. Seems to me like a
* classical mix-up between the concept of binding and of having some
* particular value... Oh well.
*/
else if ((qheader(a) & SYM_SPECIAL_VAR) == 0) return onevalue(nil);
#endif
else if (qvalue(a) == unset_var) return onevalue(nil); /* no value yet */
else return onevalue(lisp_true);
}
Lisp_Object Lsymbol_value(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!symbolp(a)) return onevalue(a);
else return onevalue(qvalue(a));
}
Lisp_Object Lset(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
if (!symbolp(a) || a == nil || a == lisp_true) return aerror("set");
qvalue(a) = b;
return onevalue(b);
}
Lisp_Object Lsymbol_function(Lisp_Object nil, Lisp_Object a)
{
one_args *f1;
two_args *f2;
n_args *fn;
if (!symbolp(a)) return onevalue(nil);
f1 = qfn1(a); f2 = qfn2(a); fn = qfnn(a);
if ((qheader(a) & (SYM_SPECIAL_FORM | SYM_MACRO)) != 0 ||
(f1 == undefined1 && f2 == undefined2 &&
fn == undefinedn)) return onevalue(nil);
else if (f1 == interpreted1 ||
f2 == interpreted2 ||
fn == interpretedn)
/* I wonder if onevalue(cons(...)) is really valid here. It is OK in SL mode */
return onevalue(cons(lambda, qenv(a)));
else if (f1 == funarged1 ||
f2 == funarged2 ||
fn == funargedn)
return onevalue(cons(funarg, qenv(a)));
else if (f1 == traceinterpreted1 ||
f2 == traceinterpreted2 ||
fn == traceinterpretedn)
return onevalue(cons(lambda, qcdr(qenv(a))));
else if (f1 == tracefunarged1 ||
f2 == tracefunarged2 ||
fn == tracefunargedn)
return onevalue(cons(funarg, qcdr(qenv(a))));
else
{
#ifdef COMMON
Lisp_Object b = get(a, work_symbol, nil);
#else
Lisp_Object b = get(a, work_symbol);
#endif
/*
* If I have already manufactured a code pointer for this function I
* can find it on the property list - in that case I will re-use it.
*/
while (b != nil)
{ Lisp_Object c = qcar(b);
if ((qheader(c) & (SYM_C_DEF | SYM_CODEPTR)) ==
(SYM_CODEPTR | (qheader(a) & SYM_C_DEF)))
return onevalue(c);
b = qcdr(b);
}
push(a);
/*
* To carry a code-pointer I manufacture a sort of gensym, flagging
* it in its header as a "code pointer object" and sticking the required
* definition in with it. I need to link this to the originating
* definition in some cases to allow for preserve/restart problems wrt
* the initialisation of function addresses that refer to C code.
* I make the carrier using GENSYM1, but need to clear the gensym flag bit
* to show I have a regular name for the object, and that I will not need
* to append a serial number later on. In Common Lisp mode I let the name
* of the gensym be just the name of the function, while in Standard Lisp
* mode I will append a numeric suffix. I do this because in Common Lisp
* mode the thing will print as (say) #:apply which is visibly different
* from the name 'apply of the base function, while in Standard Lisp a name
* like apply775 is needed to make the distinction (easily) visible.
*/
#ifdef COMMON
b = Lgensym2(nil, a);
#else
b = Lgensym1(nil, a);
#endif
pop(a);
errexit();
set_fns(b, f1, f2, fn);
qenv(b) = qenv(a);
#ifdef COMMON
/* in Common Lisp mode gensyms that are "unprinted" are not special */
qheader(b) ^= (SYM_ANY_GENSYM | SYM_CODEPTR);
#else
qheader(b) ^= (SYM_UNPRINTED_GENSYM | SYM_ANY_GENSYM | SYM_CODEPTR);
#endif
if ((qheader(a) & SYM_C_DEF) != 0)
{ Lisp_Object c, w;
#ifdef COMMON
c = get(a, unset_var, nil);
#else
c = get(a, unset_var);
#endif
if (c == nil) c = a;
push3(a, b, c);
qheader(b) |= SYM_C_DEF;
putprop(b, unset_var, c);
errexitn(3);
c = stack[0]; b = stack[-1];
#ifdef COMMON
w = get(c, work_symbol, nil);
#else
w = get(c, work_symbol);
#endif
w = cons(b, w);
pop(c);
errexitn(2);
putprop(c, work_symbol, w);
pop2(b, a);
errexit();
}
return onevalue(b);
}
}
Lisp_Object Lspecial_form_p(Lisp_Object nil, Lisp_Object a)
{
if (!symbolp(a)) return onevalue(nil);
else if ((qheader(a) & SYM_SPECIAL_FORM) != 0) return onevalue(lisp_true);
else return onevalue(nil);
}
Lisp_Object Lcodep(Lisp_Object nil, Lisp_Object a)
/*
* This responds TRUE for the special pseudo-symbols that are used to
* carry compiled code objects. It returns NIL on the symbols that
* are normally used by the user.
*/
{
if (!symbolp(a)) return onevalue(nil);
if ((qheader(a) & (SYM_CODEPTR | SYM_C_DEF)) == SYM_CODEPTR)
return onevalue(lisp_true);
else return onevalue(nil);
}
Lisp_Object getvector(int tag, int32 type, intxx size)
{
/*
* tag is the value (e.g. TAG_SYMBOL) that will go in the low order
* 3 bits of the pointer result.
* type is the code (e.g. TYPE_SYMBOL) that gets packed, together with
* the size, into a header word.
* size is measured in bytes and must allow space for the header word.
* [Note that this last issue - size including the header - was probably
* a mistake since the header size depends on whether I am using a
* 32-bit or 64-bit representation. However it would be hard to unwind
* that now!]
*/
Lisp_Object nil = C_nil;
#ifdef CHECK_FOR_CORRUPT_HEAP
validate_all();
#endif
for (;;)
{ char *r = (char *)vfringe;
unsigned int free = (unsigned int)((char *)vheaplimit - r);
/*
* On a 64-bit system the allocation size will be a multiple of 8 anyway, so
* the doubleword_align here will have no effect! The result is that I never
* need or use a padding word at the end of a vector in that case.
*/
int32 alloc_size = (int32)doubleword_align_up(size);
/*
* There is a real NASTY here - it is quite possible that I ought to implement
* a scheme whereby large vectors can be allocated as a series of chunks so as
* to avoid the current absolute limit on size. Remember that the page size
* is about 64 Kbytes for small machines but on larger ones I can have bigger
* pages (typically 256K) and hence bigger vectors.
*/
if (alloc_size > CSL_PAGE_SIZE - 32)
return aerror("vector request too big");
if (alloc_size > (intxx)free)
{ char msg[40];
/*
* I go to a whole load of trouble here to tell the user what sort of
* vector request provoked this garbage collection. I wonder if the user
* really cares - but I do very much when I am chasing after GC bugs!
*/
switch (tag)
{
case TAG_SYMBOL:
sprintf(msg, "symbol header");
break;
case TAG_NUMBERS:
switch (type)
{
case TYPE_BIGNUM:
sprintf(msg, "bignum(%ld)", (long)size);
break;
default:
sprintf(msg, "numbers(%lx,%ld)", (long)type, (long)size);
break;
}
break;
case TAG_VECTOR:
switch (type)
{
case TYPE_STRING:
sprintf(msg, "string(%ld)", (long)size);
break;
case TYPE_BPS:
sprintf(msg, "BPS(%ld)", (long)size);
break;
case TYPE_SIMPLE_VEC:
sprintf(msg, "simple vector(%ld)", (long)size);
break;
case TYPE_HASH:
sprintf(msg, "hash table(%ld)", (long)size);
break;
default:
sprintf(msg, "vector(%lx,%ld)", (long)type, (long)size);
break;
}
break;
case TAG_BOXFLOAT:
sprintf(msg, "float(%ld)", (long)size);
break;
default:
sprintf(msg, "getvector(%lx,%ld)", (long)tag, (long)size);
break;
}
reclaim(nil, msg, GC_VEC, alloc_size);
errexit();
continue;
}
vfringe = (Lisp_Object)(r + alloc_size);
*((Header *)r) = type + (size << 10) + TAG_ODDS;
/*
* DANGER: the vector allocated here is left uninitialised at this stage.
* This is OK if the vector will contain binary information, but if it
* will hold any Lisp_Objects it needs safe values put in PDQ.
*/
return (Lisp_Object)(r + tag);
}
}
Lisp_Object getvector_init(intxx n, Lisp_Object k)
{
Lisp_Object p, nil;
push(k);
p = getvector(TAG_VECTOR, TYPE_SIMPLE_VEC, n);
pop(k);
errexit();
#ifndef ADDRESS_64
if ((n & 4) != 0) n += 4; /* Ensure last doubleword is tidy */
#endif
while (n > CELL)
{ n -= CELL;
*(Lisp_Object *)((char *)p - TAG_VECTOR + n) = k;
}
return p;
}
clock_t base_time;
double *clock_stack, consolidated_time[10], gc_time;
void push_clock(void)
{
clock_t t0 = read_clock();
/*
* Provided that I do this often enough I will not suffer clock
* wrap-around or overflow.
*/
double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
base_time = t0;
*clock_stack += delta;
*++clock_stack = 0.0;
}
double pop_clock(void)
{
clock_t t0 = read_clock();
double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
base_time = t0;
return delta + *clock_stack--;
}
Lisp_Object MS_CDECL Ltime(Lisp_Object nil, int nargs, ...)
{
unsigned32 tt;
Lisp_Object r;
if (clock_stack == &consolidated_time[0])
{ clock_t t0 = read_clock();
double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
base_time = t0;
consolidated_time[0] += delta;
}
argcheck(nargs, 0, "time");
CSL_IGNORE(nil);
tt = (unsigned32)(1000.0 * consolidated_time[0]);
/*
* Overflow here is around 49 days. I suppose that that is almost a
* thinkable amount of CPU time to use.... Oh dear!
*/
if ((tt & fix_mask) == 0) return onevalue(fixnum_of_int(tt));
if (!signed_overflow(tt)) r = make_one_word_bignum(tt);
else r = make_two_word_bignum((tt>>31) & 1, tt & 0x7fffffff);
errexit();
return onevalue(r);
}
Lisp_Object MS_CDECL Lgctime(Lisp_Object nil, int nargs, ...)
{
argcheck(nargs, 0, "gctime");
CSL_IGNORE(nil);
return onevalue(fixnum_of_int((int32)(1000.0 * gc_time)));
}
#ifdef COMMON
Lisp_Object MS_CDECL Ldecoded_time(Lisp_Object nil, int nargs, ...)
{
time_t t0 = time(NULL);
/*
* tm_sec -- seconds 0..59
* tm_min -- minutes 0..59
* tm_hour -- hour of day 0..23
* tm_mday -- day of month 1..31
* tm_mon -- month 0..11
* tm_year -- years since 1900
* tm_wday -- day of week, 0..6 (Sunday..Saturday)
* tm_yday -- day of year, 0..365
* tm_isdst -- >0 if daylight savings time
* -- ==0 if not DST
* -- <0 if don't know
*/
struct tm *tbuf = localtime(&t0);
Lisp_Object r, *p = &mv_2;
int w;
argcheck(nargs, 0, "get-decoded-time");
r = fixnum_of_int(tbuf->tm_sec);
*p++ = fixnum_of_int(tbuf->tm_min);
*p++ = fixnum_of_int(tbuf->tm_hour);
*p++ = fixnum_of_int(tbuf->tm_mday);
*p++ = fixnum_of_int(tbuf->tm_mon+1);
*p++ = fixnum_of_int(tbuf->tm_year+1900);
w = tbuf->tm_wday;
*p++ = fixnum_of_int(w == 0 ? 6 : w-1);
*p++ = tbuf->tm_isdst > 0 ? lisp_true : nil;
*p++ = fixnum_of_int(0); /* Time zone info not available? */
return nvalues(r, 9);
}
#endif
Lisp_Object MS_CDECL Ldate(Lisp_Object nil, int nargs, ...)
{
Lisp_Object w;
time_t t = time(NULL);
char today[32];
argcheck(nargs, 0, "date");
CSL_IGNORE(nil);
strcpy(today, ctime(&t)); /* e.g. "Sun Sep 16 01:03:52 1973\n" */
today[24] = 0; /* loses final '\n' */
w = make_string(today);
errexit();
return onevalue(w);
}
Lisp_Object MS_CDECL Ldatestamp(Lisp_Object nil, int nargs, ...)
/*
* Returns date-stamp integer, which on many systems will be the
* number of seconds between 1970.0.0 and now, but which could be
* pretty-well other things, as per the C "time_t" type.
*/
{
Lisp_Object w;
time_t t = time(NULL);
/*
* Hmmm - I need to check time_t on a 64-bit machine!
*/
unsigned32 n = (unsigned32)t; /* NON-PORTABLE assumption about time_t */
argcheck(nargs, 0, "datestamp");
CSL_IGNORE(nil);
if ((n & fix_mask) == 0) w = fixnum_of_int(n);
else if ((n & 0xc0000000U) == 0) w = make_one_word_bignum(n);
else w = make_two_word_bignum((n >> 31) & 1, n & 0x7fffffff);
errexit();
return onevalue(w);
}
#define STR24HDR (TAG_ODDS+TYPE_STRING+((24+CELL)<<10))
static int getint(char *p, int len)
{
int r = 0;
while (len-- != 0)
{ int c = *p++;
if (c == ' ') c = '0';
r = 10*r + (c - '0');
}
return r;
}
static int getmon(char *s)
{
int c1 = s[0], c2 = s[1], c3 = s[2], r = -1, w;
char *m = "janfebmaraprmayjunjulaugsepoctnovdec";
if (isupper(c1)) c1 = tolower(c1);
if (isupper(c2)) c2 = tolower(c2);
if (isupper(c3)) c3 = tolower(c3);
for (w=0; w<12; w++)
{ if (c1==m[0] && c2==m[1] && c3==m[2])
{ r = w;
break;
}
m += 3;
}
return r;
}
static Lisp_Object Ldatelessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
/*
* This is maybe a bit of an abomination! The functions (date) and
* (filedate "filename") [and also (modulep 'modulename)] return times
* as strings of 24 characters. This function decodes these and
* sorts out which time is earlier. The alternative would be to provide
* a collection of functions that returned coded times (as in C "time_t"),
* but I have greater doubts about making those utterly portable, while the
* textual arrangement used here seems fairly robust (until you start
* worrying about carrying a portable machine across time zones or switching
* to daylight savings time).
*/
{
char *aa, *bb;
CSLbool res;
int wa, wb;
if (!is_vector(a) || !is_vector(b) ||
vechdr(a) != STR24HDR ||
vechdr(b) != STR24HDR) return aerror2("datelessp", a, b);
aa = (char *)a + (CELL - TAG_VECTOR);
bb = (char *)b + (CELL - TAG_VECTOR);
/*
* Layout is eg. "Wed May 12 15:50:23 1993"
* 012345678901234567890123
* Note that the year is 4 digits so that the year 2000 should hold
* no special terrors JUST here.
*/
if ((wa = getint(aa+20, 4)) != (wb = getint(bb+20, 4))) res = wa < wb;
else if ((wa = getmon(aa+4)) != (wb = getmon(bb+4))) res = wa < wb;
else if ((wa = getint(aa+8, 2)) != (wb = getint(bb+8, 2))) res = wa < wb;
else if ((wa = getint(aa+11, 2)) != (wb = getint(bb+11, 2))) res = wa < wb;
else if ((wa = getint(aa+14, 2)) != (wb = getint(bb+14, 2))) res = wa < wb;
else if ((wa = getint(aa+17, 2)) != (wb = getint(bb+17, 2))) res = wa < wb;
else res = NO;
return onevalue(Lispify_predicate(res));
}
static Lisp_Object Lrepresentation1(Lisp_Object nil, Lisp_Object a)
/*
* Intended for debugging, and use with indirect (q.v.)
*/
{
#ifdef ADDRESS_64
/* /* unreconstructed - may need to build a 64-bit int here */
int32 top = (int32)a & 0xf8000000U;
CSL_IGNORE(nil);
if (top == 0 || top == 0xf8000000U)
return onevalue(fixnum_of_int((int32)a));
a = make_one_word_bignum((int32)a);
errexit();
return onevalue(a);
#else
int32 top = (int32)a & 0xf8000000U;
CSL_IGNORE(nil);
if (top == 0 || top == 0xf8000000U)
return onevalue(fixnum_of_int((int32)a));
a = make_one_word_bignum((int32)a);
errexit();
return onevalue(a);
#endif
}
static Lisp_Object Lrepresentation2(Lisp_Object nil,
Lisp_Object a, Lisp_Object b)
/*
* Intended for debugging, and use with indirect (q.v.). arg2, if
* present and non-nil makes this more verbose.
*/
{
#ifdef ADDRESS_64
/* /* Unreconstructed wrt return value but trace printing is 64 bit */
int32 top = (int32)a & 0xf8000000U;
CSL_IGNORE(nil);
if (b != nil) trace_printf(" %.16lx ", (long)(unsigned64)a);
if (top == 0 || top == 0xf8000000U)
return onevalue(fixnum_of_int((int32)a));
a = make_one_word_bignum((int32)a);
errexit();
return onevalue(a);
#else
int32 top = (int32)a & 0xf8000000U;
CSL_IGNORE(nil);
if (b != nil) trace_printf(" %.8lx ", (long)(unsigned32)a);
if (top == 0 || top == 0xf8000000U)
return onevalue(fixnum_of_int((int32)a));
a = make_one_word_bignum((int32)a);
errexit();
return onevalue(a);
#endif
}
Lisp_Object Lindirect(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
#ifdef ADDRESS_64
return onevalue(*(Lisp_Object *)sixty_four_bits(a));
#else
return onevalue(*(Lisp_Object *)thirty_two_bits(a));
#endif
}
setup_type const funcs1_setup[] =
{
{"acons", wrong_no_na, wrong_no_nb, Lacons},
{"atom", Latom, too_many_1, wrong_no_1},
{"boundp", Lboundp, too_many_1, wrong_no_1},
{"car", Lcar, too_many_1, wrong_no_1},
{"car*", Lcar_star, too_many_1, wrong_no_1},
{"cdr", Lcdr, too_many_1, wrong_no_1},
{"caar", Lcaar, too_many_1, wrong_no_1},
{"cadr", Lcadr, too_many_1, wrong_no_1},
{"cdar", Lcdar, too_many_1, wrong_no_1},
{"cddr", Lcddr, too_many_1, wrong_no_1},
{"caaar", Lcaaar, too_many_1, wrong_no_1},
{"caadr", Lcaadr, too_many_1, wrong_no_1},
{"cadar", Lcadar, too_many_1, wrong_no_1},
{"caddr", Lcaddr, too_many_1, wrong_no_1},
{"cdaar", Lcdaar, too_many_1, wrong_no_1},
{"cdadr", Lcdadr, too_many_1, wrong_no_1},
{"cddar", Lcddar, too_many_1, wrong_no_1},
{"cdddr", Lcdddr, too_many_1, wrong_no_1},
{"caaaar", Lcaaaar, too_many_1, wrong_no_1},
{"caaadr", Lcaaadr, too_many_1, wrong_no_1},
{"caadar", Lcaadar, too_many_1, wrong_no_1},
{"caaddr", Lcaaddr, too_many_1, wrong_no_1},
{"cadaar", Lcadaar, too_many_1, wrong_no_1},
{"cadadr", Lcadadr, too_many_1, wrong_no_1},
{"caddar", Lcaddar, too_many_1, wrong_no_1},
{"cadddr", Lcadddr, too_many_1, wrong_no_1},
{"cdaaar", Lcdaaar, too_many_1, wrong_no_1},
{"cdaadr", Lcdaadr, too_many_1, wrong_no_1},
{"cdadar", Lcdadar, too_many_1, wrong_no_1},
{"cdaddr", Lcdaddr, too_many_1, wrong_no_1},
{"cddaar", Lcddaar, too_many_1, wrong_no_1},
{"cddadr", Lcddadr, too_many_1, wrong_no_1},
{"cdddar", Lcdddar, too_many_1, wrong_no_1},
{"cddddr", Lcddddr, too_many_1, wrong_no_1},
{"qcar", Lcar, too_many_1, wrong_no_1},
{"qcdr", Lcdr, too_many_1, wrong_no_1},
{"qcaar", Lcaar, too_many_1, wrong_no_1},
{"qcadr", Lcadr, too_many_1, wrong_no_1},
{"qcdar", Lcdar, too_many_1, wrong_no_1},
{"qcddr", Lcddr, too_many_1, wrong_no_1},
{"bpsp", Lbpsp, too_many_1, wrong_no_1},
{"codep", Lcodep, too_many_1, wrong_no_1},
{"constantp", Lconstantp, too_many_1, wrong_no_1},
{"date", wrong_no_na, wrong_no_nb, Ldate},
{"datestamp", wrong_no_na, wrong_no_nb, Ldatestamp},
{"enable-backtrace", Lenable_backtrace, too_many_1, wrong_no_1},
{"error", Lerror1, Lerror2, Lerror},
{"error1", wrong_no_na, wrong_no_nb, Lerror0},
#ifdef NAG
{"unwind", wrong_no_na, wrong_no_nb, Lunwind},
#endif
{"eq-safe", Leq_safe, too_many_1, wrong_no_1},
{"fixp", Lfixp, too_many_1, wrong_no_1},
{"floatp", Lfloatp, too_many_1, wrong_no_1},
{"fluidp", Lsymbol_specialp, too_many_1, wrong_no_1},
{"gctime", wrong_no_na, wrong_no_nb, Lgctime},
{"globalp", Lsymbol_globalp, too_many_1, wrong_no_1},
{"hash-table-p", Lhash_table_p, too_many_1, wrong_no_1},
{"indirect", Lindirect, too_many_1, wrong_no_1},
{"integerp", Lintegerp, too_many_1, wrong_no_1},
{"intersection", too_few_2, Lintersect, wrong_no_2},
{"list2", too_few_2, Llist2, wrong_no_2},
{"list2*", wrong_no_na, wrong_no_nb, Llist2star},
{"list3", wrong_no_na, wrong_no_nb, Llist3},
{"make-global", Lmake_global, too_many_1, wrong_no_1},
{"make-special", Lmake_special, too_many_1, wrong_no_1},
{"mkquote", Lmkquote, too_many_1, wrong_no_1},
{"ncons", Lncons, too_many_1, wrong_no_1},
{"numberp", Lnumberp, too_many_1, wrong_no_1},
{"pair", too_few_2, Lpair, wrong_no_2},
{"protect-symbols", Lprotect_symbols, too_many_1, wrong_no_1},
{"protected-symbol-warn", Lwarn_about_protected_symbols, too_many_1, wrong_no_1},
{"put", wrong_no_na, wrong_no_nb, Lputprop},
{"remprop", too_few_2, Lremprop, wrong_no_2},
{"representation", Lrepresentation1, Lrepresentation2, wrong_no_2},
{"rplaca", too_few_2, Lrplaca, wrong_no_2},
{"rplacd", too_few_2, Lrplacd, wrong_no_2},
{"set", too_few_2, Lset, wrong_no_2},
{"special-form-p", Lspecial_form_p, too_many_1, wrong_no_1},
{"stop", Lstop, too_many_1, wrong_no_1},
{"symbol-function", Lsymbol_function, too_many_1, wrong_no_1},
{"symbol-value", Lsymbol_value, too_many_1, wrong_no_1},
{"time", wrong_no_na, wrong_no_nb, Ltime},
{"datelessp", too_few_2, Ldatelessp, wrong_no_2},
{"union", too_few_2, Lunion, wrong_no_2},
{"unmake-global", Lunmake_global, too_many_1, wrong_no_1},
{"unmake-special", Lunmake_special, too_many_1, wrong_no_1},
{"xcons", too_few_2, Lxcons, wrong_no_2},
/* I provide both IDP and SYMBOLP in both modes... */
{"symbolp", Lsymbolp, too_many_1, wrong_no_1},
{"idp", Lsymbolp, too_many_1, wrong_no_1},
/* I support the Common Lisp names here in both modes */
{"simple-string-p", Lstringp, too_many_1, wrong_no_1},
{"simple-vector-p", Lsimple_vectorp, too_many_1, wrong_no_1},
#ifdef COMMON
{"fill-vector", wrong_no_na, wrong_no_nb, Lfill_vector},
{"get", too_few_2, Lget, Lget_3},
{"get-decoded-time", wrong_no_0a, wrong_no_0b, Ldecoded_time},
{"arrayp", Larrayp, too_many_1, wrong_no_1},
{"complex-arrayp", Lcomplex_arrayp, too_many_1, wrong_no_1},
{"short-floatp", Lshort_floatp, too_many_1, wrong_no_1},
{"single-floatp", Lsingle_floatp, too_many_1, wrong_no_1},
{"double-floatp", Ldouble_floatp, too_many_1, wrong_no_1},
{"long-floatp", Llong_floatp, too_many_1, wrong_no_1},
{"rationalp", Lrationalp, too_many_1, wrong_no_1},
{"complexp", Lcomplexp, too_many_1, wrong_no_1},
{"consp", Lconsp, too_many_1, wrong_no_1},
{"convert-to-array", Lconvert_to_array, too_many_1, wrong_no_1},
{"convert-to-struct", Lconvert_to_struct, too_many_1, wrong_no_1},
{"identity", Lidentity, too_many_1, wrong_no_1},
{"list", Lncons, Llist2, Llist},
{"list*", Lidentity, Lcons, Lliststar},
{"listp", Llistp, too_many_1, wrong_no_1},
{"bit-vector-p", Lsimple_bit_vector_p, too_many_1, wrong_no_1},
{"simple-bit-vector-p", Lsimple_bit_vector_p, too_many_1, wrong_no_1},
{"stringp", Lc_stringp, too_many_1, wrong_no_1},
{"structp", Lstructp, too_many_1, wrong_no_1},
{"flag", too_few_2, Lflag, wrong_no_2},
{"flagp", too_few_2, Lflagp, wrong_no_2},
{"flagpcar", too_few_2, Lflagpcar, wrong_no_2},
{"remflag", too_few_2, Lremflag, wrong_no_2},
{"time*", wrong_no_na, wrong_no_nb, Ltime},
#else
{"get", too_few_2, Lget, wrong_no_2},
{"convert-to-evector", Lconvert_to_struct, too_many_1, wrong_no_1},
{"evectorp", Lstructp, too_many_1, wrong_no_1},
{"get*", too_few_2, Lget, wrong_no_2},
{"pairp", Lconsp, too_many_1, wrong_no_1},
/* I provide CONSP as well as PAIRP since otherwise I get muddled */
{"consp", Lconsp, too_many_1, wrong_no_1},
{"flag", too_few_2, Lflag, wrong_no_2},
{"flagp", too_few_2, Lflagp, wrong_no_2},
{"flagpcar", too_few_2, Lflagpcar, wrong_no_2},
{"flagp**", too_few_2, Lflagp, wrong_no_2},
{"remflag", too_few_2, Lremflag, wrong_no_2},
{"stringp", Lstringp, too_many_1, wrong_no_1},
{"threevectorp", Lthreevectorp, too_many_1, wrong_no_1},
{"vectorp", Lsimple_vectorp, too_many_1, wrong_no_1},
#endif
{NULL, 0, 0, 0}
};
/* end of fns1.c */