384 lines
9.5 KiB
C
384 lines
9.5 KiB
C
/*
|
|
*
|
|
* l i s t . c -- Lists procedures
|
|
*
|
|
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
*
|
|
*
|
|
* Permission to use, copy, modify, distribute,and license this
|
|
* software and its documentation for any purpose is hereby granted,
|
|
* provided that existing copyright notices are retained in all
|
|
* copies and that this notice is included verbatim in any
|
|
* distributions. No written agreement, license, or royalty fee is
|
|
* required for any of the authorized uses.
|
|
* This software is provided ``AS IS'' without express or implied
|
|
* warranty.
|
|
*
|
|
*
|
|
* Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
* Creation date: ??-Oct-1993 21:37
|
|
* Last file update: 3-Sep-1999 20:21 (eg)
|
|
*/
|
|
|
|
#include "stk.h"
|
|
|
|
PRIMITIVE STk_pairp(SCM x)
|
|
{
|
|
return CONSP(x) ? Truth : Ntruth;
|
|
}
|
|
|
|
PRIMITIVE STk_cons(SCM x, SCM y)
|
|
{
|
|
SCM z;
|
|
NEWCELL(z,tc_cons);
|
|
CAR(z) = x;
|
|
CDR(z) = y;
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_car(SCM x)
|
|
{
|
|
if (TYPEP(x, tc_cons)) return CAR(x);
|
|
Err("car: wrong type of argument", x);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_cdr(SCM x)
|
|
{
|
|
if (TYPEP(x, tc_cons)) return CDR(x);
|
|
Err("cdr: wrong type of argument", x);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_setcar(SCM cell, SCM value)
|
|
{
|
|
if NCONSP(cell) Err("set-car!: wrong type of argument", cell);
|
|
CAR(cell) = value;
|
|
return UNDEFINED;
|
|
}
|
|
|
|
PRIMITIVE STk_setcdr(SCM cell, SCM value)
|
|
{
|
|
if NCONSP(cell) Err("set-cdr!: wrong type of argument", cell);
|
|
CDR(cell) = value;
|
|
return UNDEFINED;
|
|
}
|
|
|
|
static SCM internal_cxr(SCM l, char *fct)
|
|
{
|
|
register SCM tmp = l;
|
|
register char *p;
|
|
|
|
for(p = fct + strlen(fct)-1; *p != 'X'; p--) {
|
|
if (NCONSP(tmp)) {
|
|
char name[50];
|
|
sprintf(name, "c%sr: bad list", fct+1);
|
|
Err(name, l);
|
|
}
|
|
tmp = (*p == 'a') ? CAR(tmp) : CDR(tmp);
|
|
}
|
|
return tmp;
|
|
}
|
|
|
|
PRIMITIVE STk_caar (SCM l) { return internal_cxr(l, "Xaa"); }
|
|
PRIMITIVE STk_cdar (SCM l) { return internal_cxr(l, "Xda"); }
|
|
PRIMITIVE STk_cadr (SCM l) { return internal_cxr(l, "Xad"); }
|
|
PRIMITIVE STk_cddr (SCM l) { return internal_cxr(l, "Xdd"); }
|
|
PRIMITIVE STk_caaar (SCM l) { return internal_cxr(l, "Xaaa"); }
|
|
PRIMITIVE STk_cdaar (SCM l) { return internal_cxr(l, "Xdaa"); }
|
|
PRIMITIVE STk_cadar (SCM l) { return internal_cxr(l, "Xada"); }
|
|
PRIMITIVE STk_cddar (SCM l) { return internal_cxr(l, "Xdda"); }
|
|
PRIMITIVE STk_caadr (SCM l) { return internal_cxr(l, "Xaad"); }
|
|
PRIMITIVE STk_cdadr (SCM l) { return internal_cxr(l, "Xdad"); }
|
|
PRIMITIVE STk_caddr (SCM l) { return internal_cxr(l, "Xadd"); }
|
|
PRIMITIVE STk_cdddr (SCM l) { return internal_cxr(l, "Xddd"); }
|
|
PRIMITIVE STk_caaaar(SCM l) { return internal_cxr(l, "Xaaaa"); }
|
|
PRIMITIVE STk_cdaaar(SCM l) { return internal_cxr(l, "Xdaaa"); }
|
|
PRIMITIVE STk_cadaar(SCM l) { return internal_cxr(l, "Xadaa"); }
|
|
PRIMITIVE STk_cddaar(SCM l) { return internal_cxr(l, "Xddaa"); }
|
|
PRIMITIVE STk_caadar(SCM l) { return internal_cxr(l, "Xaada"); }
|
|
PRIMITIVE STk_cdadar(SCM l) { return internal_cxr(l, "Xdada"); }
|
|
PRIMITIVE STk_caddar(SCM l) { return internal_cxr(l, "Xadda"); }
|
|
PRIMITIVE STk_cdddar(SCM l) { return internal_cxr(l, "Xddda"); }
|
|
PRIMITIVE STk_caaadr(SCM l) { return internal_cxr(l, "Xaaad"); }
|
|
PRIMITIVE STk_cdaadr(SCM l) { return internal_cxr(l, "Xdaad"); }
|
|
PRIMITIVE STk_cadadr(SCM l) { return internal_cxr(l, "Xadad"); }
|
|
PRIMITIVE STk_cddadr(SCM l) { return internal_cxr(l, "Xddad"); }
|
|
PRIMITIVE STk_caaddr(SCM l) { return internal_cxr(l, "Xaadd"); }
|
|
PRIMITIVE STk_cdaddr(SCM l) { return internal_cxr(l, "Xdadd"); }
|
|
PRIMITIVE STk_cadddr(SCM l) { return internal_cxr(l, "Xaddd"); }
|
|
PRIMITIVE STk_cddddr(SCM l) { return internal_cxr(l, "Xdddd"); }
|
|
|
|
PRIMITIVE STk_nullp(SCM x)
|
|
{
|
|
return EQ(x, NIL) ? Truth: Ntruth;
|
|
}
|
|
|
|
int STk_llength(SCM l)
|
|
{
|
|
register SCM start = l;
|
|
register int len = 0;
|
|
|
|
for ( ; ; ) {
|
|
if (NULLP(l)) return len;
|
|
if ((l == start && len) || NCONSP(l)) return -1;
|
|
l = CDR(l);
|
|
len += 1;
|
|
}
|
|
}
|
|
|
|
PRIMITIVE STk_listp(SCM x)
|
|
{
|
|
return (STk_llength(x) < 0) ? Ntruth : Truth;
|
|
}
|
|
|
|
PRIMITIVE STk_list(SCM l, int len)
|
|
{
|
|
/* len is unused here */
|
|
return l;
|
|
}
|
|
|
|
PRIMITIVE STk_list_length(SCM l)
|
|
{
|
|
int len = STk_llength(l);
|
|
if (len >= 0) return STk_makeinteger((long) len);
|
|
Err("length: not calculable.", NIL);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
SCM STk_append2(SCM l1, SCM l2)
|
|
{
|
|
register SCM res, p;
|
|
|
|
if (NULLP(l1)) return l2;
|
|
if (NCONSP(l1)) goto Error;
|
|
|
|
for (res = NIL; ; l1 = CDR(l1)) {
|
|
if (NCONSP(l1)) goto Error;
|
|
if (res == NIL){
|
|
NEWCELL(res, tc_cons);
|
|
p = res;
|
|
}
|
|
else {
|
|
NEWCELL(CDR(p), tc_cons);
|
|
p = CDR(p);
|
|
}
|
|
CAR(p) = CAR(l1);
|
|
CDR(p) = NIL; /* Keep always a valid list in case of a GC */
|
|
if (NCONSP(CDR(l1))) break;
|
|
}
|
|
CDR(p) = l2;
|
|
return res;
|
|
Error:
|
|
Err("append: argument is not a list", l1);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_append(SCM l, int len)
|
|
{
|
|
switch (len) {
|
|
case 0: return NIL;
|
|
case 1: return CAR(l);
|
|
case 2: return STk_append2(CAR(l), CAR(CDR(l)));
|
|
default: return STk_append2(CAR(l), STk_append(CDR(l), len-1));
|
|
}
|
|
}
|
|
|
|
PRIMITIVE STk_reverse(SCM l)
|
|
{
|
|
SCM p, n = NIL;
|
|
|
|
for(p=l; NNULLP(p); p=CDR(p)) {
|
|
if (NCONSP(p)) Err("reverse: bad list", l);
|
|
n = Cons(CAR(p),n);
|
|
}
|
|
return n;
|
|
}
|
|
|
|
PRIMITIVE STk_list_tail(SCM list, SCM k)
|
|
{
|
|
register long x;
|
|
|
|
ENTER_PRIMITIVE("list-tail");
|
|
|
|
if (NCONSP(list) && NNULLP(list)) Serror("Bad list", list);
|
|
x = STk_integer_value(k);
|
|
if (x >= 0) {
|
|
SCM l;
|
|
|
|
for (l=list; x > 0; x--) {
|
|
if (NULLP(l) || NCONSP(l)) Serror("list too short", list);
|
|
l = CDR(l);
|
|
}
|
|
return l;
|
|
}
|
|
Serror("index must be exact positive integer", k);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_list_ref(SCM list, SCM k)
|
|
{
|
|
register long x;
|
|
|
|
if (NCONSP(list)) Err("list-ref: Bad list", list);
|
|
x = STk_integer_value(k);
|
|
if (x >= 0) {
|
|
SCM l = list;
|
|
|
|
for ( ; x > 0; x--) {
|
|
if (NULLP(l) || NCONSP(l)) goto Error;
|
|
l = CDR(l);
|
|
}
|
|
|
|
if (CONSP(l)) return CAR(l);
|
|
Error:
|
|
Err("list-ref: list too short", list);
|
|
}
|
|
Err("list-ref: index must be exact positive integer", k);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
static SCM lmember(SCM obj, SCM list, SCM (*predicate)(SCM, SCM) )
|
|
{
|
|
register SCM ptr;
|
|
|
|
if (NCONSP(list) && NNULLP(list)) goto Error;
|
|
for (ptr=list; NNULLP(ptr); ) {
|
|
if (CONSP(ptr)) {
|
|
if ((*predicate)(CAR(ptr), obj) == Truth) return ptr;
|
|
}
|
|
else
|
|
/* end of a dotted list */
|
|
return ((*predicate)(ptr, obj) == Truth) ? ptr : Ntruth;
|
|
if ((ptr=CDR(ptr)) == list) Err("member: circular list", NIL);
|
|
}
|
|
return Ntruth;
|
|
Error:
|
|
Err("member: Bad list", list);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_memq (SCM obj, SCM list) {return lmember(obj, list, STk_eq); }
|
|
PRIMITIVE STk_memv (SCM obj, SCM list) {return lmember(obj, list, STk_eqv); }
|
|
PRIMITIVE STk_member(SCM obj, SCM list) {return lmember(obj, list, STk_equal);}
|
|
|
|
static SCM lassoc(SCM obj, SCM alist, SCM (*predicate)(SCM, SCM))
|
|
{
|
|
register SCM l,tmp;
|
|
|
|
for(l=alist; CONSP(l); ) {
|
|
tmp = CAR(l);
|
|
if (CONSP(tmp) && (*predicate)(CAR(tmp), obj) == Truth) return tmp;
|
|
if ((l=CDR(l)) == alist) goto Error;
|
|
}
|
|
if (NULLP(l)) return(Ntruth);
|
|
Error:
|
|
Err("assoc function: improper list", alist);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_assq (SCM obj, SCM alist){return lassoc(obj, alist, STk_eq); }
|
|
PRIMITIVE STk_assv (SCM obj, SCM alist){return lassoc(obj, alist, STk_eqv); }
|
|
PRIMITIVE STk_assoc(SCM obj, SCM alist){return lassoc(obj, alist, STk_equal);}
|
|
|
|
|
|
/***
|
|
*
|
|
* Non standard functions
|
|
*
|
|
***/
|
|
|
|
PRIMITIVE STk_liststar(SCM l, int len)
|
|
{
|
|
if (len == 0) return NIL;
|
|
/* l is a pair */
|
|
return (len == 1) ? CAR(l) : STk_cons(CAR(l), STk_liststar(CDR(l), len-1));
|
|
}
|
|
|
|
PRIMITIVE STk_copy_tree(SCM l)
|
|
{
|
|
return CONSP(l) ? STk_cons(STk_copy_tree(CAR(l)), STk_copy_tree(CDR(l))): l;
|
|
}
|
|
|
|
PRIMITIVE STk_last_pair(SCM l)
|
|
{
|
|
register SCM tmp;
|
|
|
|
ENTER_PRIMITIVE("last-pair");
|
|
if (NCONSP(l)) Serror("bad list", l);
|
|
for (tmp=l; CONSP(CDR(l)); l = CDR(l))
|
|
/* Nothing */;
|
|
return l;
|
|
}
|
|
|
|
|
|
/*
|
|
* remove functions
|
|
*/
|
|
|
|
static SCM lremove(SCM obj, SCM list, SCM (*predicate)(SCM, SCM) )
|
|
{
|
|
register SCM ptr, l;
|
|
SCM result;
|
|
|
|
if (NCONSP(list) && NNULLP(list)) goto Error;
|
|
|
|
for (l=list, result=NIL; NNULLP(l); ) {
|
|
if (NCONSP(l)) goto Error;
|
|
|
|
if ((*predicate)(CAR(l), obj) == Ntruth) {
|
|
if (NULLP(result)) {
|
|
NEWCELL(result, tc_cons);
|
|
ptr = result;
|
|
}
|
|
else {
|
|
NEWCELL(CDR(ptr), tc_cons);
|
|
ptr = CDR(ptr);
|
|
}
|
|
CAR(ptr) = CAR(l);
|
|
CDR(ptr) = NIL; /* Keep always a valid list in case of a GC */
|
|
}
|
|
if ((l=CDR(l)) == list) Err("remove: circular list", NIL);
|
|
}
|
|
return result;
|
|
Error:
|
|
Err("remove: Bad list", list);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_remq (SCM obj, SCM list) {return lremove(obj, list, STk_eq); }
|
|
PRIMITIVE STk_remv (SCM obj, SCM list) {return lremove(obj, list, STk_eqv); }
|
|
PRIMITIVE STk_remove(SCM obj, SCM list) {return lremove(obj, list, STk_equal);}
|
|
|
|
/*
|
|
*
|
|
* destructive append (aka append!)
|
|
*
|
|
*/
|
|
|
|
SCM STk_dappend2(SCM l1, SCM l2)
|
|
{
|
|
register SCM tmp;
|
|
|
|
if (NULLP(l1)) return l2;
|
|
|
|
for (tmp = l1; CONSP(tmp); tmp = CDR(tmp)) {
|
|
if (NULLP(CDR(tmp))) {
|
|
CDR(tmp) = l2;
|
|
return l1;
|
|
}
|
|
}
|
|
Err("append!: argument is not a list", tmp);
|
|
return UNDEFINED; /* never reached */
|
|
}
|
|
|
|
PRIMITIVE STk_dappend(SCM l, int len)
|
|
{
|
|
switch (len) {
|
|
case 0: return NIL;
|
|
case 1: return CAR(l);
|
|
case 2: return STk_dappend2(CAR(l), CAR(CDR(l)));
|
|
default: return STk_dappend2(CAR(l), STk_dappend(CDR(l), len-1));
|
|
}
|
|
}
|