github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-01-16 16:19:10 +00:00
Code Issues Projects Releases Wiki Activity
Interlisp.maiko/src/car-cdr.c
Bruce Mitchener 6f7ec059bc
Remove dead stores. (#240)
2021-01-19 21:23:26 -08:00

633 lines
19 KiB
C
Raw Blame History

/* $Id: car-cdr.c,v 1.3 1999/05/31 23:35:25 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved
*/
/************************************************************************/
/* */
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
/* Manufactured in the United States of America. */
/* */
/************************************************************************/
#include "version.h"
/***********************************************************************/
/*
File Name : car-cdr.c
Desc : car-cdr management
Date : Apr 24, 1987
Edited by : Naoyuki Mitani
Including : car
cdr
rplaca
rplacd
OP_car
OP_cdr
OP_rplaca
OP_rplacd
*/
/**********************************************************************/
#include "lispemul.h"
#include "emlglob.h"
#include "lspglob.h"
#include "lsptypes.h"
#include "address.h"
#include "adr68k.h"
#include "gcdata.h"
#include "cell.h"
#include "car-cdrdefs.h"
#include "commondefs.h"
#include "conspagedefs.h"
#include "gchtfinddefs.h"
/************************************************************************/
/* */
/* c a r */
/* */
/* Returns CAR of its argument. Meant to be called from C. */
/* */
/************************************************************************/
LispPTR car(register LispPTR datum)
/* datum must be LISP pointer(word offset) */
{
register ConsCell *datum68k;
register ConsCell *temp;
datum68k = (ConsCell *)(Addr68k_from_LADDR(datum));
if (Listp(datum)) {
if (datum68k->cdr_code == CDR_INDIRECT) {
temp = (ConsCell *)Addr68k_from_LADDR(datum68k->car_field);
return ((LispPTR)temp->car_field);
} else
return ((LispPTR)datum68k->car_field);
}
else if (datum == NIL_PTR)
return ((LispPTR)NIL_PTR);
else {
if (datum == ATOM_T) return (ATOM_T);
/** We assume CAR/CDRERR is CDR ***/
else if ((datum & SEGMASK) == 0) /* LITATOM */
return (NIL);
else
error("car : ARG not list");
return (NIL); /* NOT REACHED */
}
} /* end of car */
/************************************************************************/
/* */
/* c d r */
/* */
/* Returns CDR of its argument. Meant to be called from C. */
/* */
/************************************************************************/
LispPTR cdr(register LispPTR datum)
/* datum must be LISP pointer(word offset) */
{
register ConsCell *datum68k;
register DLword cdr_code;
register ConsCell *temp;
if (datum == NIL_PTR) return (NIL_PTR);
if (!Listp(datum)) error("cdr : ARG not list");
datum68k = (ConsCell *)(Addr68k_from_LADDR(datum));
cdr_code = datum68k->cdr_code;
if (cdr_code == CDR_NIL) return (NIL_PTR); /* cdr is nil */
if ((cdr_code & CDR_ONPAGE) != 0) /* cdr-samepage */
#ifdef NEWCDRCODING
return (datum + ((cdr_code & 7) << 1));
#else
return (POINTER_PAGEBASE(datum) + ((cdr_code & 127) << 1));
#endif /* NEWCDRCODING */
if (cdr_code == CDR_INDIRECT) /* cdr_code > CDR_ONPAGE cdr-indirect */
return (cdr((LispPTR)(datum68k->car_field)));
/* cdr isn't a CONS, but is stored on this page. */
#ifdef NEWCDRCODING
temp = (ConsCell *)(Addr68k_from_LADDR(datum + (cdr_code << 1)));
#else
temp = (ConsCell *)(Addr68k_from_LADDR(POINTER_PAGEBASE(datum) + (cdr_code << 1)));
#endif /* NEWCDRCODING */
return ((LispPTR)temp->car_field);
} /* end of cdr */
/**********************************************************************/
/*
Func name : rplaca
Called from C program.
Date : Apr 15, 1987
Edited by : Naoyuki Mitani
*/
/**********************************************************************/
LispPTR rplaca(register LispPTR x, register LispPTR y)
/* car of x will be smashed */
/* y is a newly car object */
{
register ConsCell *x_68k;
register ConsCell *temp;
#ifdef TRACE2
printf("TRACE: rplaca()\n");
#endif
if (Listp(x) == NIL) { /* arg isn't a CONS cell, might be NIL */
if (x == NIL_PTR) {
if (y != NIL_PTR)
error("Attempt to RPLACA NIL");
else
return (NIL_PTR);
} else
error("ARG not List");
return (NIL_PTR); /* NOT REACHED */
}
else {
x_68k = (ConsCell *)Addr68k_from_LADDR(x);
GCLOOKUP(car(x), DELREF); /* set up reference count */
GCLOOKUP(y, ADDREF);
if (x_68k->cdr_code == CDR_INDIRECT) {
temp = (ConsCell *)Addr68k_from_LADDR((LispPTR)x_68k->car_field);
temp->car_field = y;
} else
x_68k->car_field = y;
return (x);
}
} /* end of rplaca */
/**********************************************************************/
/*
Func name : rplacd
Called from C program.
Date : Apr 16, 1987
Edited by : Naoyuki Mitani
*/
/**********************************************************************/
#ifdef NEWCDRCODING
static ConsCell *find_cdrable_pair(LispPTR carpart, LispPTR cdrpart); /* below... */
static ConsCell *find_close_cell(struct conspage *page, LispPTR oldcell);
#endif
LispPTR rplacd(LispPTR x, register LispPTR y)
/* cdr of x will be smashed */
/* y is a newly cdr object */
{
register ConsCell *x_68k;
register ConsCell *temp68k;
register ConsCell *cdr_cell68k;
LispPTR cdr_cell;
LispPTR rp_page;
DLword cdr_code;
register struct conspage *cons68k;
if (Listp(x) == NIL) {
if (x == NIL_PTR) {
if (y != NIL_PTR)
error("Attempt to RPLACD NIL");
else
return (NIL_PTR);
} else
error("ARG not List");
}
else {
x_68k = (ConsCell *)Addr68k_from_LADDR(x);
GCLOOKUP(cdr(x), DELREF); /* set up reference count */
GCLOOKUP(y, ADDREF);
cdr_code = x_68k->cdr_code;
if (cdr_code == CDR_INDIRECT) {
/* cdr-indirect */
rp_page = (LispPTR)x_68k->car_field;
temp68k = (ConsCell *)Addr68k_from_LADDR(rp_page);
#ifdef NEWCDRCODING
cdr_cell = (rp_page) + (temp68k->cdr_code << 1);
#else
cdr_cell = POINTER_PAGEBASE(rp_page) + (temp68k->cdr_code << 1);
#endif /* NEWCDRCODING */
cdr_cell68k = (ConsCell *)Addr68k_from_LADDR(cdr_cell);
*(LispPTR *)cdr_cell68k = y & POINTERMASK; /* cdr_code is set to 0 */
} else if (cdr_code <= CDR_MAXINDIRECT) {
/* cdr-differentpage */
#ifdef NEWCDRCODING
cdr_cell = x + (cdr_code << 1);
#else
cdr_cell = POINTER_PAGEBASE(x) + (cdr_code << 1);
#endif /* NEWCDRCODING */
cdr_cell68k = (ConsCell *)Addr68k_from_LADDR(cdr_cell);
*(LispPTR *)cdr_cell68k = y & POINTERMASK; /* cdr_code is set to 0 */
} else if (y == NIL_PTR)
/* cdr-samepage & y is nil */
x_68k->cdr_code = CDR_NIL;
#ifdef NEWCDRCODING
else if (((rp_page = POINTER_PAGEBASE(x)) == POINTER_PAGEBASE(y)) && (y > x) && (y <= (x + 14)))
/* cdr-samepage & x and y are on same page */
x_68k->cdr_code = CDR_ONPAGE + ((y - x) >> 1);
#else
else if ((rp_page = POINTER_PAGEBASE(x)) == POINTER_PAGEBASE(y))
/* cdr-samepage & x and y are on same page */
x_68k->cdr_code = CDR_ONPAGE + ((y & 0xff) >> 1);
#endif /* NEWCDRCODING */
else {
/* cdr-samepage & x and y are on different page */
cons68k = (struct conspage *)(Addr68k_from_LADDR(rp_page));
#ifdef NEWCDRCODING
if ((cons68k->count > 0) && (cdr_cell68k = find_close_cell(cons68k, x))) {
/* at least one free-cell on x's conspage */
/* AND it's within CDR-code range of x. */
*(LispPTR *)cdr_cell68k = y & POINTERMASK; /* cdr_code set to 0 */
x_68k->cdr_code = (LADDR_from_68k(cdr_cell68k) - x) >> 1;
}
#else
if (cons68k->count > 0) {
/* at least one free-cell on x's conspage */
cdr_cell68k = GetNewCell_68k(cons68k);
cons68k->count--;
cons68k->next_cell = ((freecons *)cdr_cell68k)->next_free;
*(LispPTR *)cdr_cell68k = y & POINTERMASK; /* cdr_code set to 0 */
x_68k->cdr_code = (LADDR_from_68k(cdr_cell68k) - rp_page) >> 1;
}
#endif /* NEWCDRCODING */
else {
/* no more free-cell on x's conspage */
#ifdef NEWCDRCODING
temp68k = (ConsCell *)find_cdrable_pair(x, y);
temp68k->car_field = x_68k->car_field;
x_68k->car_field = LADDR_from_68k(temp68k);
x_68k->cdr_code = CDR_INDIRECT;
#else
cons68k = next_conspage();
cdr_cell68k = GetNewCell_68k(cons68k);
cons68k->next_cell = ((freecons *)cdr_cell68k)->next_free;
temp68k = GetNewCell_68k(cons68k);
cons68k->next_cell = ((freecons *)temp68k)->next_free;
cons68k->count -= 2;
*(LispPTR *)cdr_cell68k = y & POINTERMASK; /* cdr_code set to 0 */
temp68k->car_field = x_68k->car_field;
x_68k->car_field = LADDR_from_68k(temp68k);
temp68k->cdr_code = (LADDR_from_68k(cdr_cell68k) & 0xff) >> 1;
x_68k->cdr_code = CDR_INDIRECT;
#endif /* NEWCDRCODING */
}
}
}
return (x);
} /* end of rplacd */
/**********************************************************************/
/*
Func name : N_OP_car
car management
Date : March 21, 1988
Edited by : Robert Krivacic
*/
/**********************************************************************/
LispPTR N_OP_car(register LispPTR tos) {
register ConsCell *datum68k;
register ConsCell *temp;
datum68k = (ConsCell *)(Addr68k_from_LADDR(tos));
if (Listp(tos)) {
if (datum68k->cdr_code == CDR_INDIRECT) {
temp = (ConsCell *)Addr68k_from_LADDR(datum68k->car_field);
return ((LispPTR)temp->car_field);
} else
return ((LispPTR)datum68k->car_field);
} else if (tos == NIL_PTR)
return (tos);
else if (tos == ATOM_T)
return (tos);
else {
ERROR_EXIT(tos);
}
} /* end of N_OP_car */
/**********************************************************************/
/*
Func name : N_OP_cdr
cdr management
Date : March 21, 1988
Edited by : Robert Krivacic
*/
/**********************************************************************/
LispPTR N_OP_cdr(register LispPTR tos) {
register ConsCell *datum68k;
register DLword cdr_code;
if (tos == NIL_PTR) return (tos);
if (!Listp(tos)) {
ERROR_EXIT(tos);
}
datum68k = (ConsCell *)(Addr68k_from_LADDR(tos));
cdr_code = datum68k->cdr_code;
if (cdr_code == CDR_NIL) return (NIL_PTR); /* cdr-nil */
if (cdr_code > CDR_ONPAGE) /* cdr-samepage */
#ifdef NEWCDRCODING
return (tos + ((cdr_code & 7) << 1));
#else
return (POINTER_PAGEBASE(tos) + ((cdr_code & 127) << 1));
#endif /*NEWCDRCODING */
if (cdr_code == CDR_INDIRECT) /* cdr-indirect */
return (cdr((LispPTR)(datum68k->car_field)));
/* cdr-differentpage */
#ifdef NEWCDRCODING
return ((LispPTR)((ConsCell *)(Addr68k_from_LADDR(tos + (cdr_code << 1))))->car_field);
#else
return ((LispPTR)((ConsCell *)(Addr68k_from_LADDR(POINTER_PAGEBASE(tos) + (cdr_code << 1))))->car_field);
#endif /*NEWCDRCODING */
} /* end of N_OP_cdr */
/**********************************************************************/
/*
Func name : N_OP_rplaca
rplaca management
Date : March 21, 1988
Edited by : Robert Krivacic
*/
/**********************************************************************/
LispPTR N_OP_rplaca(register LispPTR tosm1, register LispPTR tos) {
register ConsCell *x_68k;
register ConsCell *temp;
if (Listp(tosm1) == NIL) {
if (tosm1 == NIL_PTR) {
if (tos != NIL_PTR)
ERROR_EXIT(tos)
else
return (tosm1);
} else
ERROR_EXIT(tos);
}
else {
x_68k = (ConsCell *)Addr68k_from_LADDR(tosm1);
GCLOOKUP(car(tosm1), DELREF); /* set up reference count */
GCLOOKUP(tos, ADDREF);
if (x_68k->cdr_code == CDR_INDIRECT) {
temp = (ConsCell *)Addr68k_from_LADDR((LispPTR)x_68k->car_field);
temp->car_field = tos;
} else
x_68k->car_field = tos;
return (tosm1);
}
} /* end of N_OP_rplaca */
/**********************************************************************/
/*
Func name : N_OP_rplacd
rplacd management
Date : March 21, 1988
Edited by : Robert Krivacic
*/
/**********************************************************************/
LispPTR N_OP_rplacd(register LispPTR tosm1, register LispPTR tos) {
if (Listp(tosm1) == NIL) {
if (tosm1 == NIL_PTR) {
if (tos != NIL_PTR)
ERROR_EXIT(tos)
else
return (tosm1);
} else
ERROR_EXIT(tos);
}
else
rplacd(tosm1, tos);
return (tosm1);
} /* end of N_OP_rplacd */
/************************************************************************/
/* */
/* f i n d _ c l o s e _ p r i o r _ c e l l */
/* */
/* Given the real address of a CONS page and an existing cell */
/* on that page, return another cell that is close enough to */
/* that the existing cell can be its CDR (i.e. up to 7 cells */
/* earlier. If no such cell exists, return 0. */
/* */
/* If a cell is found, it is taken off the free chain before */
/* being returned. */
/* */
/************************************************************************/
ConsCell *find_close_prior_cell(struct conspage *page, LispPTR oldcell) {
unsigned oldoffset = oldcell & 0xFF;
unsigned offset = page->next_cell;
unsigned prior = 0;
unsigned noffset;
ConsCell *cell;
while (offset) {
if ((offset < oldoffset) && (offset >= (oldoffset - 14))) {
noffset = FREECONS(page, offset)->next_free;
while ((noffset > offset) && (noffset < oldoffset)) {
prior = offset;
offset = noffset;
noffset = FREECONS(page, offset)->next_free;
}
cell = (ConsCell *)((DLword *)page + offset);
if (prior)
FREECONS(page, prior)->next_free = FREECONS(page, offset)->next_free;
else
page->next_cell = FREECONS(page, offset)->next_free;
page->count -= 1;
cell->cdr_code = CDR_ONPAGE | ((oldoffset - offset) >> 1);
if (254 < (offset + ((cell->cdr_code & 7) << 1))) error("in fcpc, page overflow.");
return (cell);
}
prior = offset;
offset = ((freecons *)((DLword *)page + offset))->next_free;
}
return ((ConsCell *)0); /* No cell close enough */
}
#ifdef NEWCDRCODING
/************************************************************************/
/* */
/* f i n d _ c l o s e _ c e l l */
/* */
/* Given the real address of a CONS page and an existing cell */
/* on that page, return another cell that is close enough to */
/* be used as the CDR of the existing cell (i.e., within 7 */
/* cells. If no such cell exists, return 0. */
/* */
/* If a cell is found, it is taken off the free chain before */
/* being returned. */
/* */
/************************************************************************/
static ConsCell *find_close_cell(struct conspage *page, LispPTR oldcell) {
unsigned oldoffset = oldcell & 0xFF;
unsigned offset = page->next_cell;
unsigned prior = 0;
while (offset) {
if ((offset > oldoffset) && (offset <= (oldoffset + 14))) {
if (prior)
((freecons *)((DLword *)page + prior))->next_free =
((freecons *)((DLword *)page + offset))->next_free;
else
page->next_cell = ((freecons *)((DLword *)page + offset))->next_free;
page->count -= 1;
return (ConsCell *)((DLword *)page + offset);
}
prior = offset;
offset = ((freecons *)((DLword *)page + offset))->next_free;
}
return ((ConsCell *)0); /* No cell close enough */
}
/************************************************************************/
/* */
/* f i n d _ c d r p a i r _ i n _ p a g e */
/* */
/* */
/* */
/************************************************************************/
static ConsCell *find_cdrpair_in_page(struct conspage *pg, LispPTR carpart, LispPTR cdrpart) {
unsigned offset, prior, priorprior, nprior, poffset, noffset;
prior = priorprior = nprior = 0;
if (pg->count < 2) return (ConsCell *)0;
offset = pg->next_cell;
while (offset) {
if (prior && (offset < prior) && (prior <= offset + 14)) {
ConsCell *carcell, *cdrcell;
poffset = offset;
noffset = FREECONS(pg, offset)->next_free;
while ((noffset > offset) && (noffset < prior)) {
nprior = offset;
poffset = prior;
offset = noffset;
noffset = FREECONS(pg, offset)->next_free;
}
carcell = (ConsCell *)(((DLword *)pg) + offset);
cdrcell = (ConsCell *)(((DLword *)pg) + prior);
if (priorprior)
FREECONS(pg, priorprior)->next_free = FREECONS(pg, poffset)->next_free;
else
pg->next_cell = FREECONS(pg, poffset)->next_free;
if (nprior) FREECONS(pg, nprior)->next_free = FREECONS(pg, offset)->next_free;
pg->count -= 2;
*(LispPTR *)carcell = carpart;
*(LispPTR *)cdrcell = cdrpart;
carcell->cdr_code = (cdrcell - carcell);
return (carcell);
} else if (prior && (offset > prior) && (offset <= prior + 14)) {
ConsCell *carcell, *cdrcell;
carcell = (ConsCell *)(((DLword *)pg) + prior);
cdrcell = (ConsCell *)(((DLword *)pg) + offset);
if (priorprior)
FREECONS(pg, priorprior)->next_free = ((freecons *)cdrcell)->next_free;
else
pg->next_cell = ((freecons *)cdrcell)->next_free;
pg->count -= 2;
*(LispPTR *)carcell = carpart;
*(LispPTR *)cdrcell = cdrpart;
carcell->cdr_code = (cdrcell - carcell);
return (carcell);
}
priorprior = prior;
prior = offset;
offset = FREECONS(pg, offset)->next_free;
}
return (0); /* found no entries in this page, so return failure code */
}
/************************************************************************/
/* */
/* f i n d _ c d r a b l e _ p a i r */
/* */
/* */
/* */
/************************************************************************/
static ConsCell *find_cdrable_pair(LispPTR carpart, LispPTR cdrpart) {
unsigned pgno;
struct conspage *pg;
ConsCell *cell;
for (pg = (struct conspage *)Addr68k_from_LPAGE(pgno = ListpDTD->dtd_nextpage); pgno;
pg = (struct conspage *)Addr68k_from_LPAGE(pgno = pg->next_page)) {
if ((cell = find_cdrpair_in_page(pg, carpart, cdrpart))) return (cell);
}
return (find_cdrpair_in_page(next_conspage(), carpart, cdrpart));
}
#endif
Reference in New Issue View Git Blame Copy Permalink