Remove the Mark() and Release() procedures from the Pascal compiler and

standard library, because they never worked and come from an achingly old
version of the Pascal specification. Fix the implementations of New() and
Dispose() to use the standard C memory allocator rather than rolling their own
(also in C). Write test!

lang/pc/comp/chk_expr.c

@@ -1183,13 +1183,6 @@ ChkStandard(expp,left)
 		expp->nd_type = NULLTYPE;
 		break;
 
-	    case R_MARK:
-	    case R_RELEASE:
-		if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
-			return 0;
-		expp->nd_type = NULLTYPE;
-		break;
-
 	    case R_HALT:
 		if( !arg->nd_right ) 		/* insert 0 parameter */
 			arg->nd_right = ZeroParam();

lang/pc/comp/code.c

@@ -1076,16 +1076,6 @@ CodeStd(nd)
 			C_asp(pointer_size + word_size);
 			break;
 
-		case R_MARK:
-		case R_RELEASE:
-			CodeDAddress(left);
-			if( req == R_MARK )
-				C_cal("_sav");
-			else
-				C_cal("_rst");
-			C_asp(pointer_size);
-			break;
-
 		case R_HALT:
 			if( left )
 				CodePExpr(left);

lang/pc/comp/main.c

@@ -189,10 +189,6 @@ AddRequired()
 	/* DYNAMIC ALLOCATION PROCEDURES */
 	(void) Enter("new", D_PROCEDURE, std_type, R_NEW);
 	(void) Enter("dispose", D_PROCEDURE, std_type, R_DISPOSE);
-	if( !options['s'] ) {
-		(void) Enter("mark", D_PROCEDURE, std_type, R_MARK);
-		(void) Enter("release", D_PROCEDURE, std_type, R_RELEASE);
-	}
 
 	/* MISCELLANEOUS PROCEDURE(S) */
 	if( !options['s'] )

lang/pc/comp/required.h

@@ -1,48 +1,51 @@
 /* REQUIRED PROCEDURES AND FUNCTIONS */
 
-/* PROCEDURES */
+enum
-/* FILE HANDLING */
+{
-#define R_REWRITE	1
+    R__UNUSED = 0,
-#define R_PUT		2
-#define R_RESET		3
-#define R_GET		4
-#define R_PAGE		5
 
-/* DYNAMIC ALLOCATION */
+    /* PROCEDURES */
-#define R_NEW		6
+    /* FILE HANDLING */
-#define R_DISPOSE	7
+    R_REWRITE,
-#define R_MARK		8
+    R_PUT,
-#define R_RELEASE	9
+    R_RESET,
+    R_GET,
+    R_PAGE,
 
-/* MISCELLANEOUS PROCEDURE(S) */
+    /* DYNAMIC ALLOCATION */
-#define R_HALT		10
+    R_NEW,
+    R_DISPOSE,
 
-/* TRANSFER */
+    /* MISCELLANEOUS PROCEDURE(S) */
-#define R_PACK		11
+    R_HALT,
-#define R_UNPACK	12
 
-/* FUNCTIONS */
+    /* TRANSFER */
-/* ARITHMETIC */
+    R_PACK,
-#define R_ABS		13
+    R_UNPACK,
-#define R_SQR		14
-#define R_SIN		15
-#define R_COS		16
-#define R_EXP		17
-#define R_LN		18
-#define R_SQRT		19
-#define R_ARCTAN	20
 
-/* TRANSFER */
+    /* FUNCTIONS */
-#define R_TRUNC		21
+    /* ARITHMETIC */
-#define R_ROUND		22
+    R_ABS,
+    R_SQR,
+    R_SIN,
+    R_COS,
+    R_EXP,
+    R_LN,
+    R_SQRT,
+    R_ARCTAN,
 
-/* ORDINAL */
+    /* TRANSFER */
-#define R_ORD		23
+    R_TRUNC,
-#define R_CHR		24
+    R_ROUND,
-#define R_SUCC		25
-#define R_PRED		26
 
-/* BOOLEAN */
+    /* ORDINAL */
-#define R_ODD		27
+    R_ORD,
-#define R_EOF		28
+    R_CHR,
-#define R_EOLN		29
+    R_SUCC,
+    R_PRED,
+
+    /* BOOLEAN */
+    R_ODD,
+    R_EOF,
+    R_EOLN,
+};

lang/pc/libpc/build.lua

@@ -11,7 +11,6 @@ for _, plat in ipairs(vars.plats) do
 			"./fif.e",
 			"./gto.e",
 			"./hol0.e",
-			"./sav.e",
 			"./sig.e",
 			"./trap.e",
 			"./trp.e",

lang/pc/libpc/dis.c

