qbit/xenocara
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
cb56ed0c01
xenocara/app/xedit/lisp/core.c
matthieu a5fd897ecd update to xedit 1.2.1
2013-01-14 22:05:51 +00:00

7030 lines
144 KiB
C
Raw Blame History

/*
* Copyright (c) 2001 by The XFree86 Project, Inc.
*
* Permission is hereby granted, free of charge, to any person obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense,
* and/or sell copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
* THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
* WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
* OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
* SOFTWARE.
*
* Except as contained in this notice, the name of the XFree86 Project shall
* not be used in advertising or otherwise to promote the sale, use or other
* dealings in this Software without prior written authorization from the
* XFree86 Project.
*
* Author: Paulo César Pereira de Andrade
*/
/* $XFree86: xc/programs/xedit/lisp/core.c,v 1.71tsi Exp $ */
#include "lisp/io.h"
#include "lisp/core.h"
#include "lisp/format.h"
#include "lisp/helper.h"
#include "lisp/package.h"
#include "lisp/private.h"
#include "lisp/write.h"
/*
* Types
*/
typedef struct _SeqInfo {
LispType type;
union {
LispObj *list;
LispObj **vector;
unsigned char *string;
} data;
} SeqInfo;
#define SETSEQ(seq, object) \
switch (seq.type = XOBJECT_TYPE(object)) { \
case LispString_t: \
seq.data.string = (unsigned char*)THESTR(object); \
break; \
case LispCons_t: \
seq.data.list = object; \
break; \
default: \
seq.data.list = object->data.array.list; \
break; \
}
#ifdef __UNIXOS2__
# define finite(x) isfinite(x)
#endif
#ifdef NEED_SETENV
extern int setenv(const char *name, const char *value, int overwrite);
extern void unsetenv(const char *name);
#endif
/*
* Prototypes
*/
#define NONE 0
#define REMOVE 1
#define SUBSTITUTE 2
#define DELETE 3
#define NSUBSTITUTE 4
#define ASSOC 1
#define MEMBER 2
#define FIND 1
#define POSITION 2
#define IF 1
#define IFNOT 2
#define UNION 1
#define INTERSECTION 2
#define SETDIFFERENCE 3
#define SETEXCLUSIVEOR 4
#define SUBSETP 5
#define NSETDIFFERENCE 6
#define NINTERSECTION 7
#define NUNION 8
#define NSETEXCLUSIVEOR 9
#define COPY_LIST 1
#define COPY_ALIST 2
#define COPY_TREE 3
#define EVERY 1
#define SOME 2
#define NOTEVERY 3
#define NOTANY 4
/* Call directly LispObjectCompare() if possible */
#define FCODE(predicate) \
predicate == Oeql ? FEQL : \
predicate == Oequal ? FEQUAL : \
predicate == Oeq ? FEQ : \
predicate == Oequalp ? FEQUALP : 0
#define FCOMPARE(predicate, left, right, code) \
code == FEQ ? left == right : \
code ? LispObjectCompare(left, right, code) != NIL : \
APPLY2(predicate, left, right) != NIL
#define FUNCTION_CHECK(predicate) \
if (FUNCTIONP(predicate)) \
predicate = (predicate)->data.atom->object
#define CHECK_TEST_0() \
if (test != UNSPEC && test_not != UNSPEC) \
LispDestroy("%s: specify either :TEST or :TEST-NOT", \
STRFUN(builtin))
#define CHECK_TEST() \
CHECK_TEST_0(); \
if (test_not == UNSPEC) { \
if (test == UNSPEC) \
lambda = Oeql; \
else \
lambda = test; \
expect = 1; \
} \
else { \
lambda = test_not; \
expect = 0; \
} \
FUNCTION_CHECK(lambda); \
code = FCODE(lambda)
static LispObj *LispAdjoin(LispBuiltin*,
LispObj*, LispObj*, LispObj*, LispObj*, LispObj*);
static LispObj *LispAssocOrMember(LispBuiltin*, int, int);
static LispObj *LispEverySomeAnyNot(LispBuiltin*, int);
static LispObj *LispFindOrPosition(LispBuiltin*, int, int);
static LispObj *LispDeleteOrRemoveDuplicates(LispBuiltin*, int);
static LispObj *LispDeleteRemoveXSubstitute(LispBuiltin*, int, int);
static LispObj *LispListSet(LispBuiltin*, int);
static LispObj *LispMapc(LispBuiltin*, int);
static LispObj *LispMapl(LispBuiltin*, int);
static LispObj *LispMapnconc(LispObj*);
extern LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*);
extern LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*);
static LispObj *LispMergeSort(LispObj*, LispObj*, LispObj*, int);
static LispObj *LispXReverse(LispBuiltin*, int);
static LispObj *LispCopyList(LispBuiltin*, LispObj*, int);
static LispObj *LispValuesList(LispBuiltin*, int);
static LispObj *LispTreeEqual(LispObj*, LispObj*, LispObj*, int);
static LispDocType_t LispDocumentationType(LispBuiltin*, LispObj*);
extern void LispSetAtomObjectProperty(LispAtom*, LispObj*);
/*
* Initialization
*/
LispObj *Oeq, *Oeql, *Oequal, *Oequalp, *Omake_array,
*Kinitial_contents, *Osetf, *Ootherwise, *Oquote;
LispObj *Ogensym_counter;
Atom_id Svariable, Sstructure, Stype, Ssetf;
/*
* Implementation
*/
void
LispCoreInit(void)
{
Oeq = STATIC_ATOM("EQ");
Oeql = STATIC_ATOM("EQL");
Oequal = STATIC_ATOM("EQUAL");
Oequalp = STATIC_ATOM("EQUALP");
Omake_array = STATIC_ATOM("MAKE-ARRAY");
Kinitial_contents = KEYWORD("INITIAL-CONTENTS");
Osetf = STATIC_ATOM("SETF");
Ootherwise = STATIC_ATOM("OTHERWISE");
LispExportSymbol(Ootherwise);
Oquote = STATIC_ATOM("QUOTE");
LispExportSymbol(Oquote);
Svariable = GETATOMID("VARIABLE");
Sstructure = GETATOMID("STRUCTURE");
Stype = GETATOMID("TYPE");
/* Create as a constant so that only the C code should change the value */
Ogensym_counter = STATIC_ATOM("*GENSYM-COUNTER*");
LispDefconstant(Ogensym_counter, FIXNUM(0), NIL);
LispExportSymbol(Ogensym_counter);
Ssetf = ATOMID(Osetf);
}
LispObj *
Lisp_Acons(LispBuiltin *builtin)
/*
acons key datum alist
*/
{
LispObj *key, *datum, *alist;
alist = ARGUMENT(2);
datum = ARGUMENT(1);
key = ARGUMENT(0);
return (CONS(CONS(key, datum), alist));
}
static LispObj *
LispAdjoin(LispBuiltin*builtin, LispObj *item, LispObj *list,
LispObj *key, LispObj *test, LispObj *test_not)
{
GC_ENTER();
int code, expect, value;
LispObj *lambda, *compare, *object;
CHECK_LIST(list);
CHECK_TEST();
if (key != UNSPEC) {
item = APPLY1(key, item);
/* Result is not guaranteed to be gc protected */
GC_PROTECT(item);
}
/* Check if item is not already in place */
for (object = list; CONSP(object); object = CDR(object)) {
compare = CAR(object);
if (key != UNSPEC) {
compare = APPLY1(key, compare);
GC_PROTECT(compare);
value = FCOMPARE(lambda, item, compare, code);
/* Unprotect compare... */
--lisp__data.protect.length;
}
else
value = FCOMPARE(lambda, item, compare, code);
if (value == expect) {
/* Item is already in list */
GC_LEAVE();
return (list);
}
}
GC_LEAVE();
return (CONS(item, list));
}
LispObj *
Lisp_Adjoin(LispBuiltin *builtin)
/*
adjoin item list &key key test test-not
*/
{
LispObj *item, *list, *key, *test, *test_not;
test_not = ARGUMENT(4);
test = ARGUMENT(3);
key = ARGUMENT(2);
list = ARGUMENT(1);
item = ARGUMENT(0);
return (LispAdjoin(builtin, item, list, key, test, test_not));
}
LispObj *
Lisp_Append(LispBuiltin *builtin)
/*
append &rest lists
*/
{
GC_ENTER();
LispObj *result, *cons, *list;
LispObj *lists;
lists = ARGUMENT(0);
/* no arguments */
if (!CONSP(lists))
return (NIL);
/* skip initial nil lists */
for (; CONSP(CDR(lists)) && CAR(lists) == NIL; lists = CDR(lists))
;
/* last argument is not copied (even if it is the single argument) */
if (!CONSP(CDR(lists)))
return (CAR(lists));
/* make sure result is a list */
list = CAR(lists);
CHECK_CONS(list);
result = cons = CONS(CAR(list), NIL);
GC_PROTECT(result);
for (list = CDR(list); CONSP(list); list = CDR(list)) {
RPLACD(cons, CONS(CAR(list), NIL));
cons = CDR(cons);
}
lists = CDR(lists);
/* copy intermediate lists */
for (; CONSP(CDR(lists)); lists = CDR(lists)) {
list = CAR(lists);
if (list == NIL)
continue;
/* intermediate elements must be lists */
CHECK_CONS(list);
for (; CONSP(list); list = CDR(list)) {
RPLACD(cons, CONS(CAR(list), NIL));
cons = CDR(cons);
}
}
/* add last element */
RPLACD(cons, CAR(lists));
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Aref(LispBuiltin *builtin)
/*
aref array &rest subscripts
*/
{
long c, count, idx, seq;
LispObj *obj, *dim;
LispObj *array, *subscripts;
subscripts = ARGUMENT(1);
array = ARGUMENT(0);
/* accept strings also */
if (STRINGP(array) && CONSP(subscripts) && CDR(subscripts) == NIL) {
long offset, length = STRLEN(array);
CHECK_INDEX(CAR(subscripts));
offset = FIXNUM_VALUE(CAR(subscripts));
if (offset >= length)
LispDestroy("%s: index %ld too large for sequence length %ld",
STRFUN(builtin), offset, length);
return (SCHAR(THESTR(array)[offset]));
}
CHECK_ARRAY(array);
for (count = 0, dim = subscripts, obj = array->data.array.dim; CONSP(dim);
count++, dim = CDR(dim), obj = CDR(obj)) {
if (count >= array->data.array.rank)
LispDestroy("%s: too many subscripts %s",
STRFUN(builtin), STROBJ(subscripts));
if (!INDEXP(CAR(dim)) ||
FIXNUM_VALUE(CAR(dim)) >= FIXNUM_VALUE(CAR(obj)))
LispDestroy("%s: %s is out of range or a bad index",
STRFUN(builtin), STROBJ(CAR(dim)));
}
if (count < array->data.array.rank)
LispDestroy("%s: too few subscripts %s",
STRFUN(builtin), STROBJ(subscripts));
for (count = seq = 0, dim = subscripts; CONSP(dim); dim = CDR(dim), seq++) {
for (idx = 0, obj = array->data.array.dim; idx < seq;
obj = CDR(obj), ++idx)
;
for (c = 1, obj = CDR(obj); obj != NIL; obj = CDR(obj))
c *= FIXNUM_VALUE(CAR(obj));
count += c * FIXNUM_VALUE(CAR(dim));
}
for (array = array->data.array.list; count > 0; array = CDR(array), count--)
;
return (CAR(array));
}
static LispObj *
LispAssocOrMember(LispBuiltin *builtin, int function, int comparison)
/*
assoc item list &key test test-not key
assoc-if predicate list &key key
assoc-if-not predicate list &key key
member item list &key test test-not key
member-if predicate list &key key
member-if-not predicate list &key key
*/
{
int code = 0, expect, value;
LispObj *lambda, *result, *compare;
LispObj *item, *list, *test, *test_not, *key;
if (comparison == NONE) {
key = ARGUMENT(4);
test_not = ARGUMENT(3);
test = ARGUMENT(2);
list = ARGUMENT(1);
item = ARGUMENT(0);
lambda = NIL;
}
else {
key = ARGUMENT(2);
list = ARGUMENT(1);
lambda = ARGUMENT(0);
test = test_not = UNSPEC;
item = NIL;
}
if (list == NIL)
return (NIL);
CHECK_CONS(list);
/* Resolve compare function, and expected result of comparison */
if (comparison == NONE) {
CHECK_TEST();
}
else
expect = comparison == IFNOT ? 0 : 1;
result = NIL;
for (; CONSP(list); list = CDR(list)) {
compare = CAR(list);
if (function == ASSOC) {
if (!CONSP(compare))
continue;
compare = CAR(compare);
}
if (key != UNSPEC)
compare = APPLY1(key, compare);
if (comparison == NONE)
value = FCOMPARE(lambda, item, compare, code);
else
value = APPLY1(lambda, compare) != NIL;
if (value == expect) {
result = list;
if (function == ASSOC)
result = CAR(result);
break;
}
}
if (function == MEMBER) {
CHECK_LIST(list);
}
return (result);
}
LispObj *
Lisp_Assoc(LispBuiltin *builtin)
/*
assoc item list &key test test-not key
*/
{
return (LispAssocOrMember(builtin, ASSOC, NONE));
}
LispObj *
Lisp_AssocIf(LispBuiltin *builtin)
/*
assoc-if predicate list &key key
*/
{
return (LispAssocOrMember(builtin, ASSOC, IF));
}
LispObj *
Lisp_AssocIfNot(LispBuiltin *builtin)
/*
assoc-if-not predicate list &key key
*/
{
return (LispAssocOrMember(builtin, ASSOC, IFNOT));
}
LispObj *
Lisp_And(LispBuiltin *builtin)
/*
and &rest args
*/
{
LispObj *result = T, *args;
args = ARGUMENT(0);
for (; CONSP(args); args = CDR(args)) {
result = EVAL(CAR(args));
if (result == NIL)
break;
}
return (result);
}
LispObj *
Lisp_Apply(LispBuiltin *builtin)
/*
apply function arg &rest more-args
*/
{
GC_ENTER();
LispObj *result, *arguments;
LispObj *function, *arg, *more_args;
more_args = ARGUMENT(2);
arg = ARGUMENT(1);
function = ARGUMENT(0);
if (more_args == NIL) {
CHECK_LIST(arg);
arguments = arg;
for (; CONSP(arg); arg = CDR(arg))
;
CHECK_LIST(arg);
}
else {
LispObj *cons;
CHECK_CONS(more_args);
arguments = cons = CONS(arg, NIL);
GC_PROTECT(arguments);
for (arg = CDR(more_args);
CONSP(arg);
more_args = arg, arg = CDR(arg)) {
RPLACD(cons, CONS(CAR(more_args), NIL));
cons = CDR(cons);
}
more_args = CAR(more_args);
if (more_args != NIL) {
for (arg = more_args; CONSP(arg); arg = CDR(arg))
;
CHECK_LIST(arg);
RPLACD(cons, more_args);
}
}
result = APPLY(function, arguments);
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Atom(LispBuiltin *builtin)
/*
atom object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (CONSP(object) ? NIL : T);
}
LispObj *
Lisp_Block(LispBuiltin *builtin)
/*
block name &rest body
*/
{
int did_jump, *pdid_jump = &did_jump;
LispObj *res, **pres = &res;
LispBlock *block;
LispObj *name, *body;
body = ARGUMENT(1);
name = ARGUMENT(0);
if (!SYMBOLP(name) && name != NIL && name != T)
LispDestroy("%s: %s cannot name a block",
STRFUN(builtin), STROBJ(name));
*pres = NIL;
*pdid_jump = 1;
block = LispBeginBlock(name, LispBlockTag);
if (setjmp(block->jmp) == 0) {
for (; CONSP(body); body = CDR(body))
res = EVAL(CAR(body));
*pdid_jump = 0;
}
LispEndBlock(block);
if (*pdid_jump)
*pres = lisp__data.block.block_ret;
return (res);
}
LispObj *
Lisp_Boundp(LispBuiltin *builtin)
/*
boundp symbol
*/
{
LispAtom *atom;
LispObj *symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
atom = symbol->data.atom;
if (atom->package == lisp__data.keyword ||
(atom->a_object && atom->property->value != UNBOUND))
return (T);
return (NIL);
}
LispObj *
Lisp_Butlast(LispBuiltin *builtin)
/*
butlast list &optional count
*/
{
GC_ENTER();
long length, count;
LispObj *result, *cons, *list, *ocount;
ocount = ARGUMENT(1);
list = ARGUMENT(0);
CHECK_LIST(list);
if (ocount == UNSPEC)
count = 1;
else {
CHECK_INDEX(ocount);
count = FIXNUM_VALUE(ocount);
}
length = LispLength(list);
if (count == 0)
return (list);
else if (count >= length)
return (NIL);
length -= count + 1;
result = cons = CONS(CAR(list), NIL);
GC_PROTECT(result);
for (list = CDR(list); length > 0; list = CDR(list), length--) {
RPLACD(cons, CONS(CAR(list), NIL));
cons = CDR(cons);
}
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Nbutlast(LispBuiltin *builtin)
/*
nbutlast list &optional count
*/
{
long length, count;
LispObj *result, *list, *ocount;
ocount = ARGUMENT(1);
list = ARGUMENT(0);
CHECK_LIST(list);
if (ocount == UNSPEC)
count = 1;
else {
CHECK_INDEX(ocount);
count = FIXNUM_VALUE(ocount);
}
length = LispLength(list);
if (count == 0)
return (list);
else if (count >= length)
return (NIL);
length -= count + 1;
result = list;
for (; length > 0; list = CDR(list), length--)
;
RPLACD(list, NIL);
return (result);
}
LispObj *
Lisp_Car(LispBuiltin *builtin)
/*
car list
*/
{
LispObj *list, *result = NULL;
list = ARGUMENT(0);
if (list == NIL)
result = NIL;
else {
CHECK_CONS(list);
result = CAR(list);
}
return (result);
}
LispObj *
Lisp_Case(LispBuiltin *builtin)
/*
case keyform &rest body
*/
{
LispObj *result, *code, *keyform, *body, *form;
body = ARGUMENT(1);
keyform = ARGUMENT(0);
result = NIL;
keyform = EVAL(keyform);
for (; CONSP(body); body = CDR(body)) {
code = CAR(body);
CHECK_CONS(code);
form = CAR(code);
if (form == T || form == Ootherwise) {
if (CONSP(CDR(body)))
LispDestroy("%s: %s must be the last clause",
STRFUN(builtin), STROBJ(CAR(code)));
result = CDR(code);
break;
}
else if (CONSP(form)) {
for (; CONSP(form); form = CDR(form))
if (XEQL(keyform, CAR(form)) == T) {
result = CDR(code);
break;
}
if (CONSP(form)) /* if found match */
break;
}
else if (XEQL(keyform, form) == T) {
result = CDR(code);
break;
}
}
for (body = result; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
return (result);
}
LispObj *
Lisp_Catch(LispBuiltin *builtin)
/*
catch tag &rest body
*/
{
int did_jump, *pdid_jump = &did_jump;
LispObj *res, **pres = &res;
LispBlock *block;
LispObj *tag, *body;
body = ARGUMENT(1);
tag = ARGUMENT(0);
*pres = NIL;
*pdid_jump = 1;
block = LispBeginBlock(tag, LispBlockCatch);
if (setjmp(block->jmp) == 0) {
for (; CONSP(body); body = CDR(body))
res = EVAL(CAR(body));
*pdid_jump = 0;
}
LispEndBlock(block);
if (*pdid_jump)
*pres = lisp__data.block.block_ret;
return (res);
}
LispObj *
Lisp_Coerce(LispBuiltin *builtin)
/*
coerce object result-type
*/
{
LispObj *object, *result_type;
result_type = ARGUMENT(1);
object = ARGUMENT(0);
return (LispCoerce(builtin, object, result_type));
}
LispObj *
Lisp_Cdr(LispBuiltin *builtin)
/*
cdr list
*/
{
LispObj *list, *result = NULL;
list = ARGUMENT(0);
if (list == NIL)
result = NIL;
else {
CHECK_CONS(list);
result = CDR(list);
}
return (result);
}
LispObj *
Lisp_C_r(LispBuiltin *builtin)
/*
c[ad]{2,4}r list
*/
{
char *desc;
LispObj *list, *result = NULL;
list = ARGUMENT(0);
result = list;
desc = STRFUN(builtin);
while (desc[1] != 'R')
++desc;
while (*desc != 'C') {
if (result == NIL)
break;
CHECK_CONS(result);
result = *desc == 'A' ? CAR(result) : CDR(result);
--desc;
}
return (result);
}
LispObj *
Lisp_Cond(LispBuiltin *builtin)
/*
cond &rest body
*/
{
LispObj *result, *code, *body;
body = ARGUMENT(0);
result = NIL;
for (; CONSP(body); body = CDR(body)) {
code = CAR(body);
CHECK_CONS(code);
result = EVAL(CAR(code));
if (result == NIL)
continue;
for (code = CDR(code); CONSP(code); code = CDR(code))
result = EVAL(CAR(code));
break;
}
return (result);
}
static LispObj *
LispCopyList(LispBuiltin *builtin, LispObj *list, int function)
{
GC_ENTER();
LispObj *result, *cons;
if (list == NIL)
return (list);
CHECK_CONS(list);
result = cons = CONS(NIL, NIL);
GC_PROTECT(result);
if (CONSP(CAR(list))) {
switch (function) {
case COPY_LIST:
RPLACA(result, CAR(list));
break;
case COPY_ALIST:
RPLACA(result, CONS(CAR(CAR(list)), CDR(CAR(list))));
break;
case COPY_TREE:
RPLACA(result, LispCopyList(builtin, CAR(list), COPY_TREE));
break;
}
}
else
RPLACA(result, CAR(list));
for (list = CDR(list); CONSP(list); list = CDR(list)) {
CDR(cons) = CONS(NIL, NIL);
cons = CDR(cons);
if (CONSP(CAR(list))) {
switch (function) {
case COPY_LIST:
RPLACA(cons, CAR(list));
break;
case COPY_ALIST:
RPLACA(cons, CONS(CAR(CAR(list)), CDR(CAR(list))));
break;
case COPY_TREE:
RPLACA(cons, LispCopyList(builtin, CAR(list), COPY_TREE));
break;
}
}
else
RPLACA(cons, CAR(list));
}
/* in case list is dotted */
RPLACD(cons, list);
GC_LEAVE();
return (result);
}
LispObj *
Lisp_CopyAlist(LispBuiltin *builtin)
/*
copy-alist list
*/
{
LispObj *list;
list = ARGUMENT(0);
return (LispCopyList(builtin, list, COPY_ALIST));
}
LispObj *
Lisp_CopyList(LispBuiltin *builtin)
/*
copy-list list
*/
{
LispObj *list;
list = ARGUMENT(0);
return (LispCopyList(builtin, list, COPY_LIST));
}
LispObj *
Lisp_CopyTree(LispBuiltin *builtin)
/*
copy-tree list
*/
{
LispObj *list;
list = ARGUMENT(0);
return (LispCopyList(builtin, list, COPY_TREE));
}
LispObj *
Lisp_Cons(LispBuiltin *builtin)
/*
cons car cdr
*/
{
LispObj *car, *cdr;
cdr = ARGUMENT(1);
car = ARGUMENT(0);
return (CONS(car, cdr));
}
LispObj *
Lisp_Consp(LispBuiltin *builtin)
/*
consp object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (CONSP(object) ? T : NIL);
}
LispObj *
Lisp_Constantp(LispBuiltin *builtin)
/*
constantp form &optional environment
*/
{
LispObj *form;
form = ARGUMENT(0);
/* not all self-evaluating objects are considered constants */
if (!POINTERP(form) ||
NUMBERP(form) ||
XQUOTEP(form) ||
(XCONSP(form) && CAR(form) == Oquote) ||
(XSYMBOLP(form) && form->data.atom->constant) ||
XSTRINGP(form) ||
XARRAYP(form))
return (T);
return (NIL);
}
LispObj *
Lisp_Defconstant(LispBuiltin *builtin)
/*
defconstant name initial-value &optional documentation
*/
{
LispObj *name, *initial_value, *documentation;
documentation = ARGUMENT(2);
initial_value = ARGUMENT(1);
name = ARGUMENT(0);
CHECK_SYMBOL(name);
if (documentation != UNSPEC) {
CHECK_STRING(documentation);
}
else
documentation = NIL;
LispDefconstant(name, EVAL(initial_value), documentation);
return (name);
}
LispObj *
Lisp_Defmacro(LispBuiltin *builtin)
/*
defmacro name lambda-list &rest body
*/
{
LispArgList *alist;
LispObj *lambda, *name, *lambda_list, *body;
body = ARGUMENT(2);
lambda_list = ARGUMENT(1);
name = ARGUMENT(0);
CHECK_SYMBOL(name);
alist = LispCheckArguments(LispMacro, lambda_list, ATOMID(name)->value, 0);
if (CONSP(body) && STRINGP(CAR(body))) {
LispAddDocumentation(name, CAR(body), LispDocFunction);
body = CDR(body);
}
lambda_list = LispListProtectedArguments(alist);
lambda = LispNewLambda(name, body, lambda_list, LispMacro);
if (name->data.atom->a_builtin || name->data.atom->a_compiled) {
if (name->data.atom->a_builtin) {
ERROR_CHECK_SPECIAL_FORM(name->data.atom);
}
/* redefining these may cause surprises if bytecode
* compiled functions references them */
LispWarning("%s: %s is being redefined", STRFUN(builtin),
ATOMID(name)->value);
LispRemAtomBuiltinProperty(name->data.atom);
}
LispSetAtomFunctionProperty(name->data.atom, lambda, alist);
LispUseArgList(alist);
return (name);
}
LispObj *
Lisp_Defun(LispBuiltin *builtin)
/*
defun name lambda-list &rest body
*/
{
LispArgList *alist;
LispObj *lambda, *name, *lambda_list, *body;
body = ARGUMENT(2);
lambda_list = ARGUMENT(1);
name = ARGUMENT(0);
CHECK_SYMBOL(name);
alist = LispCheckArguments(LispFunction, lambda_list, ATOMID(name)->value, 0);
if (CONSP(body) && STRINGP(CAR(body))) {
LispAddDocumentation(name, CAR(body), LispDocFunction);
body = CDR(body);
}
lambda_list = LispListProtectedArguments(alist);
lambda = LispNewLambda(name, body, lambda_list, LispFunction);
if (name->data.atom->a_builtin || name->data.atom->a_compiled) {
if (name->data.atom->a_builtin) {
ERROR_CHECK_SPECIAL_FORM(name->data.atom);
}
/* redefining these may cause surprises if bytecode
* compiled functions references them */
LispWarning("%s: %s is being redefined", STRFUN(builtin),
ATOMID(name)->value);
LispRemAtomBuiltinProperty(name->data.atom);
}
LispSetAtomFunctionProperty(name->data.atom, lambda, alist);
LispUseArgList(alist);
return (name);
}
LispObj *
Lisp_Defsetf(LispBuiltin *builtin)
/*
defsetf function lambda-list &rest body
*/
{
LispArgList *alist;
LispObj *obj;
LispObj *lambda, *function, *lambda_list, *store, *body;
body = ARGUMENT(2);
lambda_list = ARGUMENT(1);
function = ARGUMENT(0);
CHECK_SYMBOL(function);
if (body == NIL || (CONSP(body) && STRINGP(CAR(body)))) {
if (!SYMBOLP(lambda_list))
LispDestroy("%s: syntax error %s %s",
STRFUN(builtin), STROBJ(function), STROBJ(lambda_list));
if (body != NIL)
LispAddDocumentation(function, CAR(body), LispDocSetf);
LispSetAtomSetfProperty(function->data.atom, lambda_list, NULL);
return (function);
}
alist = LispCheckArguments(LispSetf, lambda_list, ATOMID(function)->value, 0);
store = CAR(body);
if (!CONSP(store))
LispDestroy("%s: %s is a bad store value",
STRFUN(builtin), STROBJ(store));
for (obj = store; CONSP(obj); obj = CDR(obj)) {
CHECK_SYMBOL(CAR(obj));
}
body = CDR(body);
if (CONSP(body) && STRINGP(CAR(body))) {
LispAddDocumentation(function, CAR(body), LispDocSetf);
body = CDR(body);
}
lambda = LispNewLambda(function, body, store, LispSetf);
LispSetAtomSetfProperty(function->data.atom, lambda, alist);
LispUseArgList(alist);
return (function);
}
LispObj *
Lisp_Defparameter(LispBuiltin *builtin)
/*
defparameter name initial-value &optional documentation
*/
{
LispObj *name, *initial_value, *documentation;
documentation = ARGUMENT(2);
initial_value = ARGUMENT(1);
name = ARGUMENT(0);
CHECK_SYMBOL(name);
if (documentation != UNSPEC) {
CHECK_STRING(documentation);
}
else
documentation = NIL;
LispProclaimSpecial(name, EVAL(initial_value), documentation);
return (name);
}
LispObj *
Lisp_Defvar(LispBuiltin *builtin)
/*
defvar name &optional initial-value documentation
*/
{
LispObj *name, *initial_value, *documentation;
documentation = ARGUMENT(2);
initial_value = ARGUMENT(1);
name = ARGUMENT(0);
CHECK_SYMBOL(name);
if (documentation != UNSPEC) {
CHECK_STRING(documentation);
}
else
documentation = NIL;
LispProclaimSpecial(name,
initial_value != UNSPEC ? EVAL(initial_value) : NULL,
documentation);
return (name);
}
LispObj *
Lisp_Delete(LispBuiltin *builtin)
/*
delete item sequence &key from-end test test-not start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, DELETE, NONE));
}
LispObj *
Lisp_DeleteIf(LispBuiltin *builtin)
/*
delete-if predicate sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, DELETE, IF));
}
LispObj *
Lisp_DeleteIfNot(LispBuiltin *builtin)
/*
delete-if-not predicate sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, DELETE, IFNOT));
}
LispObj *
Lisp_DeleteDuplicates(LispBuiltin *builtin)
/*
delete-duplicates sequence &key from-end test test-not start end key
*/
{
return (LispDeleteOrRemoveDuplicates(builtin, DELETE));
}
LispObj *
Lisp_Do(LispBuiltin *builtin)
/*
do init test &rest body
*/
{
return (LispDo(builtin, 0));
}
LispObj *
Lisp_DoP(LispBuiltin *builtin)
/*
do* init test &rest body
*/
{
return (LispDo(builtin, 1));
}
static LispDocType_t
LispDocumentationType(LispBuiltin *builtin, LispObj *type)
{
Atom_id atom;
LispDocType_t doc_type = LispDocVariable;
CHECK_SYMBOL(type);
atom = ATOMID(type);
if (atom == Svariable)
doc_type = LispDocVariable;
else if (atom == Sfunction)
doc_type = LispDocFunction;
else if (atom == Sstructure)
doc_type = LispDocStructure;
else if (atom == Stype)
doc_type = LispDocType;
else if (atom == Ssetf)
doc_type = LispDocSetf;
else {
LispDestroy("%s: unknown documentation type %s",
STRFUN(builtin), STROBJ(type));
/*NOTREACHED*/
}
return (doc_type);
}
LispObj *
Lisp_Documentation(LispBuiltin *builtin)
/*
documentation symbol type
*/
{
LispObj *symbol, *type;
type = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
/* type is checked in LispDocumentationType() */
return (LispGetDocumentation(symbol, LispDocumentationType(builtin, type)));
}
LispObj *
Lisp_DoList(LispBuiltin *builtin)
{
return (LispDoListTimes(builtin, 0));
}
LispObj *
Lisp_DoTimes(LispBuiltin *builtin)
{
return (LispDoListTimes(builtin, 1));
}
LispObj *
Lisp_Elt(LispBuiltin *builtin)
/*
elt sequence index
svref sequence index
*/
{
long offset, length;
LispObj *result, *sequence, *oindex;
oindex = ARGUMENT(1);
sequence = ARGUMENT(0);
length = LispLength(sequence);
CHECK_INDEX(oindex);
offset = FIXNUM_VALUE(oindex);
if (offset >= length)
LispDestroy("%s: index %ld too large for sequence length %ld",
STRFUN(builtin), offset, length);
if (STRINGP(sequence))
result = SCHAR(THESTR(sequence)[offset]);
else {
if (ARRAYP(sequence))
sequence = sequence->data.array.list;
for (; offset > 0; offset--, sequence = CDR(sequence))
;
result = CAR(sequence);
}
return (result);
}
LispObj *
Lisp_Endp(LispBuiltin *builtin)
/*
endp object
*/
{
LispObj *object;
object = ARGUMENT(0);
if (object == NIL)
return (T);
CHECK_CONS(object);
return (NIL);
}
LispObj *
Lisp_Eq(LispBuiltin *builtin)
/*
eq left right
*/
{
LispObj *left, *right;
right = ARGUMENT(1);
left = ARGUMENT(0);
return (XEQ(left, right));
}
LispObj *
Lisp_Eql(LispBuiltin *builtin)
/*
eql left right
*/
{
LispObj *left, *right;
right = ARGUMENT(1);
left = ARGUMENT(0);
return (XEQL(left, right));
}
LispObj *
Lisp_Equal(LispBuiltin *builtin)
/*
equal left right
*/
{
LispObj *left, *right;
right = ARGUMENT(1);
left = ARGUMENT(0);
return (XEQUAL(left, right));
}
LispObj *
Lisp_Equalp(LispBuiltin *builtin)
/*
equalp left right
*/
{
LispObj *left, *right;
right = ARGUMENT(1);
left = ARGUMENT(0);
return (XEQUALP(left, right));
}
LispObj *
Lisp_Error(LispBuiltin *builtin)
/*
error control-string &rest arguments
*/
{
LispObj *string, *arglist;
LispObj *control_string, *arguments;
arguments = ARGUMENT(1);
control_string = ARGUMENT(0);
arglist = CONS(NIL, CONS(control_string, arguments));
GC_PROTECT(arglist);
string = APPLY(Oformat, arglist);
LispDestroy("%s", THESTR(string));
/*NOTREACHED*/
/* No need to call GC_ENTER() and GC_LEAVE() macros */
return (NIL);
}
LispObj *
Lisp_Eval(LispBuiltin *builtin)
/*
eval form
*/
{
int lex;
LispObj *form, *result;
form = ARGUMENT(0);
/* make sure eval form will not access local variables */
lex = lisp__data.env.lex;
lisp__data.env.lex = lisp__data.env.length;
result = EVAL(form);
lisp__data.env.lex = lex;
return (result);
}
static LispObj *
LispEverySomeAnyNot(LispBuiltin *builtin, int function)
/*
every predicate sequence &rest more-sequences
some predicate sequence &rest more-sequences
notevery predicate sequence &rest more-sequences
notany predicate sequence &rest more-sequences
*/
{
GC_ENTER();
long i, j, length, count;
LispObj *result, *list, *item, *arguments, *acons, *value;
SeqInfo stk[8], *seqs;
LispObj *predicate, *sequence, *more_sequences;
more_sequences = ARGUMENT(2);
sequence = ARGUMENT(1);
predicate = ARGUMENT(0);
count = 1;
length = LispLength(sequence);
for (list = more_sequences; CONSP(list); list = CDR(list), count++) {
i = LispLength(CAR(list));
if (i < length)
length = i;
}
result = function == EVERY || function == NOTANY ? T : NIL;
/* if at least one sequence has length zero */
if (length == 0)
return (result);
if (count > sizeof(stk) / sizeof(stk[0]))
seqs = LispMalloc(count * sizeof(SeqInfo));
else
seqs = &stk[0];
/* build information about sequences */
SETSEQ(seqs[0], sequence);
for (i = 1, list = more_sequences; CONSP(list); list = CDR(list), i++) {
item = CAR(list);
SETSEQ(seqs[i], item);
}
/* prepare argument list */
arguments = acons = CONS(NIL, NIL);
GC_PROTECT(arguments);
for (i = 1; i < count; i++) {
RPLACD(acons, CONS(NIL, NIL));
acons = CDR(acons);
}
/* loop applying predicate in sequence elements */
for (i = 0; i < length; i++) {
/* build argument list */
for (acons = arguments, j = 0; j < count; acons = CDR(acons), j++) {
if (seqs[j].type == LispString_t)
item = SCHAR(*seqs[j].data.string++);
else {
item = CAR(seqs[j].data.list);
seqs[j].data.list = CDR(seqs[j].data.list);
}
RPLACA(acons, item);
}
/* apply predicate */
value = APPLY(predicate, arguments);
/* check if needs to terminate loop */
if (value == NIL) {
if (function == EVERY) {
result = NIL;
break;
}
if (function == NOTEVERY) {
result = T;
break;
}
}
else {
if (function == SOME) {
result = value;
break;
}
if (function == NOTANY) {
result = NIL;
break;
}
}
}
GC_LEAVE();
if (seqs != &stk[0])
LispFree(seqs);
return (result);
}
LispObj *
Lisp_Every(LispBuiltin *builtin)
/*
every predicate sequence &rest more-sequences
*/
{
return (LispEverySomeAnyNot(builtin, EVERY));
}
LispObj *
Lisp_Some(LispBuiltin *builtin)
/*
some predicate sequence &rest more-sequences
*/
{
return (LispEverySomeAnyNot(builtin, SOME));
}
LispObj *
Lisp_Notevery(LispBuiltin *builtin)
/*
notevery predicate sequence &rest more-sequences
*/
{
return (LispEverySomeAnyNot(builtin, NOTEVERY));
}
LispObj *
Lisp_Notany(LispBuiltin *builtin)
/*
notany predicate sequence &rest more-sequences
*/
{
return (LispEverySomeAnyNot(builtin, NOTANY));
}
LispObj *
Lisp_Fboundp(LispBuiltin *builtin)
/*
fboundp symbol
*/
{
LispAtom *atom;
LispObj *symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
atom = symbol->data.atom;
if (atom->a_function || atom->a_builtin || atom->a_compiled)
return (T);
return (NIL);
}
LispObj *
Lisp_Find(LispBuiltin *builtin)
/*
find item sequence &key from-end test test-not start end key
*/
{
return (LispFindOrPosition(builtin, FIND, NONE));
}
LispObj *
Lisp_FindIf(LispBuiltin *builtin)
/*
find-if predicate sequence &key from-end start end key
*/
{
return (LispFindOrPosition(builtin, FIND, IF));
}
LispObj *
Lisp_FindIfNot(LispBuiltin *builtin)
/*
find-if-not predicate sequence &key from-end start end key
*/
{
return (LispFindOrPosition(builtin, FIND, IFNOT));
}
LispObj *
Lisp_Fill(LispBuiltin *builtin)
/*
fill sequence item &key start end
*/
{
long i, start, end, length;
LispObj *sequence, *item, *ostart, *oend;
oend = ARGUMENT(3);
ostart = ARGUMENT(2);
item = ARGUMENT(1);
sequence = ARGUMENT(0);
LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
&start, &end, &length);
if (STRINGP(sequence)) {
int ch;
char *string = THESTR(sequence);
CHECK_STRING_WRITABLE(sequence);
CHECK_SCHAR(item);
ch = SCHAR_VALUE(item);
for (i = start; i < end; i++)
string[i] = ch;
}
else {
LispObj *list;
if (CONSP(sequence))
list = sequence;
else
list = sequence->data.array.list;
for (i = 0; i < start; i++, list = CDR(list))
;
for (; i < end; i++, list = CDR(list))
RPLACA(list, item);
}
return (sequence);
}
LispObj *
Lisp_Fmakunbound(LispBuiltin *builtin)
/*
fmkaunbound symbol
*/
{
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
if (symbol->data.atom->a_function)
LispRemAtomFunctionProperty(symbol->data.atom);
else if (symbol->data.atom->a_builtin)
LispRemAtomBuiltinProperty(symbol->data.atom);
else if (symbol->data.atom->a_compiled)
LispRemAtomCompiledProperty(symbol->data.atom);
return (symbol);
}
LispObj *
Lisp_Funcall(LispBuiltin *builtin)
/*
funcall function &rest arguments
*/
{
LispObj *result;
LispObj *function, *arguments;
arguments = ARGUMENT(1);
function = ARGUMENT(0);
result = APPLY(function, arguments);
return (result);
}
LispObj *
Lisp_Functionp(LispBuiltin *builtin)
/*
functionp object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (FUNCTIONP(object) || LAMBDAP(object) ? T : NIL);
}
LispObj *
Lisp_Get(LispBuiltin *builtin)
/*
get symbol indicator &optional default
*/
{
LispObj *result;
LispObj *symbol, *indicator, *defalt;
defalt = ARGUMENT(2);
indicator = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
result = LispGetAtomProperty(symbol->data.atom, indicator);
if (result != NIL)
result = CAR(result);
else
result = defalt == UNSPEC ? NIL : defalt;
return (result);
}
/*
* ext::getenv
*/
LispObj *
Lisp_Getenv(LispBuiltin *builtin)
/*
getenv name
*/
{
char *value;
LispObj *name;
name = ARGUMENT(0);
CHECK_STRING(name);
value = getenv(THESTR(name));
return (value ? STRING(value) : NIL);
}
LispObj *
Lisp_Gc(LispBuiltin *builtin)
/*
gc &optional car cdr
*/
{
LispObj *car, *cdr;
cdr = ARGUMENT(1);
car = ARGUMENT(0);
LispGC(car, cdr);
return (NIL);
}
LispObj *
Lisp_Gensym(LispBuiltin *builtin)
/*
gensym &optional arg
*/
{
char *preffix = "G", name[132];
long counter = LONGINT_VALUE(Ogensym_counter->data.atom->property->value);
LispObj *symbol;
LispObj *arg;
arg = ARGUMENT(0);
if (arg != UNSPEC) {
if (STRINGP(arg))
preffix = THESTR(arg);
else {
CHECK_INDEX(arg);
counter = FIXNUM_VALUE(arg);
}
}
snprintf(name, sizeof(name), "%s%ld", preffix, counter);
if (strlen(name) >= 128)
LispDestroy("%s: name %s too long", STRFUN(builtin), name);
Ogensym_counter->data.atom->property->value = INTEGER(counter + 1);
symbol = UNINTERNED_ATOM(name);
symbol->data.atom->unreadable = !LispCheckAtomString(name);
return (symbol);
}
LispObj *
Lisp_Go(LispBuiltin *builtin)
/*
go tag
*/
{
unsigned blevel = lisp__data.block.block_level;
LispObj *tag;
tag = ARGUMENT(0);
while (blevel) {
LispBlock *block = lisp__data.block.block[--blevel];
if (block->type == LispBlockClosure)
/* if reached a function call */
break;
if (block->type == LispBlockBody) {
lisp__data.block.block_ret = tag;
LispBlockUnwind(block);
BLOCKJUMP(block);
}
}
LispDestroy("%s: no visible tagbody for %s",
STRFUN(builtin), STROBJ(tag));
/*NOTREACHED*/
return (NIL);
}
LispObj *
Lisp_If(LispBuiltin *builtin)
/*
if test then &optional else
*/
{
LispObj *result, *test, *then, *oelse;
oelse = ARGUMENT(2);
then = ARGUMENT(1);
test = ARGUMENT(0);
test = EVAL(test);
if (test != NIL)
result = EVAL(then);
else if (oelse != UNSPEC)
result = EVAL(oelse);
else
result = NIL;
return (result);
}
LispObj *
Lisp_IgnoreErrors(LispBuiltin *builtin)
/*
ignore-erros &rest body
*/
{
LispObj *result;
int i, jumped;
LispBlock *block;
/* interpreter state */
GC_ENTER();
int stack, lex, length;
/* memory allocation */
int mem_level;
void **mem;
LispObj *body;
body = ARGUMENT(0);
/* Save environment information */
stack = lisp__data.stack.length;
lex = lisp__data.env.lex;
length = lisp__data.env.length;
/* Save memory allocation information */
mem_level = lisp__data.mem.level;
mem = LispMalloc(mem_level * sizeof(void*));
memcpy(mem, lisp__data.mem.mem, mem_level * sizeof(void*));
++lisp__data.ignore_errors;
result = NIL;
jumped = 1;
block = LispBeginBlock(NIL, LispBlockProtect);
if (setjmp(block->jmp) == 0) {
for (; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
jumped = 0;
}
LispEndBlock(block);
if (!lisp__data.destroyed && jumped)
result = lisp__data.block.block_ret;
if (lisp__data.destroyed) {
/* Restore environment */
lisp__data.stack.length = stack;
lisp__data.env.lex = lex;
lisp__data.env.head = lisp__data.env.length = length;
GC_LEAVE();
/* Check for possible leaks due to ignoring errors */
for (i = 0; i < mem_level; i++) {
if (lisp__data.mem.mem[i] && mem[i] != lisp__data.mem.mem[i])
LispFree(lisp__data.mem.mem[i]);
}
for (; i < lisp__data.mem.level; i++) {
if (lisp__data.mem.mem[i])
LispFree(lisp__data.mem.mem[i]);
}
lisp__data.destroyed = 0;
result = NIL;
RETURN_COUNT = 1;
RETURN(0) = lisp__data.error_condition;
}
LispFree(mem);
--lisp__data.ignore_errors;
return (result);
}
LispObj *
Lisp_Intersection(LispBuiltin *builtin)
/*
intersection list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, INTERSECTION));
}
LispObj *
Lisp_Nintersection(LispBuiltin *builtin)
/*
nintersection list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, NINTERSECTION));
}
LispObj *
Lisp_Keywordp(LispBuiltin *builtin)
/*
keywordp object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (KEYWORDP(object) ? T : NIL);
}
LispObj *
Lisp_Lambda(LispBuiltin *builtin)
/*
lambda lambda-list &rest body
*/
{
GC_ENTER();
LispObj *name;
LispArgList *alist;
LispObj *lambda, *lambda_list, *body;
body = ARGUMENT(1);
lambda_list = ARGUMENT(0);
alist = LispCheckArguments(LispLambda, lambda_list, Snil->value, 0);
name = OPAQUE(alist, LispArgList_t);
lambda_list = LispListProtectedArguments(alist);
GC_PROTECT(name);
GC_PROTECT(lambda_list);
lambda = LispNewLambda(name, body, lambda_list, LispLambda);
LispUseArgList(alist);
GC_LEAVE();
return (lambda);
}
LispObj *
Lisp_Last(LispBuiltin *builtin)
/*
last list &optional count
*/
{
long count, length;
LispObj *list, *ocount;
ocount = ARGUMENT(1);
list = ARGUMENT(0);
if (!CONSP(list))
return (list);
length = LispLength(list);
if (ocount == UNSPEC)
count = 1;
else {
CHECK_INDEX(ocount);
count = FIXNUM_VALUE(ocount);
}
if (count >= length)
return (list);
length -= count;
for (; length > 0; length--)
list = CDR(list);
return (list);
}
LispObj *
Lisp_Length(LispBuiltin *builtin)
/*
length sequence
*/
{
LispObj *sequence;
sequence = ARGUMENT(0);
return (FIXNUM(LispLength(sequence)));
}
LispObj *
Lisp_Let(LispBuiltin *builtin)
/*
let init &rest body
*/
{
GC_ENTER();
int head = lisp__data.env.length;
LispObj *init, *body, *pair, *result, *list, *cons = NIL;
body = ARGUMENT(1);
init = ARGUMENT(0);
CHECK_LIST(init);
for (list = NIL; CONSP(init); init = CDR(init)) {
LispObj *symbol, *value;
pair = CAR(init);
if (SYMBOLP(pair)) {
symbol = pair;
value = NIL;
}
else {
CHECK_CONS(pair);
symbol = CAR(pair);
CHECK_SYMBOL(symbol);
pair = CDR(pair);
if (CONSP(pair)) {
value = CAR(pair);
if (CDR(pair) != NIL)
LispDestroy("%s: too much arguments to initialize %s",
STRFUN(builtin), STROBJ(symbol));
value = EVAL(value);
}
else
value = NIL;
}
pair = CONS(symbol, value);
if (list == NIL) {
list = cons = CONS(pair, NIL);
GC_PROTECT(list);
}
else {
RPLACD(cons, CONS(pair, NIL));
cons = CDR(cons);
}
}
/* Add variables */
for (; CONSP(list); list = CDR(list)) {
pair = CAR(list);
CHECK_CONSTANT(CAR(pair));
LispAddVar(CAR(pair), CDR(pair));
++lisp__data.env.head;
}
/* Values of symbols are now protected */
GC_LEAVE();
/* execute body */
for (result = NIL; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
lisp__data.env.head = lisp__data.env.length = head;
return (result);
}
LispObj *
Lisp_LetP(LispBuiltin *builtin)
/*
let* init &rest body
*/
{
int head = lisp__data.env.length;
LispObj *init, *body, *pair, *result;
body = ARGUMENT(1);
init = ARGUMENT(0);
CHECK_LIST(init);
for (; CONSP(init); init = CDR(init)) {
LispObj *symbol, *value;
pair = CAR(init);
if (SYMBOLP(pair)) {
symbol = pair;
value = NIL;
}
else {
CHECK_CONS(pair);
symbol = CAR(pair);
CHECK_SYMBOL(symbol);
pair = CDR(pair);
if (CONSP(pair)) {
value = CAR(pair);
if (CDR(pair) != NIL)
LispDestroy("%s: too much arguments to initialize %s",
STRFUN(builtin), STROBJ(symbol));
value = EVAL(value);
}
else
value = NIL;
}
CHECK_CONSTANT(symbol);
LispAddVar(symbol, value);
++lisp__data.env.head;
}
/* execute body */
for (result = NIL; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
lisp__data.env.head = lisp__data.env.length = head;
return (result);
}
LispObj *
Lisp_List(LispBuiltin *builtin)
/*
list &rest args
*/
{
LispObj *args;
args = ARGUMENT(0);
return (args);
}
LispObj *
Lisp_ListP(LispBuiltin *builtin)
/*
list* object &rest more-objects
*/
{
GC_ENTER();
LispObj *result, *cons;
LispObj *object, *more_objects;
more_objects = ARGUMENT(1);
object = ARGUMENT(0);
if (!CONSP(more_objects))
return (object);
result = cons = CONS(object, CAR(more_objects));
GC_PROTECT(result);
for (more_objects = CDR(more_objects); CONSP(more_objects);
more_objects = CDR(more_objects)) {
object = CAR(more_objects);
RPLACD(cons, CONS(CDR(cons), object));
cons = CDR(cons);
}
GC_LEAVE();
return (result);
}
/* "classic" list-length */
LispObj *
Lisp_ListLength(LispBuiltin *builtin)
/*
list-length list
*/
{
long length;
LispObj *fast, *slow;
LispObj *list;
list = ARGUMENT(0);
CHECK_LIST(list);
for (fast = slow = list, length = 0;
CONSP(slow);
slow = CDR(slow), length += 2) {
if (fast == NIL)
break;
CHECK_CONS(fast);
fast = CDR(fast);
if (fast == NIL) {
++length;
break;
}
CHECK_CONS(fast);
fast = CDR(fast);
if (slow == fast)
/* circular list */
return (NIL);
}
return (FIXNUM(length));
}
LispObj *
Lisp_Listp(LispBuiltin *builtin)
/*
listp object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (object == NIL || CONSP(object) ? T : NIL);
}
static LispObj *
LispListSet(LispBuiltin *builtin, int function)
/*
intersection list1 list2 &key test test-not key
nintersection list1 list2 &key test test-not key
set-difference list1 list2 &key test test-not key
nset-difference list1 list2 &key test test-not key
set-exclusive-or list1 list2 &key test test-not key
nset-exclusive-or list1 list2 &key test test-not key
subsetp list1 list2 &key test test-not key
union list1 list2 &key test test-not key
nunion list1 list2 &key test test-not key
*/
{
GC_ENTER();
int code, expect, value, inplace, check_list2,
intersection, setdifference, xunion, setexclusiveor;
LispObj *lambda, *result, *cmp, *cmp1, *cmp2,
*item, *clist1, *clist2, *cons, *cdr;
LispObj *list1, *list2, *test, *test_not, *key;
key = ARGUMENT(4);
test_not = ARGUMENT(3);
test = ARGUMENT(2);
list2 = ARGUMENT(1);
list1 = ARGUMENT(0);
/* Check if arguments are valid lists */
CHECK_LIST(list1);
CHECK_LIST(list2);
setdifference = intersection = xunion = setexclusiveor = inplace = 0;
switch (function) {
case NSETDIFFERENCE:
inplace = 1;
case SETDIFFERENCE:
setdifference = 1;
break;
case NINTERSECTION:
inplace = 1;
case INTERSECTION:
intersection = 1;
break;
case NUNION:
inplace = 1;
case UNION:
xunion = 1;
break;
case NSETEXCLUSIVEOR:
inplace = 1;
case SETEXCLUSIVEOR:
setexclusiveor = 1;
break;
}
/* Check for fast return */
if (list1 == NIL)
return (setdifference || intersection ?
NIL : function == SUBSETP ? T : list2);
if (list2 == NIL)
return (intersection || xunion || function == SUBSETP ? NIL : list1);
CHECK_TEST();
clist1 = cdr = NIL;
/* Make a copy of list2 with the key predicate applied */
if (key != UNSPEC) {
result = cons = CONS(APPLY1(key, CAR(list2)), NIL);
GC_PROTECT(result);
for (cmp2 = CDR(list2); CONSP(cmp2); cmp2 = CDR(cmp2)) {
item = APPLY1(key, CAR(cmp2));
RPLACD(cons, CONS(APPLY1(key, CAR(cmp2)), NIL));
cons = CDR(cons);
}
/* check if list2 is a proper list */
CHECK_LIST(cmp2);
clist2 = result;
check_list2 = 0;
}
else {
clist2 = list2;
check_list2 = 1;
}
result = cons = NIL;
/* Compare elements of lists
* Logic:
* UNION
* 1) Walk list1 and if CAR(list1) not in list2, add it to result
* 2) Add list2 to result
* INTERSECTION
* 1) Walk list1 and if CAR(list1) in list2, add it to result
* SET-DIFFERENCE
* 1) Walk list1 and if CAR(list1) not in list2, add it to result
* SET-EXCLUSIVE-OR
* 1) Walk list1 and if CAR(list1) not in list2, add it to result
* 2) Walk list2 and if CAR(list2) not in list1, add it to result
* SUBSETP
* 1) Walk list1 and if CAR(list1) not in list2, return NIL
* 2) Return T
*/
value = 0;
for (cmp1 = list1; CONSP(cmp1); cmp1 = CDR(cmp1)) {
item = CAR(cmp1);
/* Apply key predicate if required */
if (key != UNSPEC) {
cmp = APPLY1(key, item);
if (setexclusiveor) {
if (clist1 == NIL) {
clist1 = cdr = CONS(cmp, NIL);
GC_PROTECT(clist1);
}
else {
RPLACD(cdr, CONS(cmp, NIL));
cdr = CDR(cdr);
}
}
}
else
cmp = item;
/* Compare against list2 */
for (cmp2 = clist2; CONSP(cmp2); cmp2 = CDR(cmp2)) {
value = FCOMPARE(lambda, cmp, CAR(cmp2), code);
if (value == expect)
break;
}
if (check_list2 && value != expect) {
/* check if list2 is a proper list */
CHECK_LIST(cmp2);
check_list2 = 0;
}
if (function == SUBSETP) {
/* Element of list1 not in list2? */
if (value != expect) {
GC_LEAVE();
return (NIL);
}
}
/* If need to add item to result */
else if (((setdifference || xunion || setexclusiveor) &&
value != expect) ||
(intersection && value == expect)) {
if (inplace) {
if (result == NIL)
result = cons = cmp1;
else {
if (setexclusiveor) {
/* don't remove elements yet, will need
* to check agains't list2 later */
for (cmp2 = cons; CDR(cmp2) != cmp1; cmp2 = CDR(cmp2))
;
if (cmp2 != cons) {
RPLACD(cmp2, list1);
list1 = cmp2;
}
}
RPLACD(cons, cmp1);
cons = cmp1;
}
}
else {
if (result == NIL) {
result = cons = CONS(item, NIL);
GC_PROTECT(result);
}
else {
RPLACD(cons, CONS(item, NIL));
cons = CDR(cons);
}
}
}
}
/* check if list1 is a proper list */
CHECK_LIST(cmp1);
if (function == SUBSETP) {
GC_LEAVE();
return (T);
}
else if (xunion) {
/* Add list2 to tail of result */
if (result == NIL)
result = list2;
else
RPLACD(cons, list2);
}
else if (setexclusiveor) {
LispObj *result2, *cons2;
result2 = cons2 = NIL;
for (cmp2 = list2; CONSP(cmp2); cmp2 = CDR(cmp2)) {
item = CAR(cmp2);
if (key != UNSPEC) {
cmp = CAR(clist2);
/* XXX changing clist2 */
clist2 = CDR(clist2);
cmp1 = clist1;
}
else {
cmp = item;
cmp1 = list1;
}
/* Compare against list1 */
for (; CONSP(cmp1); cmp1 = CDR(cmp1)) {
value = FCOMPARE(lambda, cmp, CAR(cmp1), code);
if (value == expect)
break;
}
if (value != expect) {
if (inplace) {
if (result2 == NIL)
result2 = cons2 = cmp2;
else {
RPLACD(cons2, cmp2);
cons2 = cmp2;
}
}
else {
if (result == NIL) {
result = cons = CONS(item, NIL);
GC_PROTECT(result);
}
else {
RPLACD(cons, CONS(item, NIL));
cons = CDR(cons);
}
}
}
}
if (inplace) {
if (CONSP(cons2))
RPLACD(cons2, NIL);
if (result == NIL)
result = result2;
else
RPLACD(cons, result2);
}
}
else if ((function == NSETDIFFERENCE || function == NINTERSECTION) &&
CONSP(cons))
RPLACD(cons, NIL);
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Loop(LispBuiltin *builtin)
/*
loop &rest body
*/
{
LispObj *code, *result;
LispBlock *block;
LispObj *body;
body = ARGUMENT(0);
result = NIL;
block = LispBeginBlock(NIL, LispBlockTag);
if (setjmp(block->jmp) == 0) {
for (;;)
for (code = body; CONSP(code); code = CDR(code))
(void)EVAL(CAR(code));
}
LispEndBlock(block);
result = lisp__data.block.block_ret;
return (result);
}
/* XXX This function is broken, needs a review
(being delayed until true array/vectors be implemented) */
LispObj *
Lisp_MakeArray(LispBuiltin *builtin)
/*
make-array dimensions &key element-type initial-element initial-contents
adjustable fill-pointer displaced-to
displaced-index-offset
*/
{
long rank = 0, count = 1, offset, zero, c;
LispObj *obj, *dim, *array;
LispType type;
LispObj *dimensions, *element_type, *initial_element, *initial_contents,
*displaced_to, *displaced_index_offset;
dim = array = NIL;
type = LispNil_t;
displaced_index_offset = ARGUMENT(7);
displaced_to = ARGUMENT(6);
initial_contents = ARGUMENT(3);
initial_element = ARGUMENT(2);
element_type = ARGUMENT(1);
dimensions = ARGUMENT(0);
if (INDEXP(dimensions)) {
dim = CONS(dimensions, NIL);
rank = 1;
count = FIXNUM_VALUE(dimensions);
}
else if (CONSP(dimensions)) {
dim = dimensions;
for (rank = 0; CONSP(dim); rank++, dim = CDR(dim)) {
obj = CAR(dim);
CHECK_INDEX(obj);
count *= FIXNUM_VALUE(obj);
}
dim = dimensions;
}
else if (dimensions == NIL) {
dim = NIL;
rank = count = 0;
}
else
LispDestroy("%s: %s is a bad array dimension",
STRFUN(builtin), STROBJ(dimensions));
/* check element-type */
if (element_type != UNSPEC) {
if (element_type == T)
type = LispNil_t;
else if (!SYMBOLP(element_type))
LispDestroy("%s: unsupported element type %s",
STRFUN(builtin), STROBJ(element_type));
else {
Atom_id atom = ATOMID(element_type);
if (atom == Satom)
type = LispAtom_t;
else if (atom == Sinteger)
type = LispInteger_t;
else if (atom == Scharacter)
type = LispSChar_t;
else if (atom == Sstring)
type = LispString_t;
else if (atom == Slist)
type = LispCons_t;
else if (atom == Sopaque)
type = LispOpaque_t;
else
LispDestroy("%s: unsupported element type %s",
STRFUN(builtin), ATOMID(element_type)->value);
}
}
/* check initial-contents */
if (rank) {
CHECK_LIST(initial_contents);
}
/* check displaced-to */
if (displaced_to != UNSPEC) {
CHECK_ARRAY(displaced_to);
}
/* check displaced-index-offset */
offset = -1;
if (displaced_index_offset != UNSPEC) {
CHECK_INDEX(displaced_index_offset);
offset = FIXNUM_VALUE(displaced_index_offset);
}
c = 0;
if (initial_element != UNSPEC)
++c;
if (initial_contents != UNSPEC)
++c;
if (displaced_to != UNSPEC || offset >= 0)
++c;
if (c > 1)
LispDestroy("%s: more than one initialization specified",
STRFUN(builtin));
if (initial_element == UNSPEC)
initial_element = NIL;
zero = count == 0;
if (displaced_to != UNSPEC) {
CHECK_ARRAY(displaced_to);
if (offset < 0)
offset = 0;
for (c = 1, obj = displaced_to->data.array.dim; obj != NIL;
obj = CDR(obj))
c *= FIXNUM_VALUE(CAR(obj));
if (c < count + offset)
LispDestroy("%s: array-total-size + displaced-index-offset "
"exceeds total size", STRFUN(builtin));
for (c = 0, array = displaced_to->data.array.list; c < offset; c++)
array = CDR(array);
}
else if (initial_contents != UNSPEC) {
CHECK_CONS(initial_contents);
if (rank == 0)
array = initial_contents;
else if (rank == 1) {
for (array = initial_contents, c = 0; c < count;
array = CDR(array), c++)
if (!CONSP(array))
LispDestroy("%s: bad argument or size %s",
STRFUN(builtin), STROBJ(array));
if (array != NIL)
LispDestroy("%s: bad argument or size %s",
STRFUN(builtin), STROBJ(array));
array = initial_contents;
}
else {
LispObj *err = NIL;
/* check if list matches */
int i, j, k, *dims, *loop;
/* create iteration variables */
dims = LispMalloc(sizeof(int) * rank);
loop = LispCalloc(1, sizeof(int) * (rank - 1));
for (i = 0, obj = dim; CONSP(obj); i++, obj = CDR(obj))
dims[i] = FIXNUM_VALUE(CAR(obj));
/* check if list matches specified dimensions */
while (loop[0] < dims[0]) {
for (obj = initial_contents, i = 0; i < rank - 1; i++) {
for (j = 0; j < loop[i]; j++)
obj = CDR(obj);
err = obj;
if (!CONSP(obj = CAR(obj)))
goto make_array_error;
err = obj;
}
--i;
for (;;) {
++loop[i];
if (i && loop[i] >= dims[i])
loop[i] = 0;
else
break;
--i;
}
for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) {
if (!CONSP(obj))
goto make_array_error;
}
if (obj == NIL)
continue;
make_array_error:
LispFree(dims);
LispFree(loop);
LispDestroy("%s: bad argument or size %s",
STRFUN(builtin), STROBJ(err));
}
/* list is correct, use it to fill initial values */
/* reset loop */
memset(loop, 0, sizeof(int) * (rank - 1));
GCDisable();
/* fill array with supplied values */
array = NIL;
while (loop[0] < dims[0]) {
for (obj = initial_contents, i = 0; i < rank - 1; i++) {
for (j = 0; j < loop[i]; j++)
obj = CDR(obj);
obj = CAR(obj);
}
--i;
for (;;) {
++loop[i];
if (i && loop[i] >= dims[i])
loop[i] = 0;
else
break;
--i;
}
for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) {
if (array == NIL)
array = CONS(CAR(obj), NIL);
else {
RPLACD(array, CONS(CAR(array), CDR(array)));
RPLACA(array, CAR(obj));
}
}
}
LispFree(dims);
LispFree(loop);
array = LispReverse(array);
GCEnable();
}
}
else {
GCDisable();
/* allocate array */
if (count) {
--count;
array = CONS(initial_element, NIL);
while (count) {
RPLACD(array, CONS(CAR(array), CDR(array)));
RPLACA(array, initial_element);
count--;
}
}
GCEnable();
}
obj = LispNew(array, dim);
obj->type = LispArray_t;
obj->data.array.list = array;
obj->data.array.dim = dim;
obj->data.array.rank = rank;
obj->data.array.type = type;
obj->data.array.zero = zero;
return (obj);
}
LispObj *
Lisp_MakeList(LispBuiltin *builtin)
/*
make-list size &key initial-element
*/
{
GC_ENTER();
long count;
LispObj *result, *cons;
LispObj *size, *initial_element;
initial_element = ARGUMENT(1);
size = ARGUMENT(0);
CHECK_INDEX(size);
count = FIXNUM_VALUE(size);
if (count == 0)
return (NIL);
if (initial_element == UNSPEC)
initial_element = NIL;
result = cons = CONS(initial_element, NIL);
GC_PROTECT(result);
for (; count > 1; count--) {
RPLACD(cons, CONS(initial_element, NIL));
cons = CDR(cons);
}
GC_LEAVE();
return (result);
}
LispObj *
Lisp_MakeSymbol(LispBuiltin *builtin)
/*
make-symbol name
*/
{
LispObj *name, *symbol;
name = ARGUMENT(0);
CHECK_STRING(name);
symbol = UNINTERNED_ATOM(THESTR(name));
symbol->data.atom->unreadable = !LispCheckAtomString(THESTR(name));
return (symbol);
}
LispObj *
Lisp_Makunbound(LispBuiltin *builtin)
/*
makunbound symbol
*/
{
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
LispUnsetVar(symbol);
return (symbol);
}
LispObj *
Lisp_Mapc(LispBuiltin *builtin)
/*
mapc function list &rest more-lists
*/
{
return (LispMapc(builtin, 0));
}
LispObj *
Lisp_Mapcar(LispBuiltin *builtin)
/*
mapcar function list &rest more-lists
*/
{
return (LispMapc(builtin, 1));
}
/* Like nconc but ignore non list arguments */
LispObj *
LispMapnconc(LispObj *list)
{
LispObj *result = NIL;
if (CONSP(list)) {
LispObj *cons, *head, *tail;
cons = NIL;
for (; CONSP(CDR(list)); list = CDR(list)) {
head = CAR(list);
if (CONSP(head)) {
for (tail = head; CONSP(CDR(tail)); tail = CDR(tail))
;
if (cons != NIL)
RPLACD(cons, head);
else
result = head;
cons = tail;
}
}
head = CAR(list);
if (CONSP(head)) {
if (cons != NIL)
RPLACD(cons, head);
else
result = head;
}
}
return (result);
}
LispObj *
Lisp_Mapcan(LispBuiltin *builtin)
/*
mapcan function list &rest more-lists
*/
{
return (LispMapnconc(LispMapc(builtin, 1)));
}
static LispObj *
LispMapc(LispBuiltin *builtin, int mapcar)
{
GC_ENTER();
long i, offset, count, length;
LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value;
LispObj *stk[8], **cdrs;
LispObj *function, *list, *more_lists;
more_lists = ARGUMENT(2);
list = ARGUMENT(1);
function = ARGUMENT(0);
/* Result will be no longer than this */
for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist))
;
/* If first argument is not a list... */
if (length == 0)
return (NIL);
/* At least one argument will be passed to function, count how many
* extra arguments will be used, and calculate result length. */
count = 0;
for (rest = more_lists; CONSP(rest); rest = CDR(rest), count++) {
/* Check if extra list is really a list, and if it is smaller
* than the first list */
for (i = 0, alist = CAR(rest);
i < length && CONSP(alist);
i++, alist = CDR(alist))
;
/* If it is not a true list */
if (i == 0)
return (NIL);
/* If it is smaller than the currently calculated result length */
if (i < length)
length = i;
}
if (mapcar) {
/* Initialize gc protected object cells for resulting list */
result = cons = CONS(NIL, NIL);
GC_PROTECT(result);
}
else
result = cons = list;
if (count >= sizeof(stk) / sizeof(stk[0]))
cdrs = LispMalloc(count * sizeof(LispObj*));
else
cdrs = &stk[0];
for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest))
cdrs[i] = CAR(rest);
/* Initialize gc protected object cells for argument list */
arguments = acons = CONS(NIL, NIL);
GC_PROTECT(arguments);
/* Allocate space for extra arguments */
for (i = 0; i < count; i++) {
RPLACD(acons, CONS(NIL, NIL));
acons = CDR(acons);
}
/* For every element of the list that will be used */
for (offset = 0;; list = CDR(list)) {
acons = arguments;
/* Add first argument */
RPLACA(acons, CAR(list));
acons = CDR(acons);
/* For every extra list argument */
for (i = 0; i < count; i++) {
alist = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
/* Add element to argument list */
RPLACA(acons, CAR(alist));
acons = CDR(acons);
}
value = APPLY(function, arguments);
if (mapcar) {
/* Store result */
RPLACA(cons, value);
/* Allocate new result cell */
if (++offset < length) {
RPLACD(cons, CONS(NIL, NIL));
cons = CDR(cons);
}
else
break;
}
else if (++offset >= length)
break;
}
/* Unprotect argument and result list */
GC_LEAVE();
if (cdrs != &stk[0])
LispFree(cdrs);
return (result);
}
static LispObj *
LispMapl(LispBuiltin *builtin, int maplist)
{
GC_ENTER();
long i, offset, count, length;
LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value;
LispObj *stk[8], **cdrs;
LispObj *function, *list, *more_lists;
more_lists = ARGUMENT(2);
list = ARGUMENT(1);
function = ARGUMENT(0);
/* count is the number of lists, length is the length of the result */
for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist))
;
/* first argument is not a list */
if (length == 0)
return (NIL);
/* check remaining arguments */
for (count = 0, rest = more_lists; CONSP(rest); rest = CDR(rest), count++) {
for (i = 0, alist = CAR(rest);
i < length && CONSP(alist);
i++, alist = CDR(alist))
;
/* argument is not a list */
if (i == 0)
return (NIL);
/* result will have the length of the smallest list */
if (i < length)
length = i;
}
/* result will be a list */
if (maplist) {
result = cons = CONS(NIL, NIL);
GC_PROTECT(result);
}
else
result = cons = list;
if (count >= sizeof(stk) / sizeof(stk[0]))
cdrs = LispMalloc(count * sizeof(LispObj*));
else
cdrs = &stk[0];
for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest))
cdrs[i] = CAR(rest);
/* initialize argument list */
arguments = acons = CONS(NIL, NIL);
GC_PROTECT(arguments);
for (i = 0; i < count; i++) {
RPLACD(acons, CONS(NIL, NIL));
acons = CDR(acons);
}
/* for every used list element */
for (offset = 0;; list = CDR(list)) {
acons = arguments;
/* first argument */
RPLACA(acons, list);
acons = CDR(acons);
/* for every extra list */
for (i = 0; i < count; i++) {
RPLACA(acons, cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
acons = CDR(acons);
}
value = APPLY(function, arguments);
if (maplist) {
/* store result */
RPLACA(cons, value);
/* allocate new cell */
if (++offset < length) {
RPLACD(cons, CONS(NIL, NIL));
cons = CDR(cons);
}
else
break;
}
else if (++offset >= length)
break;
}
GC_LEAVE();
if (cdrs != &stk[0])
LispFree(cdrs);
return (result);
}
LispObj *
Lisp_Mapl(LispBuiltin *builtin)
/*
mapl function list &rest more-lists
*/
{
return (LispMapl(builtin, 0));
}
LispObj *
Lisp_Maplist(LispBuiltin *builtin)
/*
maplist function list &rest more-lists
*/
{
return (LispMapl(builtin, 1));
}
LispObj *
Lisp_Mapcon(LispBuiltin *builtin)
/*
mapcon function list &rest more-lists
*/
{
return (LispMapnconc(LispMapl(builtin, 1)));
}
LispObj *
Lisp_Member(LispBuiltin *builtin)
/*
member item list &key test test-not key
*/
{
int code, expect;
LispObj *compare, *lambda;
LispObj *item, *list, *test, *test_not, *key;
key = ARGUMENT(4);
test_not = ARGUMENT(3);
test = ARGUMENT(2);
list = ARGUMENT(1);
item = ARGUMENT(0);
if (list == NIL)
return (NIL);
CHECK_CONS(list);
CHECK_TEST();
if (key == UNSPEC) {
if (code == FEQ) {
for (; CONSP(list); list = CDR(list))
if (item == CAR(list))
return (list);
}
else {
for (; CONSP(list); list = CDR(list))
if ((FCOMPARE(lambda, item, CAR(list), code)) == expect)
return (list);
}
}
else {
if (code == FEQ) {
for (; CONSP(list); list = CDR(list))
if (item == APPLY1(key, CAR(list)))
return (list);
}
else {
for (; CONSP(list); list = CDR(list)) {
compare = APPLY1(key, CAR(list));
if ((FCOMPARE(lambda, item, compare, code)) == expect)
return (list);
}
}
}
/* check if is a proper list */
CHECK_LIST(list);
return (NIL);
}
LispObj *
Lisp_MemberIf(LispBuiltin *builtin)
/*
member-if predicate list &key key
*/
{
return (LispAssocOrMember(builtin, MEMBER, IF));
}
LispObj *
Lisp_MemberIfNot(LispBuiltin *builtin)
/*
member-if-not predicate list &key key
*/
{
return (LispAssocOrMember(builtin, MEMBER, IFNOT));
}
LispObj *
Lisp_MultipleValueBind(LispBuiltin *builtin)
/*
multiple-value-bind symbols values &rest body
*/
{
int i, head = lisp__data.env.length;
LispObj *result, *symbol, *value;
LispObj *symbols, *values, *body;
body = ARGUMENT(2);
values = ARGUMENT(1);
symbols = ARGUMENT(0);
result = EVAL(values);
for (i = -1; CONSP(symbols); symbols = CDR(symbols), i++) {
symbol = CAR(symbols);
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
if (i >= 0 && i < RETURN_COUNT)
value = RETURN(i);
else if (i < 0)
value = result;
else
value = NIL;
LispAddVar(symbol, value);
++lisp__data.env.head;
}
/* Execute code with binded variables (if any) */
for (result = NIL; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
lisp__data.env.head = lisp__data.env.length = head;
return (result);
}
LispObj *
Lisp_MultipleValueCall(LispBuiltin *builtin)
/*
multiple-value-call function &rest form
*/
{
GC_ENTER();
int i;
LispObj *arguments, *cons, *result;
LispObj *function, *form;
form = ARGUMENT(1);
function = ARGUMENT(0);
/* build argument list */
arguments = cons = NIL;
for (; CONSP(form); form = CDR(form)) {
RETURN_COUNT = 0;
result = EVAL(CAR(form));
if (RETURN_COUNT >= 0) {
if (arguments == NIL) {
arguments = cons = CONS(result, NIL);
GC_PROTECT(arguments);
}
else {
RPLACD(cons, CONS(result, NIL));
cons = CDR(cons);
}
for (i = 0; i < RETURN_COUNT; i++) {
RPLACD(cons, CONS(RETURN(i), NIL));
cons = CDR(cons);
}
}
}
/* apply function */
if (POINTERP(function) && !XSYMBOLP(function) && !XFUNCTIONP(function)) {
function = EVAL(function);
GC_PROTECT(function);
}
result = APPLY(function, arguments);
GC_LEAVE();
return (result);
}
LispObj *
Lisp_MultipleValueProg1(LispBuiltin *builtin)
/*
multiple-value-prog1 first-form &rest form
*/
{
GC_ENTER();
int i, count;
LispObj *values, *cons;
LispObj *first_form, *form;
form = ARGUMENT(1);
first_form = ARGUMENT(0);
values = EVAL(first_form);
if (!CONSP(form))
return (values);
cons = NIL;
count = RETURN_COUNT;
if (count < 0)
values = NIL;
else if (count == 0) {
GC_PROTECT(values);
}
else {
values = cons = CONS(values, NIL);
GC_PROTECT(values);
for (i = 0; i < count; i++) {
RPLACD(cons, CONS(RETURN(i), NIL));
cons = CDR(cons);
}
}
for (; CONSP(form); form = CDR(form))
EVAL(CAR(form));
RETURN_COUNT = count;
if (count > 0) {
for (i = 0, cons = CDR(values); CONSP(cons); cons = CDR(cons), i++)
RETURN(i) = CAR(cons);
values = CAR(values);
}
GC_LEAVE();
return (values);
}
LispObj *
Lisp_MultipleValueList(LispBuiltin *builtin)
/*
multiple-value-list form
*/
{
int i;
GC_ENTER();
LispObj *form, *result, *cons;
form = ARGUMENT(0);
result = EVAL(form);
if (RETURN_COUNT < 0)
return (NIL);
result = cons = CONS(result, NIL);
GC_PROTECT(result);
for (i = 0; i < RETURN_COUNT; i++) {
RPLACD(cons, CONS(RETURN(i), NIL));
cons = CDR(cons);
}
GC_LEAVE();
return (result);
}
LispObj *
Lisp_MultipleValueSetq(LispBuiltin *builtin)
/*
multiple-value-setq symbols form
*/
{
int i;
LispObj *result, *symbol, *value;
LispObj *symbols, *form;
form = ARGUMENT(1);
symbols = ARGUMENT(0);
CHECK_LIST(symbols);
result = EVAL(form);
if (CONSP(symbols)) {
symbol = CAR(symbols);
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
LispSetVar(symbol, result);
symbols = CDR(symbols);
}
for (i = 0; CONSP(symbols); symbols = CDR(symbols), i++) {
symbol = CAR(symbols);
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
if (i < RETURN_COUNT && RETURN_COUNT > 0)
value = RETURN(i);
else
value = NIL;
LispSetVar(symbol, value);
}
return (result);
}
LispObj *
Lisp_Nconc(LispBuiltin *builtin)
/*
nconc &rest lists
*/
{
LispObj *list, *lists, *cons, *head, *tail;
lists = ARGUMENT(0);
/* skip any initial empty lists */
for (; CONSP(lists); lists = CDR(lists))
if (CAR(lists) != NIL)
break;
/* don't check if a proper list */
if (!CONSP(lists))
return (lists);
/* setup to concatenate lists */
list = CAR(lists);
CHECK_CONS(list);
for (cons = list; CONSP(CDR(cons)); cons = CDR(cons))
;
/* if only two lists */
lists = CDR(lists);
if (!CONSP(lists)) {
RPLACD(cons, lists);
return (list);
}
/* concatenate */
for (; CONSP(CDR(lists)); lists = CDR(lists)) {
head = CAR(lists);
if (head == NIL)
continue;
CHECK_CONS(head);
for (tail = head; CONSP(CDR(tail)); tail = CDR(tail))
;
RPLACD(cons, head);
cons = tail;
}
/* add last list */
RPLACD(cons, CAR(lists));
return (list);
}
LispObj *
Lisp_Nreverse(LispBuiltin *builtin)
/*
nreverse sequence
*/
{
return (LispXReverse(builtin, 1));
}
LispObj *
Lisp_NsetDifference(LispBuiltin *builtin)
/*
nset-difference list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, NSETDIFFERENCE));
}
LispObj *
Lisp_Nsubstitute(LispBuiltin *builtin)
/*
nsubstitute newitem olditem sequence &key from-end test test-not start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, NONE));
}
LispObj *
Lisp_NsubstituteIf(LispBuiltin *builtin)
/*
nsubstitute-if newitem test sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IF));
}
LispObj *
Lisp_NsubstituteIfNot(LispBuiltin *builtin)
/*
nsubstitute-if-not newitem test sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IFNOT));
}
LispObj *
Lisp_Nth(LispBuiltin *builtin)
/*
nth index list
*/
{
long position;
LispObj *oindex, *list;
list = ARGUMENT(1);
oindex = ARGUMENT(0);
CHECK_INDEX(oindex);
position = FIXNUM_VALUE(oindex);
if (list == NIL)
return (NIL);
CHECK_CONS(list);
for (; position > 0; position--) {
if (!CONSP(list))
return (NIL);
list = CDR(list);
}
return (CONSP(list) ? CAR(list) : NIL);
}
LispObj *
Lisp_Nthcdr(LispBuiltin *builtin)
/*
nthcdr index list
*/
{
long position;
LispObj *oindex, *list;
list = ARGUMENT(1);
oindex = ARGUMENT(0);
CHECK_INDEX(oindex);
position = FIXNUM_VALUE(oindex);
if (list == NIL)
return (NIL);
CHECK_CONS(list);
for (; position > 0; position--) {
if (!CONSP(list))
return (NIL);
list = CDR(list);
}
return (list);
}
LispObj *
Lisp_NthValue(LispBuiltin *builtin)
/*
nth-value index form
*/
{
long i;
LispObj *oindex, *form, *result;
form = ARGUMENT(1);
oindex = ARGUMENT(0);
oindex = EVAL(oindex);
CHECK_INDEX(oindex);
i = FIXNUM_VALUE(oindex) - 1;
result = EVAL(form);
if (RETURN_COUNT < 0 || i >= RETURN_COUNT)
result = NIL;
else if (i >= 0)
result = RETURN(i);
return (result);
}
LispObj *
Lisp_Null(LispBuiltin *builtin)
/*
null list
*/
{
LispObj *list;
list = ARGUMENT(0);
return (list == NIL ? T : NIL);
}
LispObj *
Lisp_Or(LispBuiltin *builtin)
/*
or &rest args
*/
{
LispObj *result = NIL, *args;
args = ARGUMENT(0);
for (; CONSP(args); args = CDR(args)) {
result = EVAL(CAR(args));
if (result != NIL)
break;
}
return (result);
}
LispObj *
Lisp_Pairlis(LispBuiltin *builtin)
/*
pairlis key data &optional alist
*/
{
LispObj *result, *cons;
LispObj *key, *data, *alist;
alist = ARGUMENT(2);
data = ARGUMENT(1);
key = ARGUMENT(0);
if (CONSP(key) && CONSP(data)) {
GC_ENTER();
result = cons = CONS(CONS(CAR(key), CAR(data)), NIL);
GC_PROTECT(result);
key = CDR(key);
data = CDR(data);
for (; CONSP(key) && CONSP(data); key = CDR(key), data = CDR(data)) {
RPLACD(cons, CONS(CONS(CAR(key), CAR(data)), NIL));
cons = CDR(cons);
}
if (CONSP(key) || CONSP(data))
LispDestroy("%s: different length lists", STRFUN(builtin));
GC_LEAVE();
if (alist != UNSPEC)
RPLACD(cons, alist);
}
else
result = alist == UNSPEC ? NIL : alist;
return (result);
}
static LispObj *
LispFindOrPosition(LispBuiltin *builtin,
int function, int comparison)
/*
find item sequence &key from-end test test-not start end key
find-if predicate sequence &key from-end start end key
find-if-not predicate sequence &key from-end start end key
position item sequence &key from-end test test-not start end key
position-if predicate sequence &key from-end start end key
position-if-not predicate sequence &key from-end start end key
*/
{
int code = 0, istring, expect, value;
char *string = NULL;
long offset = -1, start, end, length, i = comparison == NONE ? 7 : 5;
LispObj *cmp, *element, **objects = NULL;
LispObj *item, *predicate, *sequence, *from_end,
*test, *test_not, *ostart, *oend, *key;
key = ARGUMENT(i); --i;
oend = ARGUMENT(i); --i;
ostart = ARGUMENT(i); --i;
if (comparison == NONE) {
test_not = ARGUMENT(i); --i;
test = ARGUMENT(i); --i;
}
else
test_not = test = UNSPEC;
from_end = ARGUMENT(i); --i;
if (from_end == UNSPEC)
from_end = NIL;
sequence = ARGUMENT(i); --i;
if (comparison == NONE) {
item = ARGUMENT(i);
predicate = Oeql;
}
else {
predicate = ARGUMENT(i);
item = NIL;
}
LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
&start, &end, &length);
if (sequence == NIL)
return (NIL);
/* Cannot specify both :test and :test-not */
if (test != UNSPEC && test_not != UNSPEC)
LispDestroy("%s: specify either :TEST or :TEST-NOT", STRFUN(builtin));
expect = 1;
if (comparison == NONE) {
if (test != UNSPEC)
predicate = test;
else if (test_not != UNSPEC) {
predicate = test_not;
expect = 0;
}
FUNCTION_CHECK(predicate);
code = FCODE(predicate);
}
cmp = element = NIL;
istring = STRINGP(sequence);
if (istring)
string = THESTR(sequence);
else {
if (!CONSP(sequence))
sequence = sequence->data.array.list;
for (i = 0; i < start; i++)
sequence = CDR(sequence);
}
if ((length = end - start) == 0)
return (NIL);
if (from_end != NIL && !istring) {
objects = LispMalloc(sizeof(LispObj*) * length);
for (i = length - 1; i >= 0; i--, sequence = CDR(sequence))
objects[i] = CAR(sequence);
}
for (i = 0; i < length; i++) {
if (istring)
element = SCHAR(string[from_end == NIL ? i + start : end - i - 1]);
else
element = from_end == NIL ? CAR(sequence) : objects[i];
if (key != UNSPEC)
cmp = APPLY1(key, element);
else
cmp = element;
/* Update list */
if (!istring && from_end == NIL)
sequence = CDR(sequence);
if (comparison == NONE)
value = FCOMPARE(predicate, item, cmp, code);
else
value = APPLY1(predicate, cmp) != NIL;
if ((!value &&
(comparison == IFNOT ||
(comparison == NONE && !expect))) ||
(value &&
(comparison == IF ||
(comparison == NONE && expect)))) {
offset = from_end == NIL ? i + start : end - i - 1;
break;
}
}
if (from_end != NIL && !istring)
LispFree(objects);
return (offset == -1 ? NIL : function == FIND ? element : FIXNUM(offset));
}
LispObj *
Lisp_Pop(LispBuiltin *builtin)
/*
pop place
*/
{
LispObj *result, *value;
LispObj *place;
place = ARGUMENT(0);
if (SYMBOLP(place)) {
result = LispGetVar(place);
if (result == NULL)
LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
CHECK_CONSTANT(place);
if (result != NIL) {
CHECK_CONS(result);
value = CDR(result);
result = CAR(result);
}
else
value = NIL;
LispSetVar(place, value);
}
else {
GC_ENTER();
LispObj quote;
result = EVAL(place);
if (result != NIL) {
CHECK_CONS(result);
value = CDR(result);
GC_PROTECT(value);
result = CAR(result);
}
else
value = NIL;
quote.type = LispQuote_t;
quote.data.quote = value;
APPLY2(Osetf, place, &quote);
GC_LEAVE();
}
return (result);
}
LispObj *
Lisp_Position(LispBuiltin *builtin)
/*
position item sequence &key from-end test test-not start end key
*/
{
return (LispFindOrPosition(builtin, POSITION, NONE));
}
LispObj *
Lisp_PositionIf(LispBuiltin *builtin)
/*
position-if predicate sequence &key from-end start end key
*/
{
return (LispFindOrPosition(builtin, POSITION, IF));
}
LispObj *
Lisp_PositionIfNot(LispBuiltin *builtin)
/*
position-if-not predicate sequence &key from-end start end key
*/
{
return (LispFindOrPosition(builtin, POSITION, IFNOT));
}
LispObj *
Lisp_Proclaim(LispBuiltin *builtin)
/*
proclaim declaration
*/
{
LispObj *arguments, *object;
char *operation;
LispObj *declaration;
declaration = ARGUMENT(0);
CHECK_CONS(declaration);
arguments = declaration;
object = CAR(arguments);
CHECK_SYMBOL(object);
operation = ATOMID(object)->value;
if (strcmp(operation, "SPECIAL") == 0) {
for (arguments = CDR(arguments); CONSP(arguments);
arguments = CDR(arguments)) {
object = CAR(arguments);
CHECK_SYMBOL(object);
LispProclaimSpecial(object, NULL, NIL);
}
}
else if (strcmp(operation, "TYPE") == 0) {
/* XXX no type checking yet, but should be added */
}
/* else do nothing */
return (NIL);
}
LispObj *
Lisp_Prog1(LispBuiltin *builtin)
/*
prog1 first &rest body
*/
{
GC_ENTER();
LispObj *result;
LispObj *first, *body;
body = ARGUMENT(1);
first = ARGUMENT(0);
result = EVAL(first);
GC_PROTECT(result);
for (; CONSP(body); body = CDR(body))
(void)EVAL(CAR(body));
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Prog2(LispBuiltin *builtin)
/*
prog2 first second &rest body
*/
{
GC_ENTER();
LispObj *result;
LispObj *first, *second, *body;
body = ARGUMENT(2);
second = ARGUMENT(1);
first = ARGUMENT(0);
(void)EVAL(first);
result = EVAL(second);
GC_PROTECT(result);
for (; CONSP(body); body = CDR(body))
(void)EVAL(CAR(body));
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Progn(LispBuiltin *builtin)
/*
progn &rest body
*/
{
LispObj *result = NIL;
LispObj *body;
body = ARGUMENT(0);
for (; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
return (result);
}
/*
* This does what I believe is the expected behaviour (or at least
* acceptable for the the interpreter), if the code being executed
* ever tries to change/bind a progv symbol, the symbol state will
* be restored when exiting the progv block, so, code like:
* (progv '(*x*) '(1) (defvar *x* 10))
* when exiting the block, will have *x* unbound, and not a dynamic
* symbol; if it was already bound, will have the old value.
* Symbols already dynamic can be freely changed, even unbounded in
* the progv block.
*/
LispObj *
Lisp_Progv(LispBuiltin *builtin)
/*
progv symbols values &rest body
*/
{
GC_ENTER();
int head = lisp__data.env.length, i, count, ostk[32], *offsets;
LispObj *result, *list, *symbol, *value;
int jumped;
char fstk[32], *flags;
LispBlock *block;
LispAtom *atom;
LispObj *symbols, *values, *body;
/* Possible states */
#define DYNAMIC_SYMBOL 1
#define GLOBAL_SYMBOL 2
#define UNBOUND_SYMBOL 3
body = ARGUMENT(2);
values = ARGUMENT(1);
symbols = ARGUMENT(0);
/* get symbol names */
symbols = EVAL(symbols);
GC_PROTECT(symbols);
/* get symbol values */
values = EVAL(values);
GC_PROTECT(values);
/* count/check symbols and allocate space to remember symbol state */
for (count = 0, list = symbols; CONSP(list); count++, list = CDR(list)) {
symbol = CAR(list);
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
}
if (count > sizeof(fstk)) {
flags = LispMalloc(count);
offsets = LispMalloc(count * sizeof(int));
}
else {
flags = &fstk[0];
offsets = &ostk[0];
}
/* store flags and save old value if required */
for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
atom = CAR(list)->data.atom;
if (atom->dyn)
flags[i] = DYNAMIC_SYMBOL;
else if (atom->a_object) {
flags[i] = GLOBAL_SYMBOL;
offsets[i] = lisp__data.protect.length;
GC_PROTECT(atom->property->value);
}
else
flags[i] = UNBOUND_SYMBOL;
}
/* bind the symbols */
for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
symbol = CAR(list);
atom = symbol->data.atom;
if (CONSP(values)) {
value = CAR(values);
values = CDR(values);
}
else
value = NIL;
if (flags[i] != DYNAMIC_SYMBOL) {
if (!atom->a_object)
LispSetAtomObjectProperty(atom, value);
else
SETVALUE(atom, value);
}
else
LispAddVar(symbol, value);
}
/* bind dynamic symbols */
lisp__data.env.head = lisp__data.env.length;
jumped = 0;
result = NIL;
block = LispBeginBlock(NIL, LispBlockProtect);
if (setjmp(block->jmp) == 0) {
for (; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
}
/* restore symbols */
for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
symbol = CAR(list);
atom = symbol->data.atom;
if (flags[i] != DYNAMIC_SYMBOL) {
if (flags[i] == UNBOUND_SYMBOL)
LispUnsetVar(symbol);
else {
/* restore global symbol value */
LispSetAtomObjectProperty(atom, lisp__data.protect.objects
[offsets[i]]);
atom->dyn = 0;
}
}
}
/* unbind dynamic symbols */
lisp__data.env.head = lisp__data.env.length = head;
GC_LEAVE();
if (count > sizeof(fstk)) {
LispFree(flags);
LispFree(offsets);
}
LispEndBlock(block);
if (!lisp__data.destroyed) {
if (jumped)
result = lisp__data.block.block_ret;
}
else {
/* check if there is an unwind-protect block */
LispBlockUnwind(NULL);
/* no unwind-protect block, return to the toplevel */
LispDestroy(".");
}
return (result);
}
LispObj *
Lisp_Provide(LispBuiltin *builtin)
/*
provide module
*/
{
LispObj *module, *obj;
module = ARGUMENT(0);
CHECK_STRING(module);
for (obj = MOD; obj != NIL; obj = CDR(obj)) {
if (STRLEN(CAR(obj)) == STRLEN(module) &&
memcmp(THESTR(CAR(obj)), THESTR(module), STRLEN(module)) == 0)
return (module);
}
if (MOD == NIL)
MOD = CONS(module, NIL);
else {
RPLACD(MOD, CONS(CAR(MOD), CDR(MOD)));
RPLACA(MOD, module);
}
LispSetVar(lisp__data.modules, MOD);
return (MOD);
}
LispObj *
Lisp_Push(LispBuiltin *builtin)
/*
push item place
*/
{
LispObj *result, *list;
LispObj *item, *place;
place = ARGUMENT(1);
item = ARGUMENT(0);
item = EVAL(item);
if (SYMBOLP(place)) {
list = LispGetVar(place);
if (list == NULL)
LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
CHECK_CONSTANT(place);
LispSetVar(place, result = CONS(item, list));
}
else {
GC_ENTER();
LispObj quote;
list = EVAL(place);
result = CONS(item, list);
GC_PROTECT(result);
quote.type = LispQuote_t;
quote.data.quote = result;
APPLY2(Osetf, place, &quote);
GC_LEAVE();
}
return (result);
}
LispObj *
Lisp_Pushnew(LispBuiltin *builtin)
/*
pushnew item place &key key test test-not
*/
{
GC_ENTER();
LispObj *result, *list;
LispObj *item, *place, *key, *test, *test_not;
test_not = ARGUMENT(4);
test = ARGUMENT(3);
key = ARGUMENT(2);
place = ARGUMENT(1);
item = ARGUMENT(0);
/* Evaluate place */
if (SYMBOLP(place)) {
list = LispGetVar(place);
if (list == NULL)
LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
/* Do error checking now. */
CHECK_CONSTANT(place);
}
else
/* It is possible that list is not gc protected? */
list = EVAL(place);
item = EVAL(item);
GC_PROTECT(item);
if (key != UNSPEC) {
key = EVAL(key);
GC_PROTECT(key);
}
if (test != UNSPEC) {
test = EVAL(test);
GC_PROTECT(test);
}
else if (test_not != UNSPEC) {
test_not = EVAL(test_not);
GC_PROTECT(test_not);
}
result = LispAdjoin(builtin, item, list, key, test, test_not);
/* Item already in list */
if (result == list) {
GC_LEAVE();
return (result);
}
if (SYMBOLP(place)) {
CHECK_CONSTANT(place);
LispSetVar(place, result);
}
else {
LispObj quote;
GC_PROTECT(result);
quote.type = LispQuote_t;
quote.data.quote = result;
APPLY2(Osetf, place, &quote);
}
GC_LEAVE();
return (result);
}
#ifdef __SUNPRO_C
/* prevent "Function has no return statement" error for Lisp_Quit */
#pragma does_not_return(exit)
#endif
LispObj *
Lisp_Quit(LispBuiltin *builtin)
/*
quit &optional status
*/
{
int status = 0;
LispObj *ostatus;
ostatus = ARGUMENT(0);
if (FIXNUMP(ostatus))
status = (int)FIXNUM_VALUE(ostatus);
else if (ostatus != UNSPEC)
LispDestroy("%s: bad exit status argument %s",
STRFUN(builtin), STROBJ(ostatus));
exit(status);
}
LispObj *
Lisp_Quote(LispBuiltin *builtin)
/*
quote object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (object);
}
LispObj *
Lisp_Replace(LispBuiltin *builtin)
/*
replace sequence1 sequence2 &key start1 end1 start2 end2
*/
{
long length, length1, length2, start1, end1, start2, end2;
LispObj *sequence1, *sequence2, *ostart1, *oend1, *ostart2, *oend2;
oend2 = ARGUMENT(5);
ostart2 = ARGUMENT(4);
oend1 = ARGUMENT(3);
ostart1 = ARGUMENT(2);
sequence2 = ARGUMENT(1);
sequence1 = ARGUMENT(0);
LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1,
&start1, &end1, &length1);
LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2,
&start2, &end2, &length2);
if (start1 == end1 || start2 == end2)
return (sequence1);
length = end1 - start1;
if (length > end2 - start2)
length = end2 - start2;
if (STRINGP(sequence1)) {
CHECK_STRING_WRITABLE(sequence1);
if (!STRINGP(sequence2))
LispDestroy("%s: cannot store %s in %s",
STRFUN(builtin), STROBJ(sequence2), THESTR(sequence1));
memmove(THESTR(sequence1) + start1, THESTR(sequence2) + start2, length);
}
else {
int i;
LispObj *from, *to;
if (ARRAYP(sequence1))
sequence1 = sequence1->data.array.list;
if (ARRAYP(sequence2))
sequence2 = sequence2->data.array.list;
/* adjust pointers */
for (i = 0, from = sequence2; i < start2; i++, from = CDR(from))
;
for (i = 0, to = sequence1; i < start1; i++, to = CDR(to))
;
/* copy data */
for (i = 0; i < length; i++, from = CDR(from), to = CDR(to))
RPLACA(to, CAR(from));
}
return (sequence1);
}
static LispObj *
LispDeleteOrRemoveDuplicates(LispBuiltin *builtin, int function)
/*
delete-duplicates sequence &key from-end test test-not start end key
remove-duplicates sequence &key from-end test test-not start end key
*/
{
GC_ENTER();
int code, expect, value = 0;
long i, j, start, end, length, count;
LispObj *lambda, *result, *cons, *compare;
LispObj *sequence, *from_end, *test, *test_not, *ostart, *oend, *key;
key = ARGUMENT(6);
oend = ARGUMENT(5);
ostart = ARGUMENT(4);
test_not = ARGUMENT(3);
test = ARGUMENT(2);
from_end = ARGUMENT(1);
if (from_end == UNSPEC)
from_end = NIL;
sequence = ARGUMENT(0);
LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
&start, &end, &length);
/* Check if need to do something */
if (start == end)
return (sequence);
CHECK_TEST();
/* Initialize */
count = 0;
result = cons = NIL;
if (STRINGP(sequence)) {
char *ptr, *string, *buffer = LispMalloc(length + 1);
/* Use same code, update start/end offsets */
if (from_end != NIL) {
i = length - start;
start = length - end;
end = i;
}
if (from_end == NIL)
string = THESTR(sequence);
else {
/* Make a reversed copy of the sequence */
string = LispMalloc(length + 1);
for (ptr = THESTR(sequence) + length - 1, i = 0; i < length; i++)
string[i] = *ptr--;
string[i] = '\0';
}
ptr = buffer;
/* Copy leading bytes */
for (i = 0; i < start; i++)
*ptr++ = string[i];
compare = SCHAR(string[i]);
if (key != UNSPEC)
compare = APPLY1(key, compare);
result = cons = CONS(compare, NIL);
GC_PROTECT(result);
for (++i; i < end; i++) {
compare = SCHAR(string[i]);
if (key != UNSPEC)
compare = APPLY1(key, compare);
RPLACD(cons, CONS(compare, NIL));
cons = CDR(cons);
}
for (i = start; i < end; i++, result = CDR(result)) {
compare = CAR(result);
for (j = i + 1, cons = CDR(result); j < end; j++, cons = CDR(cons)) {
value = FCOMPARE(lambda, compare, CAR(cons), code);
if (value == expect)
break;
}
if (value != expect)
*ptr++ = string[i];
else
++count;
}
if (count) {
/* Copy ending bytes */
for (; i <= length; i++) /* Also copy the ending nul */
*ptr++ = string[i];
if (from_end == NIL)
ptr = buffer;
else {
for (i = 0, ptr = buffer + strlen(buffer);
ptr > buffer;
i++)
string[i] = *--ptr;
string[i] = '\0';
ptr = string;
LispFree(buffer);
}
if (function == REMOVE)
result = STRING2(ptr);
else {
CHECK_STRING_WRITABLE(sequence);
result = sequence;
free(THESTR(result));
THESTR(result) = ptr;
LispMused(ptr);
}
}
else {
result = sequence;
if (from_end != NIL)
LispFree(string);
}
}
else {
long xlength = end - start;
LispObj *list, *object, **kobjects = NULL, **xobjects;
LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength);
if (!CONSP(sequence))
object = sequence->data.array.list;
else
object = sequence;
list = object;
for (i = 0; i < start; i++)
object = CDR(object);
/* Put data in a vector */
if (from_end == NIL) {
for (i = 0; i < xlength; i++, object = CDR(object))
objects[i] = CAR(object);
}
else {
for (i = xlength - 1; i >= 0; i--, object = CDR(object))
objects[i] = CAR(object);
}
/* Apply key predicate if required */
if (key != UNSPEC) {
kobjects = LispMalloc(sizeof(LispObj*) * xlength);
for (i = 0; i < xlength; i++) {
kobjects[i] = APPLY1(key, objects[i]);
GC_PROTECT(kobjects[i]);
}
xobjects = kobjects;
}
else
xobjects = objects;
/* Check if needs to remove something */
for (i = 0; i < xlength; i++) {
compare = xobjects[i];
for (j = i + 1; j < xlength; j++) {
value = FCOMPARE(lambda, compare, xobjects[j], code);
if (value == expect) {
objects[i] = NULL;
++count;
break;
}
}
}
if (count) {
/* Create/set result list */
object = list;
if (start) {
/* Skip first elements of resulting list */
if (function == REMOVE) {
result = cons = CONS(CAR(object), NIL);
GC_PROTECT(result);
for (i = 1, object = CDR(object);
i < start;
i++, object = CDR(object)) {
RPLACD(cons, CONS(CAR(object), NIL));
cons = CDR(cons);
}
}
else {
result = cons = object;
for (i = 1; i < start; i++, cons = CDR(cons))
;
}
}
else if (function == DELETE)
result = list;
/* Skip initial removed elements */
if (function == REMOVE) {
for (i = 0; objects[i] == NULL && i < xlength; i++)
;
}
else
i = 0;
if (i < xlength) {
int xstart, xlimit, xinc;
if (from_end == NIL) {
xstart = i;
xlimit = xlength;
xinc = 1;
}
else {
xstart = xlength - 1;
xlimit = i - 1;
xinc = -1;
}
if (function == REMOVE) {
for (i = xstart; i != xlimit; i += xinc) {
if (objects[i] != NULL) {
if (result == NIL) {
result = cons = CONS(objects[i], NIL);
GC_PROTECT(result);
}
else {
RPLACD(cons, CONS(objects[i], NIL));
cons = CDR(cons);
}
}
}
}
else {
/* Delete duplicates */
for (i = xstart; i != xlimit; i += xinc) {
if (objects[i] == NULL) {
if (cons == NIL) {
if (CONSP(CDR(result))) {
RPLACA(result, CADR(result));
RPLACD(result, CDDR(result));
}
else {
RPLACA(result, CDR(result));
RPLACD(result, NIL);
}
}
else {
if (CONSP(CDR(cons)))
RPLACD(cons, CDDR(cons));
else
RPLACD(cons, NIL);
}
}
else {
if (cons == NIL)
cons = result;
else
cons = CDR(cons);
}
}
}
}
if (end < length && function == REMOVE) {
for (i = start; i < end; i++, object = CDR(object))
;
if (result == NIL) {
result = cons = CONS(CAR(object), NIL);
GC_PROTECT(result);
++i;
object = CDR(object);
}
for (; i < length; i++, object = CDR(object)) {
RPLACD(cons, CONS(CAR(object), NIL));
cons = CDR(cons);
}
}
}
else
result = sequence;
LispFree(objects);
if (key != UNSPEC)
LispFree(kobjects);
if (count && !CONSP(sequence)) {
if (function == REMOVE)
result = VECTOR(result);
else {
length = FIXNUM_VALUE(CAR(sequence->data.array.dim)) - count;
CAR(sequence->data.array.dim) = FIXNUM(length);
result = sequence;
}
}
}
GC_LEAVE();
return (result);
}
LispObj *
Lisp_RemoveDuplicates(LispBuiltin *builtin)
/*
remove-duplicates sequence &key from-end test test-not start end key
*/
{
return (LispDeleteOrRemoveDuplicates(builtin, REMOVE));
}
static LispObj *
LispDeleteRemoveXSubstitute(LispBuiltin *builtin,
int function, int comparison)
/*
delete item sequence &key from-end test test-not start end count key
delete-if predicate sequence &key from-end start end count key
delete-if-not predicate sequence &key from-end start end count key
remove item sequence &key from-end test test-not start end count key
remove-if predicate sequence &key from-end start end count key
remove-if-not predicate sequence &key from-end start end count key
substitute newitem olditem sequence &key from-end test test-not start end count key
substitute-if newitem test sequence &key from-end start end count key
substitute-if-not newitem test sequence &key from-end start end count key
nsubstitute newitem olditem sequence &key from-end test test-not start end count key
nsubstitute-if newitem test sequence &key from-end start end count key
nsubstitute-if-not newitem test sequence &key from-end start end count key
*/
{
GC_ENTER();
int code, expect, value, inplace, substitute;
long i, j, start, end, length, copy, count, xstart, xend, xinc, xlength;
LispObj *result, *compare;
LispObj *item, *newitem, *lambda, *sequence, *from_end,
*test, *test_not, *ostart, *oend, *ocount, *key;
substitute = function == SUBSTITUTE || function == NSUBSTITUTE;
if (!substitute)
i = comparison == NONE ? 8 : 6;
else /* substitute */
i = comparison == NONE ? 9 : 7;
/* Get function arguments */
key = ARGUMENT(i); --i;
ocount = ARGUMENT(i); --i;
oend = ARGUMENT(i); --i;
ostart = ARGUMENT(i); --i;
if (comparison == NONE) {
test_not = ARGUMENT(i); --i;
test = ARGUMENT(i); --i;
}
else
test_not = test = UNSPEC;
from_end = ARGUMENT(i); --i;
if (from_end == UNSPEC)
from_end = NIL;
sequence = ARGUMENT(i); --i;
if (comparison != NONE) {
lambda = ARGUMENT(i); --i;
if (substitute)
newitem = ARGUMENT(0);
else
newitem = NIL;
item = NIL;
}
else {
lambda = NIL;
if (substitute) {
item = ARGUMENT(1);
newitem = ARGUMENT(0);
}
else {
item = ARGUMENT(0);
newitem = NIL;
}
}
/* Check if argument is a valid sequence, and if start/end
* are correctly specified. */
LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
&start, &end, &length);
/* Check count argument */
if (ocount == UNSPEC) {
count = length;
/* Doesn't matter, but left to right should be slightly faster */
from_end = NIL;
}
else {
CHECK_INDEX(ocount);
count = FIXNUM_VALUE(ocount);
}
/* Check if need to do something */
if (start == end || count == 0)
return (sequence);
CHECK_TEST_0();
/* Resolve comparison function, and expected result of comparison */
if (comparison == NONE) {
if (test_not == UNSPEC) {
if (test == UNSPEC)
lambda = Oeql;
else
lambda = test;
expect = 1;
}
else {
lambda = test_not;
expect = 0;
}
FUNCTION_CHECK(lambda);
}
else
expect = comparison == IFNOT ? 0 : 1;
/* Check for fast path to comparison function */
code = FCODE(lambda);
/* Initialize for loop */
copy = count;
result = sequence;
inplace = function == DELETE || function == NSUBSTITUTE;
xlength = end - start;
/* String is easier */
if (STRINGP(sequence)) {
char *buffer, *string;
if (comparison == NONE) {
CHECK_SCHAR(item);
}
if (substitute) {
CHECK_SCHAR(newitem);
}
if (from_end == NIL) {
xstart = start;
xend = end;
xinc = 1;
}
else {
xstart = end - 1;
xend = start - 1;
xinc = -1;
}
string = THESTR(sequence);
buffer = LispMalloc(length + 1);
/* Copy leading bytes, if any */
for (i = 0; i < start; i++)
buffer[i] = string[i];
for (j = xstart; i != xend && count > 0; i += xinc) {
compare = SCHAR(string[i]);
if (key != UNSPEC) {
compare = APPLY1(key, compare);
/* Value returned by the key predicate may not be protected */
GC_PROTECT(compare);
if (comparison == NONE)
value = FCOMPARE(lambda, item, compare, code);
else
value = APPLY1(lambda, compare) != NIL;
/* Unprotect value returned by the key predicate */
GC_LEAVE();
}
else {
if (comparison == NONE)
value = FCOMPARE(lambda, item, compare, code);
else
value = APPLY1(lambda, compare) != NIL;
}
if (value != expect) {
buffer[j] = string[i];
j += xinc;
}
else {
if (substitute) {
buffer[j] = SCHAR_VALUE(newitem);
j += xinc;
}
else
--count;
}
}
if (count != copy && from_end != NIL)
memmove(buffer + start, buffer + copy - count, count);
/* Copy remaining bytes, if any */
for (; i < length; i++, j++)
buffer[j] = string[i];
buffer[j] = '\0';
xlength = length - (copy - count);
if (inplace) {
CHECK_STRING_WRITABLE(sequence);
/* result is a pointer to sequence */
LispFree(THESTR(sequence));
LispMused(buffer);
THESTR(sequence) = buffer;
STRLEN(sequence) = xlength;
}
else
result = LSTRING2(buffer, xlength);
}
/* If inplace, need to update CAR and CDR of sequence */
else {
LispObj *list, *object;
LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength);
if (!CONSP(sequence))
list = sequence->data.array.list;
else
list = sequence;
/* Put data in a vector */
for (i = 0, object = list; i < start; i++)
object = CDR(object);
for (i = 0; i < xlength; i++, object = CDR(object))
objects[i] = CAR(object);
if (from_end == NIL) {
xstart = 0;
xend = xlength;
xinc = 1;
}
else {
xstart = xlength - 1;
xend = -1;
xinc = -1;
}
/* Check if needs to remove something */
for (i = xstart; i != xend && count > 0; i += xinc) {
compare = objects[i];
if (key != UNSPEC) {
compare = APPLY1(key, compare);
GC_PROTECT(compare);
if (comparison == NONE)
value = FCOMPARE(lambda, item, compare, code);
else
value = APPLY1(lambda, compare) != NIL;
GC_LEAVE();
}
else {
if (comparison == NONE)
value = FCOMPARE(lambda, item, compare, code);
else
value = APPLY1(lambda, compare) != NIL;
}
if (value == expect) {
if (substitute)
objects[i] = newitem;
else
objects[i] = NULL;
--count;
}
}
if (copy != count) {
LispObj *cons = NIL;
i = 0;
object = list;
if (inplace) {
/* While result is NIL, skip initial elements of sequence */
result = start ? list : NIL;
/* Skip initial elements, if any */
for (; i < start; i++, cons = object, object = CDR(object))
;
}
/* Copy initial elements, if any */
else {
result = NIL;
if (start) {
result = cons = CONS(CAR(list), NIL);
GC_PROTECT(result);
for (++i, object = CDR(list);
i < start;
i++, object = CDR(object)) {
RPLACD(cons, CONS(CAR(object), NIL));
cons = CDR(cons);
}
}
}
/* Skip initial removed elements, if any */
for (i = 0; i < xlength && objects[i] == NULL; i++)
;
for (i = 0; i < xlength; i++, object = CDR(object)) {
if (objects[i]) {
if (inplace) {
if (result == NIL)
result = cons = object;
else {
RPLACD(cons, object);
cons = CDR(cons);
}
if (function == NSUBSTITUTE)
RPLACA(cons, objects[i]);
}
else {
if (result == NIL) {
result = cons = CONS(objects[i], NIL);
GC_PROTECT(result);
}
else {
RPLACD(cons, CONS(objects[i], NIL));
cons = CDR(cons);
}
}
}
}
if (inplace) {
if (result == NIL)
result = object;
else
RPLACD(cons, object);
if (!CONSP(sequence)) {
result = sequence;
CAR(result)->data.array.dim =
FIXNUM(length - (copy - count));
}
}
else if (end < length) {
i = end;
/* Copy ending elements, if any */
if (result == NIL) {
result = cons = CONS(CAR(object), NIL);
GC_PROTECT(result);
object = CDR(object);
i++;
}
for (; i < length; i++, object = CDR(object)) {
RPLACD(cons, CONS(CAR(object), NIL));
cons = CDR(cons);
}
}
}
/* Release comparison vector */
LispFree(objects);
}
GC_LEAVE();
return (result);
}
LispObj *
Lisp_Remove(LispBuiltin *builtin)
/*
remove item sequence &key from-end test test-not start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, REMOVE, NONE));
}
LispObj *
Lisp_RemoveIf(LispBuiltin *builtin)
/*
remove-if predicate sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IF));
}
LispObj *
Lisp_RemoveIfNot(LispBuiltin *builtin)
/*
remove-if-not predicate sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IFNOT));
}
LispObj *
Lisp_Remprop(LispBuiltin *builtin)
/*
remprop symbol indicator
*/
{
LispObj *symbol, *indicator;
indicator = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
return (LispRemAtomProperty(symbol->data.atom, indicator));
}
LispObj *
Lisp_Return(LispBuiltin *builtin)
/*
return &optional result
*/
{
unsigned blevel = lisp__data.block.block_level;
LispObj *result;
result = ARGUMENT(0);
while (blevel) {
LispBlock *block = lisp__data.block.block[--blevel];
if (block->type == LispBlockClosure)
/* if reached a function call */
break;
if (block->type == LispBlockTag && block->tag == NIL) {
lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result);
LispBlockUnwind(block);
BLOCKJUMP(block);
}
}
LispDestroy("%s: no visible NIL block", STRFUN(builtin));
/*NOTREACHED*/
return (NIL);
}
LispObj *
Lisp_ReturnFrom(LispBuiltin *builtin)
/*
return-from name &optional result
*/
{
unsigned blevel = lisp__data.block.block_level;
LispObj *name, *result;
result = ARGUMENT(1);
name = ARGUMENT(0);
if (name != NIL && name != T && !SYMBOLP(name))
LispDestroy("%s: %s is not a valid block name",
STRFUN(builtin), STROBJ(name));
while (blevel) {
LispBlock *block = lisp__data.block.block[--blevel];
if (name == block->tag &&
(block->type == LispBlockTag || block->type == LispBlockClosure)) {
lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result);
LispBlockUnwind(block);
BLOCKJUMP(block);
}
if (block->type == LispBlockClosure)
/* can use return-from only in the current function */
break;
}
LispDestroy("%s: no visible block named %s",
STRFUN(builtin), STROBJ(name));
/*NOTREACHED*/
return (NIL);
}
static LispObj *
LispXReverse(LispBuiltin *builtin, int inplace)
/*
nreverse sequence
reverse sequence
*/
{
long length;
LispObj *list, *result = NIL;
LispObj *sequence;
sequence = ARGUMENT(0);
/* Do error checking for arrays and object type. */
length = LispLength(sequence);
if (length <= 1)
return (sequence);
switch (XOBJECT_TYPE(sequence)) {
case LispString_t: {
long i;
char *from, *to;
from = THESTR(sequence) + length - 1;
if (inplace) {
char temp;
CHECK_STRING_WRITABLE(sequence);
to = THESTR(sequence);
for (i = 0; i < length / 2; i++) {
temp = to[i];
to[i] = from[-i];
from[-i] = temp;
}
result = sequence;
}
else {
to = LispMalloc(length + 1);
to[length] = '\0';
for (i = 0; i < length; i++)
to[i] = from[-i];
result = STRING2(to);
}
} return (result);
case LispCons_t:
if (inplace) {
long i, j;
LispObj *temp;
/* For large lists this can be very slow, but for small
* amounts of data, this avoid allocating a buffer to
* to store the CAR of the sequence. This is only done
* to not destroy the contents of a variable.
*/
for (i = 0, list = sequence;
i < (length + 1) / 2;
i++, list = CDR(list))
;
length /= 2;
for (i = 0; i < length; i++, list = CDR(list)) {
for (j = length - i - 1, result = sequence;
j > 0;
j--, result = CDR(result))
;
temp = CAR(list);
RPLACA(list, CAR(result));
RPLACA(result, temp);
}
return (sequence);
}
list = sequence;
break;
case LispArray_t:
if (inplace) {
sequence->data.array.list =
LispReverse(sequence->data.array.list);
return (sequence);
}
list = sequence->data.array.list;
break;
default: /* LispNil_t */
return (result);
}
{
GC_ENTER();
LispObj *cons;
result = cons = CONS(CAR(list), NIL);
GC_PROTECT(result);
for (list = CDR(list); CONSP(list); list = CDR(list)) {
RPLACD(cons, CONS(CAR(list), NIL));
cons = CDR(cons);
}
result = LispReverse(result);
GC_LEAVE();
}
if (ARRAYP(sequence)) {
list = result;
result = LispNew(list, NIL);
result->type = LispArray_t;
result->data.array.list = list;
result->data.array.dim = sequence->data.array.dim;
result->data.array.rank = sequence->data.array.rank;
result->data.array.type = sequence->data.array.type;
result->data.array.zero = sequence->data.array.zero;
}
return (result);
}
LispObj *
Lisp_Reverse(LispBuiltin *builtin)
/*
reverse sequence
*/
{
return (LispXReverse(builtin, 0));
}
LispObj *
Lisp_Rplaca(LispBuiltin *builtin)
/*
rplaca place value
*/
{
LispObj *place, *value;
value = ARGUMENT(1);
place = ARGUMENT(0);
CHECK_CONS(place);
RPLACA(place, value);
return (place);
}
LispObj *
Lisp_Rplacd(LispBuiltin *builtin)
/*
rplacd place value
*/
{
LispObj *place, *value;
value = ARGUMENT(1);
place = ARGUMENT(0);
CHECK_CONS(place);
RPLACD(place, value);
return (place);
}
LispObj *
Lisp_Search(LispBuiltin *builtin)
/*
search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2
*/
{
int code = 0, expect, value;
long start1, start2, end1, end2, length1, length2, off1, off2, offset = -1;
LispObj *cmp1, *cmp2, *list1 = NIL, *lambda;
SeqInfo seq1, seq2;
LispObj *sequence1, *sequence2, *from_end, *test, *test_not,
*key, *ostart1, *ostart2, *oend1, *oend2;
oend2 = ARGUMENT(9);
oend1 = ARGUMENT(8);
ostart2 = ARGUMENT(7);
ostart1 = ARGUMENT(6);
key = ARGUMENT(5);
test_not = ARGUMENT(4);
test = ARGUMENT(3);
from_end = ARGUMENT(2);
sequence2 = ARGUMENT(1);
sequence1 = ARGUMENT(0);
LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1,
&start1, &end1, &length1);
LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2,
&start2, &end2, &length2);
/* Check for special conditions */
if (start1 == end1)
return (FIXNUM(end2));
else if (start2 == end2)
return (start1 == end1 ? FIXNUM(start2) : NIL);
CHECK_TEST();
if (from_end == UNSPEC)
from_end = NIL;
SETSEQ(seq1, sequence1);
SETSEQ(seq2, sequence2);
length1 = end1 - start1;
length2 = end2 - start2;
/* update start of sequences */
if (start1) {
if (seq1.type == LispString_t)
seq1.data.string += start1;
else {
for (cmp1 = seq1.data.list; start1; cmp1 = CDR(cmp1), --start1)
;
seq1.data.list = cmp1;
}
end1 = length1;
}
if (start2) {
if (seq2.type == LispString_t)
seq2.data.string += start2;
else {
for (cmp2 = seq2.data.list; start2; cmp2 = CDR(cmp2), --start2)
;
seq2.data.list = cmp2;
}
end2 = length2;
}
/* easier case */
if (from_end == NIL) {
LispObj *list2 = NIL;
/* while a match is possible */
while (end2 - start2 >= length1) {
/* prepare to search */
off1 = 0;
off2 = start2;
if (seq1.type != LispString_t)
list1 = seq1.data.list;
if (seq2.type != LispString_t)
list2 = seq2.data.list;
/* for every element that must match in sequence1 */
while (off1 < length1) {
if (seq1.type == LispString_t)
cmp1 = SCHAR(seq1.data.string[off1]);
else
cmp1 = CAR(list1);
if (seq2.type == LispString_t)
cmp2 = SCHAR(seq2.data.string[off2]);
else
cmp2 = CAR(list2);
if (key != UNSPEC) {
cmp1 = APPLY1(key, cmp1);
cmp2 = APPLY1(key, cmp2);
}
/* compare elements */
value = FCOMPARE(lambda, cmp1, cmp2, code);
if (value != expect)
break;
/* update offsets/sequence pointers */
++off1;
++off2;
if (seq1.type != LispString_t)
list1 = CDR(list1);
if (seq2.type != LispString_t)
list2 = CDR(list2);
}
/* if everything matched */
if (off1 == end1) {
offset = off2 - length1;
break;
}
/* update offset/sequence2 pointer */
++start2;
if (seq2.type != LispString_t)
seq2.data.list = CDR(seq2.data.list);
}
}
else {
/* allocate vector if required, only list2 requires it.
* list1 can be traversed forward */
if (seq2.type != LispString_t) {
cmp2 = seq2.data.list;
seq2.data.vector = LispMalloc(sizeof(LispObj*) * length2);
for (off2 = 0; off2 < end2; off2++, cmp2 = CDR(cmp2))
seq2.data.vector[off2] = CAR(cmp2);
}
/* while a match is possible */
while (end2 >= length1) {
/* prepare to search */
off1 = 0;
off2 = end2 - length1;
if (seq1.type != LispString_t)
list1 = seq1.data.list;
/* for every element that must match in sequence1 */
while (off1 < end1) {
if (seq1.type == LispString_t)
cmp1 = SCHAR(seq1.data.string[off1]);
else
cmp1 = CAR(list1);
if (seq2.type == LispString_t)
cmp2 = SCHAR(seq2.data.string[off2]);
else
cmp2 = seq2.data.vector[off2];
if (key != UNSPEC) {
cmp1 = APPLY1(key, cmp1);
cmp2 = APPLY1(key, cmp2);
}
/* Compare elements */
value = FCOMPARE(lambda, cmp1, cmp2, code);
if (value != expect)
break;
/* Update offsets */
++off1;
++off2;
if (seq1.type != LispString_t)
list1 = CDR(list1);
}
/* If all elements matched */
if (off1 == end1) {
offset = off2 - length1;
break;
}
/* Update offset */
--end2;
}
if (seq2.type != LispString_t)
LispFree(seq2.data.vector);
}
return (offset == -1 ? NIL : FIXNUM(offset));
}
/*
* ext::getenv
*/
LispObj *
Lisp_Setenv(LispBuiltin *builtin)
/*
setenv name value &optional overwrite
*/
{
char *name, *value;
LispObj *oname, *ovalue, *overwrite;
overwrite = ARGUMENT(2);
ovalue = ARGUMENT(1);
oname = ARGUMENT(0);
CHECK_STRING(oname);
name = THESTR(oname);
CHECK_STRING(ovalue);
value = THESTR(ovalue);
setenv(name, value, overwrite != UNSPEC && overwrite != NIL);
value = getenv(name);
return (value ? STRING(value) : NIL);
}
LispObj *
Lisp_Set(LispBuiltin *builtin)
/*
set symbol value
*/
{
LispAtom *atom;
LispObj *symbol, *value;
value = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
atom = symbol->data.atom;
if (atom->dyn)
LispSetVar(symbol, value);
else if (atom->watch || !atom->a_object)
LispSetAtomObjectProperty(atom, value);
else {
CHECK_CONSTANT(symbol);
SETVALUE(atom, value);
}
return (value);
}
LispObj *
Lisp_SetDifference(LispBuiltin *builtin)
/*
set-difference list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, SETDIFFERENCE));
}
LispObj *
Lisp_SetExclusiveOr(LispBuiltin *builtin)
/*
set-exclusive-or list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, SETEXCLUSIVEOR));
}
LispObj *
Lisp_NsetExclusiveOr(LispBuiltin *builtin)
/*
nset-exclusive-or list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, NSETEXCLUSIVEOR));
}
LispObj *
Lisp_SetQ(LispBuiltin *builtin)
/*
setq &rest form
*/
{
LispObj *result, *variable, *form;
form = ARGUMENT(0);
result = NIL;
for (; CONSP(form); form = CDR(form)) {
variable = CAR(form);
CHECK_SYMBOL(variable);
CHECK_CONSTANT(variable);
form = CDR(form);
if (!CONSP(form))
LispDestroy("%s: odd number of arguments", STRFUN(builtin));
result = EVAL(CAR(form));
LispSetVar(variable, result);
}
return (result);
}
LispObj *
Lisp_Psetq(LispBuiltin *builtin)
/*
psetq &rest form
*/
{
GC_ENTER();
int base = gc__protect;
LispObj *value, *symbol, *list, *form;
form = ARGUMENT(0);
/* parallel setq, first pass evaluate values and basic error checking */
for (list = form; CONSP(list); list = CDR(list)) {
symbol = CAR(list);
CHECK_SYMBOL(symbol);
list = CDR(list);
if (!CONSP(list))
LispDestroy("%s: odd number of arguments", STRFUN(builtin));
value = EVAL(CAR(list));
GC_PROTECT(value);
}
/* second pass, assign values */
for (; CONSP(form); form = CDDR(form)) {
symbol = CAR(form);
CHECK_CONSTANT(symbol);
LispSetVar(symbol, lisp__data.protect.objects[base++]);
}
GC_LEAVE();
return (NIL);
}
LispObj *
Lisp_Setf(LispBuiltin *builtin)
/*
setf &rest form
*/
{
LispAtom *atom;
LispObj *setf, *place, *value, *result = NIL, *data;
LispObj *form;
form = ARGUMENT(0);
for (; CONSP(form); form = CDR(form)) {
place = CAR(form);
form = CDR(form);
if (!CONSP(form))
LispDestroy("%s: odd number of arguments", STRFUN(builtin));
value = CAR(form);
if (!POINTERP(place))
goto invalid_place;
if (XSYMBOLP(place)) {
CHECK_CONSTANT(place);
result = EVAL(value);
(void)LispSetVar(place, result);
}
else if (XCONSP(place)) {
/* it really should not be required to protect any object
* evaluated here, but is done for safety in case one of
* the evaluated forms returns data not gc protected, what
* could cause surprises if the object is garbage collected
* before finishing setf. */
GC_ENTER();
setf = CAR(place);
if (!SYMBOLP(setf))
goto invalid_place;
if (!CONSP(CDR(place)))
goto invalid_place;
value = EVAL(value);
GC_PROTECT(value);
atom = setf->data.atom;
if (atom->a_defsetf == 0) {
if (atom->a_defstruct &&
atom->property->structure.function >= 0) {
/* Use a default setf method for the structure field, as
* if this definition have been done
* (defsetf THE-STRUCT-FIELD (struct) (value)
* `(lisp::struct-store 'THE-STRUCT-FIELD ,struct ,value))
*/
place = CDR(place);
data = CAR(place);
if (CONSP(CDR(place)))
goto invalid_place;
data = EVAL(data);
GC_PROTECT(data);
result = APPLY3(Ostruct_store, setf, data, value);
GC_LEAVE();
continue;
}
/* Must also expand macros */
else if (atom->a_function &&
atom->property->fun.function->funtype == LispMacro) {
result = LispRunSetfMacro(atom, CDR(place), value);
continue;
}
goto invalid_place;
}
place = CDR(place);
setf = setf->data.atom->property->setf;
if (SYMBOLP(setf)) {
LispObj *arguments, *cons;
if (!CONSP(CDR(place))) {
arguments = EVAL(CAR(place));
GC_PROTECT(arguments);
result = APPLY2(setf, arguments, value);
}
else if (!CONSP(CDDR(place))) {
arguments = EVAL(CAR(place));
GC_PROTECT(arguments);
cons = EVAL(CADR(place));
GC_PROTECT(cons);
result = APPLY3(setf, arguments, cons, value);
}
else {
arguments = cons = CONS(EVAL(CAR(place)), NIL);
GC_PROTECT(arguments);
for (place = CDR(place); CONSP(place); place = CDR(place)) {
RPLACD(cons, CONS(EVAL(CAR(place)), NIL));
cons = CDR(cons);
}
RPLACD(cons, CONS(value, NIL));
result = APPLY(setf, arguments);
}
}
else
result = LispRunSetf(atom->property->salist, setf, place, value);
GC_LEAVE();
}
else
goto invalid_place;
}
return (result);
invalid_place:
LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place));
/*NOTREACHED*/
return (NIL);
}
LispObj *
Lisp_Psetf(LispBuiltin *builtin)
/*
psetf &rest form
*/
{
int base;
GC_ENTER();
LispAtom *atom;
LispObj *setf, *place = NIL, *value, *data;
LispObj *form;
form = ARGUMENT(0);
/* parallel setf, first pass evaluate values and basic error checking */
base = gc__protect;
for (setf = form; CONSP(setf); setf = CDR(setf)) {
if (!POINTERP(CAR(setf)))
goto invalid_place;
setf = CDR(setf);
if (!CONSP(setf))
LispDestroy("%s: odd number of arguments", STRFUN(builtin));
value = EVAL(CAR(setf));
GC_PROTECT(value);
}
/* second pass, assign values */
for (; CONSP(form); form = CDDR(form)) {
place = CAR(form);
value = lisp__data.protect.objects[base++];
if (XSYMBOLP(place)) {
CHECK_CONSTANT(place);
(void)LispSetVar(place, value);
}
else if (XCONSP(place)) {
LispObj *arguments, *cons;
int xbase = lisp__data.protect.length;
setf = CAR(place);
if (!SYMBOLP(setf))
goto invalid_place;
if (!CONSP(CDR(place)))
goto invalid_place;
atom = setf->data.atom;
if (atom->a_defsetf == 0) {
if (atom->a_defstruct &&
atom->property->structure.function >= 0) {
place = CDR(place);
data = CAR(place);
if (CONSP(CDR(place)))
goto invalid_place;
data = EVAL(data);
GC_PROTECT(data);
(void)APPLY3(Ostruct_store, setf, data, value);
lisp__data.protect.length = xbase;
continue;
}
else if (atom->a_function &&
atom->property->fun.function->funtype == LispMacro) {
(void)LispRunSetfMacro(atom, CDR(place), value);
lisp__data.protect.length = xbase;
continue;
}
goto invalid_place;
}
place = CDR(place);
setf = setf->data.atom->property->setf;
if (SYMBOLP(setf)) {
if (!CONSP(CDR(place))) {
arguments = EVAL(CAR(place));
GC_PROTECT(arguments);
(void)APPLY2(setf, arguments, value);
}
else if (!CONSP(CDDR(place))) {
arguments = EVAL(CAR(place));
GC_PROTECT(arguments);
cons = EVAL(CADR(place));
GC_PROTECT(cons);
(void)APPLY3(setf, arguments, cons, value);
}
else {
arguments = cons = CONS(EVAL(CAR(place)), NIL);
GC_PROTECT(arguments);
for (place = CDR(place); CONSP(place); place = CDR(place)) {
RPLACD(cons, CONS(EVAL(CAR(place)), NIL));
cons = CDR(cons);
}
RPLACD(cons, CONS(value, NIL));
(void)APPLY(setf, arguments);
}
lisp__data.protect.length = xbase;
}
else
(void)LispRunSetf(atom->property->salist, setf, place, value);
}
else
goto invalid_place;
}
GC_LEAVE();
return (NIL);
invalid_place:
LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place));
/*NOTREACHED*/
return (NIL);
}
LispObj *
Lisp_Sleep(LispBuiltin *builtin)
/*
sleep seconds
*/
{
long sec, msec;
double value, dsec;
LispObj *seconds;
seconds = ARGUMENT(0);
value = -1.0;
switch (OBJECT_TYPE(seconds)) {
case LispFixnum_t:
value = FIXNUM_VALUE(seconds);
break;
case LispDFloat_t:
value = DFLOAT_VALUE(seconds);
break;
default:
break;
}
if (value < 0.0 || value > MOST_POSITIVE_FIXNUM)
LispDestroy("%s: %s is not a positive fixnum",
STRFUN(builtin), STROBJ(seconds));
msec = modf(value, &dsec) * 1e6;
sec = dsec;
if (sec)
sleep(sec);
if (msec)
usleep(msec);
return (NIL);
}
/*
* This function is called recursively, but the contents of "list2" are
* kept gc protected until it returns to LispSort. This is required partly
* because the "gc protection logic" protects an object, not the contents
* of the c pointer.
*/
static LispObj *
LispMergeSort(LispObj *list, LispObj *predicate, LispObj *key, int code)
{
int protect;
LispObj *list1, *list2, *left, *right, *result, *cons;
/* Check if list length is larger than 1 */
if (!CONSP(list) || !CONSP(CDR(list)))
return (list);
list1 = list2 = list;
for (;;) {
list = CDR(list);
if (!CONSP(list))
break;
list = CDR(list);
if (!CONSP(list))
break;
list2 = CDR(list2);
}
cons = list2;
list2 = CDR(list2);
RPLACD(cons, NIL);
protect = 0;
if (lisp__data.protect.length + 2 >= lisp__data.protect.space)
LispMoreProtects();
lisp__data.protect.objects[lisp__data.protect.length++] = list2;
list1 = LispMergeSort(list1, predicate, key, code);
list2 = LispMergeSort(list2, predicate, key, code);
left = CAR(list1);
right = CAR(list2);
if (key != UNSPEC) {
protect = lisp__data.protect.length;
left = APPLY1(key, left);
lisp__data.protect.objects[protect] = left;
right = APPLY1(key, right);
lisp__data.protect.objects[protect + 1] = right;
}
result = NIL;
for (;;) {
if ((FCOMPARE(predicate, left, right, code)) == 0 &&
(FCOMPARE(predicate, right, left, code)) == 1) {
/* right is "smaller" */
if (result == NIL)
result = list2;
else
RPLACD(cons, list2);
cons = list2;
list2 = CDR(list2);
if (!CONSP(list2)) {
RPLACD(cons, list1);
break;
}
right = CAR(list2);
if (key != UNSPEC) {
right = APPLY1(key, right);
lisp__data.protect.objects[protect + 1] = right;
}
}
else {
/* left is "smaller" */
if (result == NIL)
result = list1;
else
RPLACD(cons, list1);
cons = list1;
list1 = CDR(list1);
if (!CONSP(list1)) {
RPLACD(cons, list2);
break;
}
left = CAR(list1);
if (key != UNSPEC) {
left = APPLY1(key, left);
lisp__data.protect.objects[protect] = left;
}
}
}
if (key != UNSPEC)
lisp__data.protect.length = protect;
return (result);
}
/* XXX The first version made a copy of the list and then adjusted
* the CARs of the list. To minimize GC time now it is now doing
* the sort inplace. So, instead of writing just (sort variable)
* now it is required to write (setq variable (sort variable))
* if the variable should always keep all elements.
*/
LispObj *
Lisp_Sort(LispBuiltin *builtin)
/*
sort sequence predicate &key key
*/
{
GC_ENTER();
int istring, code;
long length;
char *string;
LispObj *list, *work, *cons = NULL;
LispObj *sequence, *predicate, *key;
key = ARGUMENT(2);
predicate = ARGUMENT(1);
sequence = ARGUMENT(0);
length = LispLength(sequence);
if (length < 2)
return (sequence);
list = sequence;
istring = XSTRINGP(sequence);
if (istring) {
CHECK_STRING_WRITABLE(sequence);
/* Convert string to list */
string = THESTR(sequence);
work = cons = CONS(SCHAR(string[0]), NIL);
GC_PROTECT(work);
for (++string; *string; ++string) {
RPLACD(cons, CONS(SCHAR(*string), NIL));
cons = CDR(cons);
}
}
else if (ARRAYP(list))
work = list->data.array.list;
else
work = list;
FUNCTION_CHECK(predicate);
code = FCODE(predicate);
work = LispMergeSort(work, predicate, key, code);
if (istring) {
/* Convert list to string */
string = THESTR(sequence);
for (; CONSP(work); ++string, work = CDR(work))
*string = SCHAR_VALUE(CAR(work));
}
else if (ARRAYP(list))
list->data.array.list = work;
else
sequence = work;
GC_LEAVE();
return (sequence);
}
LispObj *
Lisp_Subseq(LispBuiltin *builtin)
/*
subseq sequence start &optional end
*/
{
long start, end, length, seqlength;
LispObj *sequence, *ostart, *oend, *result;
oend = ARGUMENT(2);
ostart = ARGUMENT(1);
sequence = ARGUMENT(0);
LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
&start, &end, &length);
seqlength = end - start;
if (sequence == NIL)
result = NIL;
else if (XSTRINGP(sequence)) {
char *string = LispMalloc(seqlength + 1);
memcpy(string, THESTR(sequence) + start, seqlength);
string[seqlength] = '\0';
result = STRING2(string);
}
else {
GC_ENTER();
LispObj *object;
if (end > start) {
/* list or array */
int count;
LispObj *cons;
if (ARRAYP(sequence))
object = sequence->data.array.list;
else
object = sequence;
/* goto first element to copy */
for (count = 0; count < start; count++, object = CDR(object))
;
result = cons = CONS(CAR(object), NIL);
GC_PROTECT(result);
for (++count, object = CDR(object); count < end; count++,
object = CDR(object)) {
RPLACD(cons, CONS(CAR(object), NIL));
cons = CDR(cons);
}
}
else
result = NIL;
if (ARRAYP(sequence)) {
object = LispNew(NIL, NIL);
GC_PROTECT(object);
object->type = LispArray_t;
object->data.array.list = result;
object->data.array.dim = CONS(FIXNUM(seqlength), NIL);
object->data.array.rank = 1;
object->data.array.type = sequence->data.array.type;
object->data.array.zero = length == 0;
result = object;
}
GC_LEAVE();
}
return (result);
}
LispObj *
Lisp_Subsetp(LispBuiltin *builtin)
/*
subsetp list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, SUBSETP));
}
LispObj *
Lisp_Substitute(LispBuiltin *builtin)
/*
substitute newitem olditem sequence &key from-end test test-not start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, NONE));
}
LispObj *
Lisp_SubstituteIf(LispBuiltin *builtin)
/*
substitute-if newitem test sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IF));
}
LispObj *
Lisp_SubstituteIfNot(LispBuiltin *builtin)
/*
substitute-if-not newitem test sequence &key from-end start end count key
*/
{
return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IFNOT));
}
LispObj *
Lisp_Symbolp(LispBuiltin *builtin)
/*
symbolp object
*/
{
LispObj *object;
object = ARGUMENT(0);
return (SYMBOLP(object) ? T : NIL);
}
LispObj *
Lisp_SymbolFunction(LispBuiltin *builtin)
/*
symbol-function symbol
*/
{
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
return (LispSymbolFunction(symbol));
}
LispObj *
Lisp_SymbolName(LispBuiltin *builtin)
/*
symbol-name symbol
*/
{
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
return (LispSymbolName(symbol));
}
LispObj *
Lisp_SymbolPackage(LispBuiltin *builtin)
/*
symbol-package symbol
*/
{
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
symbol = symbol->data.atom->package;
return (symbol ? symbol : NIL);
}
LispObj *
Lisp_SymbolPlist(LispBuiltin *builtin)
/*
symbol-plist symbol
*/
{
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
return (symbol->data.atom->a_property ?
symbol->data.atom->property->properties : NIL);
}
LispObj *
Lisp_SymbolValue(LispBuiltin *builtin)
/*
symbol-value symbol
*/
{
LispAtom *atom;
LispObj *symbol;
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
atom = symbol->data.atom;
if (!atom->a_object || atom->property->value == UNBOUND) {
if (atom->package == lisp__data.keyword)
return (symbol);
LispDestroy("%s: the symbol %s has no value",
STRFUN(builtin), STROBJ(symbol));
}
return (atom->dyn ? LispGetVar(symbol) : atom->property->value);
}
LispObj *
Lisp_Tagbody(LispBuiltin *builtin)
/*
tagbody &rest body
*/
{
GC_ENTER();
int stack, lex, length;
LispObj *list, *body, *ptr, *tag, *labels, *map, **p_body;
LispBlock *block;
body = ARGUMENT(0);
/* Save environment information */
stack = lisp__data.stack.length;
lex = lisp__data.env.lex;
length = lisp__data.env.length;
/* Since the body may be large, and the code may iterate several
* thousand times, it is not a bad idea to avoid checking all
* elements of the body to verify if it is a tag. */
for (labels = map = NIL, ptr = body; CONSP(ptr); ptr = CDR(ptr)) {
tag = CAR(ptr);
switch (OBJECT_TYPE(tag)) {
case LispNil_t:
case LispAtom_t:
case LispFixnum_t:
/* Don't allow duplicated labels */
for (list = labels; CONSP(list); list = CDDR(list)) {
if (CAR(list) == tag)
LispDestroy("%s: tag %s specified more than once",
STRFUN(builtin), STROBJ(tag));
}
if (labels == NIL) {
labels = CONS(tag, CONS(NIL, NIL));
map = CDR(labels);
GC_PROTECT(labels);
}
else {
RPLACD(map, CONS(tag, CONS(NIL, NIL)));
map = CDDR(map);
}
break;
case LispCons_t:
/* Restart point for tag */
if (map != NIL && CAR(map) == NIL)
RPLACA(map, ptr);
break;
default:
break;
}
}
/* Check for consecutive labels without code between them */
for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) {
if (CADR(ptr) == NIL) {
for (map = CDDR(ptr); CONSP(map); map = CDDR(map)) {
if (CADR(map) != NIL) {
RPLACA(CDR(ptr), CADR(map));
break;
}
}
}
}
/* Initialize */
list = body;
p_body = &body;
block = LispBeginBlock(NIL, LispBlockBody);
/* Loop */
if (setjmp(block->jmp) != 0) {
/* Restore environment */
lisp__data.stack.length = stack;
lisp__data.env.lex = lex;
lisp__data.env.head = lisp__data.env.length = length;
tag = lisp__data.block.block_ret;
for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) {
map = CAR(ptr);
if (map == tag)
break;
}
if (!CONSP(ptr))
LispDestroy("%s: no such tag %s", STRFUN(builtin), STROBJ(tag));
*p_body = CADR(ptr);
}
/* Execute code */
for (; CONSP(body); body = CDR(body)) {
LispObj *form = CAR(body);
if (CONSP(form))
EVAL(form);
}
/* If got here, (go) not called, else, labels will be candidate to gc
* when GC_LEAVE() be called by the code in the bottom of the stack. */
GC_LEAVE();
/* Finished */
LispEndBlock(block);
/* Always return NIL */
return (NIL);
}
LispObj *
Lisp_The(LispBuiltin *builtin)
/*
the value-type form
*/
{
LispObj *value_type, *form;
form = ARGUMENT(1);
value_type = ARGUMENT(0);
form = EVAL(form);
return (LispCoerce(builtin, form, value_type));
}
LispObj *
Lisp_Throw(LispBuiltin *builtin)
/*
throw tag result
*/
{
unsigned blevel = lisp__data.block.block_level;
LispObj *tag, *result;
result = ARGUMENT(1);
tag = ARGUMENT(0);
tag = EVAL(tag);
if (blevel == 0)
LispDestroy("%s: not within a block", STRFUN(builtin));
while (blevel) {
LispBlock *block = lisp__data.block.block[--blevel];
if (block->type == LispBlockCatch && tag == block->tag) {
lisp__data.block.block_ret = EVAL(result);
LispBlockUnwind(block);
BLOCKJUMP(block);
}
}
LispDestroy("%s: %s is not a valid tag", STRFUN(builtin), STROBJ(tag));
/*NOTREACHED*/
return (NIL);
}
static LispObj *
LispTreeEqual(LispObj *left, LispObj *right, LispObj *test, int expect)
{
LispObj *cmp_left, *cmp_right;
if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right)))
return (NIL);
if (CONSP(left)) {
for (; CONSP(left) && CONSP(right);
left = CDR(left), right = CDR(right)) {
cmp_left = CAR(left);
cmp_right = CAR(right);
if ((OBJECT_TYPE(cmp_left)) ^ (OBJECT_TYPE(cmp_right)))
return (NIL);
if (CONSP(cmp_left)) {
if (LispTreeEqual(cmp_left, cmp_right, test, expect) == NIL)
return (NIL);
}
else {
if (POINTERP(cmp_left) &&
(XQUOTEP(cmp_left) || XBACKQUOTEP(cmp_left))) {
cmp_left = cmp_left->data.quote;
cmp_right = cmp_right->data.quote;
}
else if (COMMAP(cmp_left)) {
cmp_left = cmp_left->data.comma.eval;
cmp_right = cmp_right->data.comma.eval;
}
if ((APPLY2(test, cmp_left, cmp_right) != NIL) != expect)
return (NIL);
}
}
if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right)))
return (NIL);
}
if (POINTERP(left) && (XQUOTEP(left) || XBACKQUOTEP(left))) {
left = left->data.quote;
right = right->data.quote;
}
else if (COMMAP(left)) {
left = left->data.comma.eval;
right = right->data.comma.eval;
}
return ((APPLY2(test, left, right) != NIL) == expect ? T : NIL);
}
LispObj *
Lisp_TreeEqual(LispBuiltin *builtin)
/*
tree-equal tree-1 tree-2 &key test test-not
*/
{
int expect;
LispObj *compare;
LispObj *tree_1, *tree_2, *test, *test_not;
test_not = ARGUMENT(3);
test = ARGUMENT(2);
tree_2 = ARGUMENT(1);
tree_1 = ARGUMENT(0);
CHECK_TEST_0();
if (test_not != UNSPEC) {
expect = 0;
compare = test_not;
}
else {
if (test == UNSPEC)
test = Oeql;
expect = 1;
compare = test;
}
return (LispTreeEqual(tree_1, tree_2, compare, expect));
}
LispObj *
Lisp_Typep(LispBuiltin *builtin)
/*
typep object type
*/
{
LispObj *result = NULL;
LispObj *object, *type;
type = ARGUMENT(1);
object = ARGUMENT(0);
if (SYMBOLP(type)) {
Atom_id atom = ATOMID(type);
if (OBJECT_TYPE(object) == LispStruct_t)
result = ATOMID(CAR(object->data.struc.def)) == atom ? T : NIL;
else if (type->data.atom->a_defstruct &&
type->data.atom->property->structure.function == STRUCT_NAME)
result = NIL;
else if (atom == Snil)
result = object == NIL ? T : NIL;
else if (atom == St)
result = object == T ? T : NIL;
else if (atom == Satom)
result = !CONSP(object) ? T : NIL;
else if (atom == Ssymbol)
result = SYMBOLP(object) || object == NIL || object == T ? T : NIL;
else if (atom == Sinteger)
result = INTEGERP(object) ? T : NIL;
else if (atom == Srational)
result = RATIONALP(object) ? T : NIL;
else if (atom == Scons || atom == Slist)
result = CONSP(object) ? T : NIL;
else if (atom == Sstring)
result = STRINGP(object) ? T : NIL;
else if (atom == Scharacter)
result = SCHARP(object) ? T : NIL;
else if (atom == Scomplex)
result = COMPLEXP(object) ? T : NIL;
else if (atom == Svector || atom == Sarray)
result = ARRAYP(object) ? T : NIL;
else if (atom == Skeyword)
result = KEYWORDP(object) ? T : NIL;
else if (atom == Sfunction)
result = LAMBDAP(object) ? T : NIL;
else if (atom == Spathname)
result = PATHNAMEP(object) ? T : NIL;
else if (atom == Sopaque)
result = OPAQUEP(object) ? T : NIL;
}
else if (CONSP(type)) {
if (OBJECT_TYPE(object) == LispStruct_t &&
SYMBOLP(CAR(type)) && ATOMID(CAR(type)) == Sstruct &&
SYMBOLP(CAR(CDR(type))) && CDR(CDR(type)) == NIL) {
result = ATOMID(CAR(object->data.struc.def)) ==
ATOMID(CAR(CDR(type))) ? T : NIL;
}
}
else if (type == NIL)
result = object == NIL ? T : NIL;
else if (type == T)
result = object == T ? T : NIL;
if (result == NULL)
LispDestroy("%s: bad type specification %s",
STRFUN(builtin), STROBJ(type));
return (result);
}
LispObj *
Lisp_Union(LispBuiltin *builtin)
/*
union list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, UNION));
}
LispObj *
Lisp_Nunion(LispBuiltin *builtin)
/*
nunion list1 list2 &key test test-not key
*/
{
return (LispListSet(builtin, NUNION));
}
LispObj *
Lisp_Unless(LispBuiltin *builtin)
/*
unless test &rest body
*/
{
LispObj *result, *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
result = NIL;
test = EVAL(test);
RETURN_COUNT = 0;
if (test == NIL) {
for (; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
}
return (result);
}
/*
* ext::until
*/
LispObj *
Lisp_Until(LispBuiltin *builtin)
/*
until test &rest body
*/
{
LispObj *result, *test, *body, *prog;
body = ARGUMENT(1);
test = ARGUMENT(0);
result = NIL;
for (;;) {
if ((result = EVAL(test)) == NIL) {
for (prog = body; CONSP(prog); prog = CDR(prog))
(void)EVAL(CAR(prog));
}
else
break;
}
return (result);
}
LispObj *
Lisp_UnwindProtect(LispBuiltin *builtin)
/*
unwind-protect protect &rest cleanup
*/
{
LispObj *result, **presult = &result;
int did_jump, *pdid_jump = &did_jump, destroyed;
LispBlock *block;
LispObj *protect, *cleanup, **pcleanup = &cleanup;
cleanup = ARGUMENT(1);
protect = ARGUMENT(0);
/* run protected code */
*presult = NIL;
*pdid_jump = 1;
block = LispBeginBlock(NIL, LispBlockProtect);
if (setjmp(block->jmp) == 0) {
*presult = EVAL(protect);
*pdid_jump = 0;
}
LispEndBlock(block);
if (!lisp__data.destroyed && *pdid_jump)
*presult = lisp__data.block.block_ret;
destroyed = lisp__data.destroyed;
lisp__data.destroyed = 0;
/* run cleanup, unprotected code */
if (CONSP(*pcleanup))
for (; CONSP(cleanup); cleanup = CDR(cleanup))
(void)EVAL(CAR(cleanup));
if (destroyed) {
/* in case there is another unwind-protect */
LispBlockUnwind(NULL);
/* if not, just return to the toplevel */
lisp__data.destroyed = 1;
LispDestroy(".");
}
return (result);
}
static LispObj *
LispValuesList(LispBuiltin *builtin, int check_list)
{
long i, count;
LispObj *result;
LispObj *list;
list = ARGUMENT(0);
count = LispLength(list) - 1;
if (count >= 0) {
result = CAR(list);
if ((RETURN_CHECK(count)) != count)
LispDestroy("%s: too many values", STRFUN(builtin));
RETURN_COUNT = count;
for (i = 0, list = CDR(list); count && CONSP(list);
count--, i++, list = CDR(list))
RETURN(i) = CAR(list);
if (check_list) {
CHECK_LIST(list);
}
}
else {
RETURN_COUNT = -1;
result = NIL;
}
return (result);
}
LispObj *
Lisp_Values(LispBuiltin *builtin)
/*
values &rest objects
*/
{
return (LispValuesList(builtin, 0));
}
LispObj *
Lisp_ValuesList(LispBuiltin *builtin)
/*
values-list list
*/
{
return (LispValuesList(builtin, 1));
}
LispObj *
Lisp_Vector(LispBuiltin *builtin)
/*
vector &rest objects
*/
{
LispObj *objects;
objects = ARGUMENT(0);
return (VECTOR(objects));
}
LispObj *
Lisp_When(LispBuiltin *builtin)
/*
when test &rest body
*/
{
LispObj *result, *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
result = NIL;
test = EVAL(test);
RETURN_COUNT = 0;
if (test != NIL) {
for (; CONSP(body); body = CDR(body))
result = EVAL(CAR(body));
}
return (result);
}
/*
* ext::while
*/
LispObj *
Lisp_While(LispBuiltin *builtin)
/*
while test &rest body
*/
{
LispObj *test, *body, *prog;
body = ARGUMENT(1);
test = ARGUMENT(0);
for (;;) {
if (EVAL(test) != NIL) {
for (prog = body; CONSP(prog); prog = CDR(prog))
(void)EVAL(CAR(prog));
}
else
break;
}
return (NIL);
}
/*
* ext::unsetenv
*/
LispObj *
Lisp_Unsetenv(LispBuiltin *builtin)
/*
unsetenv name
*/
{
char *name;
LispObj *oname;
oname = ARGUMENT(0);
CHECK_STRING(oname);
name = THESTR(oname);
unsetenv(name);
return (NIL);
}
LispObj *
Lisp_XeditEltStore(LispBuiltin *builtin)
/*
lisp::elt-store sequence index value
*/
{
int length, offset;
LispObj *sequence, *oindex, *value;
value = ARGUMENT(2);
oindex = ARGUMENT(1);
sequence = ARGUMENT(0);
CHECK_INDEX(oindex);
offset = FIXNUM_VALUE(oindex);
length = LispLength(sequence);
if (offset >= length)
LispDestroy("%s: index %d too large for sequence length %d",
STRFUN(builtin), offset, length);
if (STRINGP(sequence)) {
int ch;
CHECK_STRING_WRITABLE(sequence);
CHECK_SCHAR(value);
ch = SCHAR_VALUE(value);
if (ch < 0 || ch > 255)
LispDestroy("%s: cannot represent character %d",
STRFUN(builtin), ch);
THESTR(sequence)[offset] = ch;
}
else {
if (ARRAYP(sequence))
sequence = sequence->data.array.list;
for (; offset > 0; offset--, sequence = CDR(sequence))
;
RPLACA(sequence, value);
}
return (value);
}
LispObj *
Lisp_XeditPut(LispBuiltin *builtin)
/*
lisp::put symbol indicator value
*/
{
LispObj *symbol, *indicator, *value;
value = ARGUMENT(2);
indicator = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
return (CAR(LispPutAtomProperty(symbol->data.atom, indicator, value)));
}
LispObj *
Lisp_XeditSetSymbolPlist(LispBuiltin *builtin)
/*
lisp::set-symbol-plist symbol list
*/
{
LispObj *symbol, *list;
list = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
return (LispReplaceAtomPropertyList(symbol->data.atom, list));
}
LispObj *
Lisp_XeditVectorStore(LispBuiltin *builtin)
/*
lisp::vector-store array &rest values
*/
{
LispObj *value, *list, *object;
long rank, count, sequence, offset, accum;
LispObj *array, *values;
values = ARGUMENT(1);
array = ARGUMENT(0);
/* check for errors */
for (rank = 0, list = values;
CONSP(list) && CONSP(CDR(list));
list = CDR(list), rank++) {
CHECK_INDEX(CAR(values));
}
if (rank == 0)
LispDestroy("%s: too few subscripts", STRFUN(builtin));
value = CAR(list);
if (STRINGP(array) && rank == 1) {
long ch;
long length = STRLEN(array);
long offset = FIXNUM_VALUE(CAR(values));
CHECK_SCHAR(value);
CHECK_STRING_WRITABLE(array);
ch = SCHAR_VALUE(value);
if (offset >= length)
LispDestroy("%s: index %ld too large for sequence length %ld",
STRFUN(builtin), offset, length);
if (ch < 0 || ch > 255)
LispDestroy("%s: cannot represent character %ld",
STRFUN(builtin), ch);
THESTR(array)[offset] = ch;
return (value);
}
CHECK_ARRAY(array);
if (rank != array->data.array.rank)
LispDestroy("%s: too %s subscripts", STRFUN(builtin),
rank < array->data.array.rank ? "few" : "many");
for (list = values, object = array->data.array.dim;
CONSP(CDR(list));
list = CDR(list), object = CDR(object)) {
if (FIXNUM_VALUE(CAR(list)) >= FIXNUM_VALUE(CAR(object)))
LispDestroy("%s: %ld is out of range, index %ld",
STRFUN(builtin),
FIXNUM_VALUE(CAR(list)),
FIXNUM_VALUE(CAR(object)));
}
for (count = sequence = 0, list = values;
CONSP(CDR(list));
list = CDR(list), sequence++) {
for (offset = 0, object = array->data.array.dim;
offset < sequence; object = CDR(object), offset++)
;
for (accum = 1, object = CDR(object); CONSP(object);
object = CDR(object))
accum *= FIXNUM_VALUE(CAR(object));
count += accum * FIXNUM_VALUE(CAR(list));
}
for (array = array->data.array.list; count > 0; array = CDR(array), count--)
;
RPLACA(array, value);
return (value);
}
LispObj *
Lisp_XeditDocumentationStore(LispBuiltin *builtin)
/*
lisp::documentation-store symbol type string
*/
{
LispDocType_t doc_type;
LispObj *symbol, *type, *string;
string = ARGUMENT(2);
type = ARGUMENT(1);
symbol = ARGUMENT(0);
CHECK_SYMBOL(symbol);
/* type is checked in LispDocumentationType() */
doc_type = LispDocumentationType(builtin, type);
if (string == NIL)
/* allow explicitly releasing memory used for documentation */
LispRemDocumentation(symbol, doc_type);
else {
CHECK_STRING(string);
LispAddDocumentation(symbol, string, doc_type);
}
return (string);
}
Reference in New Issue View Git Blame Copy Permalink