d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

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

Browse source 
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!
This commit is contained in:
David Given 2016-11-24 20:35:26 +01:00
parent 899f1ea4f3
commit c084f9f224
10 changed files with 90 additions and 325 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lang/pc/comp/chk_expr.c
View file

@ -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();

10
lang/pc/comp/code.c
View file

@ -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);

4
lang/pc/comp/main.c
View file

@ -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'] )

61
lang/pc/comp/required.h
View file

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

1
lang/pc/libpc/build.lua
View file

@ -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",

101
lang/pc/libpc/dis.c
View file

@ -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 */

122
lang/pc/libpc/new.c
View file

@ -1,120 +1,20 @@
/*
* 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 <stdlib.h>
#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 **);
/*
* 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)
void _new(int n, void** ptr)
{
char *cp, *sbrk(int);
struct adm *up;
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)
void* p = malloc(n);
if (!p)
_trp(EHEAP);
q = 0;
*ptr = p;
}
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;
void _dis(int n, void** ptr)
{
free(*ptr);
*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 */

49
lang/pc/libpc/sav.e
View file

@ -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 ?

2
plat/qemuppc/tests/build.lua
View file

@ -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), "%..$", "")

34
plat/qemuppc/tests/newdispose_p.p Normal file
View file

@ -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.