Replaced dis and new with modern implementations donated by erik@backerud.se.

lang/pc/libpc/dis.c

@@ -1,3 +1,15 @@
+/*
+ * File:  -  dis.c
+ *
+ * dispose() built in standard procedure in Pascal (6.6.5.3)
+ *
+ * Re-implementation of storage allocator for Ack Pascal compiler
+ * under Linux, and other UNIX-like systems.
+ *
+ * Written by Erik Backerud, 2010-10-01
+ *
+ * Original copyright and author info below:
+ */
 /* $Id$ */
 /*
  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
@@ -23,65 +35,67 @@
 #define assert()	/* nothing */
 
 /*
- * use circular list of free blocks from low to high addresses
+ * use a singly linked list of free blocks.
- * _highp points to free block with highest address
  */
 struct adm {
 	struct adm	*next;
 	int		size;
 };
 
-extern struct adm	*_lastp;
+struct adm *freep = 0;			/* first element on free list */
-extern struct adm	*_highp;
-extern			_trp();
 
-static int merge(p1,p2) struct adm *p1,*p2; {
+extern void _trp(int);
-	struct adm *p;
 
-	p = (struct adm *)((char *)p1 + p1->size);
+/*
-	if (p > p2)
+ * Dispose
+ * Called with two arguments:
+ * n the size of the block to be freed, in bytes,
+ * pp address of pointer to data.
+ */
+void
+_dis(int n, struct adm **pp)
+{
+    struct adm *block;	/* the block of data being freed (inc. header) */
+    struct adm *p, *q;
+
+    if (*pp == 0) {
+	_trp(EFREE);
+    }
+    block = *pp - 1;
+    if (freep == 0) {
+	freep = block;
+	block->next = 0;
+    } else {
+	q = 0;	/* trail one behind */
+	for (p = freep; p < block; p = p->next) {
+	    if (p == 0) {	/* We reached the end of the free list. */
+		break;
+	    }
+	    q = p;
+	    /* check if block is contained in the free block p */
+	    if (p+p->size > block) {
 		_trp(EFREE);
-	if (p != p2)
+	    }
-		return(0);
-	p1->size += p2->size;
-	p1->next = p2->next;
-	return(1);
-}
-
-_dis(n,pp) int n; struct adm **pp; {
-	struct adm *p1,*p2;
-
-	/*
-	 * NOTE: dispose only objects whose size is a multiple of sizeof(*pp).
-	 *       this is always true for objects allocated by _new()
-	 */
-	n = ((n+sizeof(*p1)-1) / sizeof(*p1)) * sizeof(*p1);
-	if (n == 0)
-		return;
-	if ((p1= *pp) == (struct adm *) 0)
-		_trp(EFREE);
-	p1->size = n;
-	if ((p2 = _highp) == 0)  /*p1 is the only free block*/
-		p1->next = p1;
-	else {
-		if (p2 > p1) {
-			/*search for the preceding free block*/
-			if (_lastp < p1)  /*reduce search*/
-				p2 = _lastp;
-			while (p2->next < p1)
-				p2 = p2->next;
-		}
-		/* if p2 preceeds p1 in the circular list,
-		 * try to merge them			*/
-		p1->next = p2->next; p2->next = p1;
-		if (p2 <= p1 && merge(p2,p1))
-			p1 = p2;
-		p2 = p1->next;
-		/* p1 preceeds p2 in the circular list */
-		if (p2 > p1) merge(p1,p2);
 	}
-	if (p1 >= p1->next)
+	if (p == block) {	/* this block already freed */
-		_highp = p1;
+	  _trp(EFREE);
-	_lastp = p1;
+	}
-	*pp = (struct adm *) 0;
+	if (q == 0) {	/* block is first */
-}
+	    freep = block;
+	    block->next = p;
+	} else {
+	    q->next = block;
+	}
+	block->next = p;
+	/* merge with successor on free list? */
+	if (block + block->size == p) {
+	    block->size = block->size + p->size;
+	    block->next = p->next;
+	}
+	/* merge with preceding block on free list? */
+	if (q != 0 && q+q->size == block) {
+	    q->size = q->size + block->size;
+	    q->next = block->next;
+	}
+    }
+}   /* _dis */

lang/pc/libpc/new.c

@@ -1,3 +1,15 @@
+/*
+ * File:  -  new.c
+ *
+ * new() built in standard procedure in Pascal (6.6.5.3)
+ *
+ * Re-implementation of storage allocator for Ack Pascal compiler
+ * under Linux, and other UNIX-like systems.
+ *
+ * Written by Erik Backerud, 2010-10-01
+ *
+ * Original copyright and author info below:
+ */
 /* $Id$ */
 /*
  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
@@ -17,53 +29,92 @@
  */
 
 /* Author: J.W. Stevenson */
-
+#include <em_abs.h>
-extern		_sav();
+#include <pc_err.h>
-extern		_rst();
 
 #define assert(x)	/* nothing */
 #define	UNDEF		0x8000
+#define NALLOC		(1024)		/* request this many units from OS */
 
+
+/*
+ * use a singly linked list of free blocks.
+ */
 struct adm {
 	struct adm	*next;
 	int		size;
 };
 
-struct adm	*_lastp = 0;
+extern struct adm	*freep;
-struct adm	*_highp = 0;
 
-_new(n,pp) int n; struct adm **pp; {
+extern void _trp(int);			/* called on error */
-	struct adm *p,*q;
-	int *ptmp;
 
-	n = ((n+sizeof(*p)-1) / sizeof(*p)) * sizeof(*p);
+extern void _dis(int, struct adm **);
-	if ((p = _lastp) != 0)
+
-		do {
+
-			q = p->next;
+/*
-			if (q->size >= n) {
+ * Helper function to request 'nu' units of memory from the OS.
-				assert(q->size%sizeof(adm) == 0);
+ * A storage unit is sizeof(struct adm). Typically 8 bytes
-				if ((q->size -= n) == 0) {
+ * on a 32-bit machine like i386 etc.
-					if (p == q)
+ */
-						p = 0;
+static struct adm *
-					else
+morecore(unsigned nu)
-						p->next = q->next;
+{
-					if (q == _highp)
+    char *cp, *sbrk(int);
-						_highp = p;
+    struct adm *up;
-				}
+
-				_lastp = p;
+    if (nu < NALLOC)
-				p = (struct adm *)((char *)q + q->size);
+	nu = NALLOC;
-				q = (struct adm *)((char *)p + n);
+    cp = sbrk(nu * sizeof(struct adm));
-				goto initialize;
+    if (cp == (char *) -1) /* no space at all */
-			}
+	return 0;
-			p = q;
+    up = (struct adm*) cp;
-		} while (p != _lastp);
+    up->size = nu;
-	/*no free block big enough*/
+    up = up + 1;
-	_sav(&p);
+    _dis((nu - 1) * sizeof(struct adm), &up);
-	q = (struct adm *)((char *)p + n);
+    return freep;
-	_rst(&q);
+}   /* morecore */
-initialize:
+
-	*pp = p;
+/*
-	ptmp = (int *)p;
+ * Dispose
-	while (ptmp < (int *)q)
+ * Called with two arguments:
-		*ptmp++ = UNDEF;
+ * n the size of the block to be freed, in bytes,
-}
+ * pp address of pointer to data.
+ */
+void
+_new(int n, struct adm **pp)
+{
+    int nunits;    /* the unit of storage is sizeof(struct adm) */
+    struct adm *p,*q;
+
+    /* round up size of request */
+    nunits  = (n + sizeof(struct adm) - 1) / sizeof(struct adm) + 1;
+
+    q = 0;
+    for (p = freep; ; p = p->next) {
+	if (p == 0) {
+	    p = morecore(nunits);
+	    if (p == 0)
+		_trp(EHEAP);
+	    q = 0;
+	}
+	if (p->size >= nunits) {
+	    if (p->size == nunits) {	/* exact fit */
+		if (q == 0) {	/* first element on free list. */
+		    freep = p->next;
+		} else {
+		    q->next = p->next;
+		}
+	    } else {		/* allocate tail end */
+		q = p;
+		q->size = q->size - nunits;
+		p = q + q->size;
+		p->next = 0;
+		p->size = nunits;
+	    }
+	    break;
+	}
+	q = p;
+    }
+    *pp = p + 1;
+}   /* _new */