mirror of
https://github.com/Interlisp/maiko.git
synced 2026-02-04 23:44:42 +00:00
Maiko sources matching state as of 020102 prior to initial patching for Mac OSX
This commit is contained in:
Nick Briggs
738
src/car-cdr.c
Executable file
738
src/car-cdr.c
Executable file
@@ -0,0 +1,738 @@
|
||||
/* $Id: car-cdr.c,v 1.3 1999/05/31 23:35:25 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
|
||||
static char *id = "$Id: car-cdr.c,v 1.3 1999/05/31 23:35:25 sybalsky Exp $ Copyright (C) Venue";
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
|
||||
/* Manufactured in the United States of America. */
|
||||
/* */
|
||||
/* The contents of this file are proprietary information */
|
||||
/* belonging to Venue, and are provided to you under license. */
|
||||
/* They may not be further distributed or disclosed to third */
|
||||
/* parties without the specific permission of Venue. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
#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 "gc.h"
|
||||
#include "cell.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");
|
||||
}
|
||||
} /* 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;
|
||||
|
||||
datum68k = (ConsCell *)(Addr68k_from_LADDR(datum));
|
||||
cdr_code = datum68k->cdr_code;
|
||||
|
||||
if (Listp(datum))
|
||||
{
|
||||
if (cdr_code == CDR_NIL) return(NIL_PTR); /* cdr is nil */
|
||||
|
||||
else 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 */
|
||||
else if (cdr_code == CDR_INDIRECT) /* cdr_code > CDR_ONPAGE */
|
||||
/* cdr-indirect */
|
||||
return(cdr ((LispPTR)(datum68k->car_field)));
|
||||
|
||||
else
|
||||
{
|
||||
/* 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);
|
||||
}
|
||||
}
|
||||
else if (datum==NIL_PTR) return(NIL_PTR);
|
||||
|
||||
/**** We assume CAR/CDRERR is CDR ****************/
|
||||
else error("cdr : ARG not list");
|
||||
|
||||
} /* 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");
|
||||
}
|
||||
|
||||
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
|
||||
ConsCell *find_cdrable_pair(LispPTR carpart, LispPTR cdrpart); /* below... */
|
||||
#endif
|
||||
extern struct conspage *next_conspage(void); /* conspage.c */
|
||||
|
||||
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;
|
||||
ConsCell * find_close_cell(struct conspage *page, LispPTR oldcell);
|
||||
|
||||
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;
|
||||
register ConsCell *temp;
|
||||
|
||||
datum68k = (ConsCell *)(Addr68k_from_LADDR(tos));
|
||||
cdr_code = datum68k->cdr_code;
|
||||
|
||||
if (Listp(tos))
|
||||
{
|
||||
if (cdr_code == CDR_NIL) return(NIL_PTR); /* cdr-nil */
|
||||
|
||||
else 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 */
|
||||
else if (cdr_code == CDR_INDIRECT) /* cdr_code < CDR_ONPAGE */
|
||||
/* cdr-indirect */
|
||||
return(cdr ((LispPTR)(datum68k->car_field)));
|
||||
|
||||
else
|
||||
{
|
||||
/* 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 */
|
||||
}
|
||||
}
|
||||
else if (tos == NIL_PTR) return(tos);
|
||||
else
|
||||
{
|
||||
ERROR_EXIT(tos);
|
||||
}
|
||||
|
||||
|
||||
} /* 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 _ 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. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
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 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, poffset;
|
||||
unsigned nprior = 0;
|
||||
ConsCell *cell;
|
||||
|
||||
while (offset)
|
||||
{
|
||||
if ((offset < oldoffset) && (offset >= (oldoffset-14)))
|
||||
{
|
||||
poffset = offset;
|
||||
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 */
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
ConsCell *find_cdrpair_in_page(struct conspage *pg, LispPTR carpart, LispPTR cdrpart)
|
||||
{
|
||||
ConsCell *cell;
|
||||
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 */
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
ConsCell *find_cdrable_pair(LispPTR carpart, LispPTR cdrpart)
|
||||
{
|
||||
unsigned offset, prior, priorprior, 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));
|
||||
}
|
||||
Reference in New Issue
Block a user