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();
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);
/* 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'] )
/* REQUIRED PROCEDURES AND FUNCTIONS */
-/* PROCEDURES */
-/* FILE HANDLING */
-#define R_REWRITE 1
-#define R_PUT 2
-#define R_RESET 3
-#define R_GET 4
-#define R_PAGE 5
-
-/* DYNAMIC ALLOCATION */
-#define R_NEW 6
-#define R_DISPOSE 7
-#define R_MARK 8
-#define R_RELEASE 9
-
-/* MISCELLANEOUS PROCEDURE(S) */
-#define R_HALT 10
-
-/* TRANSFER */
-#define R_PACK 11
-#define R_UNPACK 12
-
-/* 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
-
-/* TRANSFER */
-#define R_TRUNC 21
-#define R_ROUND 22
-
-/* ORDINAL */
-#define R_ORD 23
-#define R_CHR 24
-#define R_SUCC 25
-#define R_PRED 26
-
-/* BOOLEAN */
-#define R_ODD 27
-#define R_EOF 28
-#define R_EOLN 29
+enum
+{
+ R__UNUSED = 0,
+
+ /* PROCEDURES */
+ /* FILE HANDLING */
+ R_REWRITE,
+ R_PUT,
+ R_RESET,
+ R_GET,
+ R_PAGE,
+
+ /* DYNAMIC ALLOCATION */
+ R_NEW,
+ R_DISPOSE,
+
+ /* MISCELLANEOUS PROCEDURE(S) */
+ R_HALT,
+
+ /* TRANSFER */
+ R_PACK,
+ R_UNPACK,
+
+ /* FUNCTIONS */
+ /* ARITHMETIC */
+ R_ABS,
+ R_SQR,
+ R_SIN,
+ R_COS,
+ R_EXP,
+ R_LN,
+ R_SQRT,
+ R_ARCTAN,
+
+ /* TRANSFER */
+ R_TRUNC,
+ R_ROUND,
+
+ /* ORDINAL */
+ R_ORD,
+ R_CHR,
+ R_SUCC,
+ R_PRED,
+
+ /* BOOLEAN */
+ R_ODD,
+ R_EOF,
+ R_EOLN,
+};
"./fif.e",
"./gto.e",
"./hol0.e",
- "./sav.e",
"./sig.e",
"./trap.e",
"./trp.e",
+++ /dev/null
-/*
- * 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 */
-/*
- * 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;
+ void* p = malloc(n);
+ if (!p)
+ _trp(EHEAP);
- 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 */
+ *ptr = p;
+}
-/*
- * 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)
+void _dis(int n, void** ptr)
{
- 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 */
+ free(*ptr);
+ *ptr = NULL;
+}
\ No newline at end of file
+++ /dev/null
-#
-; $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 ?
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), "%..$", "")
--- /dev/null
+#
+(*$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.
public / ack.git / commitdiff