@@ -1,101 +0,0 @@
-/*
- * 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.
- *
- *          This product is part of the Amsterdam Compiler Kit.
- *
- * Permission to use, sell, duplicate or disclose this software must be
- * obtained in writing. Requests for such permissions may be sent to
- *
- *      Dr. Andrew S. Tanenbaum
- *      Wiskundig Seminarium
- *      Vrije Universiteit
- *      Postbox 7161
- *      1007 MC Amsterdam
- *      The Netherlands
- *
- */
-
-/* Author: J.W. Stevenson */
-
-#include	<pc_err.h>
-
-#define assert()	/* nothing */
-
-/*
- * use a singly linked list of free blocks.
- */
-struct adm {
-	struct adm	*next;
-	int		size;
-};
-
-struct adm *freep = 0;			/* first element on free list */
-
-extern void _trp(int);
-
-/*
- * 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 == block) {	/* this block already freed */
-	  _trp(EFREE);
-	}
-	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,120 +1,20 @@
-/*
+#include <stdlib.h>
- * 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.
- *
- *          This product is part of the Amsterdam Compiler Kit.
- *
- * Permission to use, sell, duplicate or disclose this software must be
- * obtained in writing. Requests for such permissions may be sent to
- *
- *      Dr. Andrew S. Tanenbaum
- *      Wiskundig Seminarium
- *      Vrije Universiteit
- *      Postbox 7161
- *      1007 MC Amsterdam
- *      The Netherlands
- *
- */
-
-/* Author: J.W. Stevenson */
 #include <em_abs.h>
 #include <pc_err.h>
 
-#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;
-};
-
-extern struct adm	*freep;
-
 extern void _trp(int);			/* called on error */
 
-extern void _dis(int, struct adm **);
+void _new(int n, void** ptr)
-
-
-/*
- * Helper function to request 'nu' units of memory from the OS.
- * A storage unit is sizeof(struct adm). Typically 8 bytes
- * on a 32-bit machine like i386 etc.
- */
-static struct adm *
-morecore(unsigned nu)
 {
-    char *cp, *sbrk(int);
+	void* p = malloc(n);
-    struct adm *up;
+	if (!p)
-
-    if (nu < NALLOC)
-	nu = NALLOC;
-    cp = sbrk(nu * sizeof(struct adm));
-    if (cp == (char *) -1) /* no space at all */
-	return 0;
-    up = (struct adm*) cp;
-    up->size = nu;
-    up = up + 1;
-    _dis((nu - 1) * sizeof(struct adm), &up);
-    return freep;
-}   /* morecore */
-
-/*
- * Dispose
- * Called with two arguments:
- * 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;
+
-	}
+	*ptr = p;
-	if (p->size >= nunits) {
+}
-	    if (p->size == nunits) {	/* exact fit */
+
-		if (q == 0) {	/* first element on free list. */
+void _dis(int n, void** ptr)
-		    freep = p->next;
+{
-		} else {
+	free(*ptr);
-		    q->next = p->next;
+	*ptr = NULL;
-		}
+}
-	    } 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 */

lang/pc/libpc/sav.e

@@ -1,49 +0,0 @@
-#
-; $Id$
-;  (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
-; 
-;           This product is part of the Amsterdam Compiler Kit.
-; 
-;  Permission to use, sell, duplicate or disclose this software must be
-;  obtained in writing. Requests for such permissions may be sent to
-; 
-;       Dr. Andrew S. Tanenbaum
-;       Wiskundig Seminarium
-;       Vrije Universiteit
-;       Postbox 7161
-;       1007 MC Amsterdam
-;       The Netherlands
-; 
-
-/* Author: J.W. Stevenson */
-
-
- mes 2,EM_WSIZE,EM_PSIZE
-
-#define	PTRAD	0
-
-#define	HP	2
-
-; _sav called with one parameter:
-;	- address of pointer variable (PTRAD)
-
- exp $_sav
- pro $_sav,0
- lor HP
- lal PTRAD
- loi EM_PSIZE
- sti EM_PSIZE
- ret 0
- end ?
-
-; _rst is called with one parameter:
-;	- address of pointer variable (PTRAD)
-
- exp $_rst
- pro $_rst,0
- lal PTRAD
- loi EM_PSIZE
- loi EM_PSIZE
- str HP
- ret 0
- end ?

plat/qemuppc/tests/build.lua

@@ -6,7 +6,7 @@ local tests = {}
 if os.execute("which "..qemu.." > /dev/null") ~= 0 then
 	print("warning: skipping tests which require ", qemu)
 else
-	local testcases = filenamesof("./*.c", "./*.s", "./*.e")
+	local testcases = filenamesof("./*.c", "./*.s", "./*.e", "./*.p")
 
 	for _, f in ipairs(testcases) do
 		local fs = replace(basename(f), "%..$", "")

plat/qemuppc/tests/newdispose_p.p

@@ -0,0 +1,34 @@
+#
+(*$U+ -- enables underscores in identifiers *)
+
+program markrelease;
+
+type
+    iptr = ^integer;
+
+var
+    ptr1 : iptr;
+    ptr2 : iptr;
+    
+procedure finished;
+    extern;
+
+procedure fail(line: integer);
+    extern;
+    
+#define ASSERT(cond) \
+    if (not (cond)) then fail(__LINE__)
+
+begin
+    New(ptr1);
+    New(ptr2);
+    ASSERT(ptr1 <> ptr2);
+
+    Dispose(ptr1);
+    Dispose(ptr2);
+    (* Not required by the Pascal standard, but our implementation sets the
+     * pointers to NULL after freeing them. *)
+    ASSERT(ptr1 = ptr2);
+
+    finished
+end.