/*  Part of XPCE --- The SWI-Prolog GUI toolkit

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        jan@swi-prolog.org
    WWW:           https://www.swi-prolog.org/
    Copyright (c)  1985-2025, University of Amsterdam
			      SWI-Prolog Solutions b.v.
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

#define PCE_INCLUDED 1

#ifdef _MSC_VER
#define _CRT_SECURE_NO_WARNINGS
#pragma warning(disable : 4996)	/* deprecate open() etc */
#pragma warning(disable : 4244)	/* possible loss of data (int conversion) */
#pragma warning(disable : 4267)	/* possible loss of data (int conversion) */
#pragma warning(disable : 4018)	/* signed/unsigned comparison */
#pragma warning(disable : 4146)	/* unary minus operator applied to unsigned type */
#include <inttypes.h>
#endif

#include <md.h>

#define O_NOX11RESOURCES 1		/* use own resource parser */

#include <stdbool.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <stdarg.h>
#ifdef __APPLE__			/* defines INT_MAX, so we must */
#include <time.h>			/* do that before we do it here */
#endif
#include <h/stream.h>			/* IOSTREAM interface */
#include <limits.h>

#ifndef INT_MAX
#define INT_MAX	    ((int)(((unsigned int)1<<(sizeof(int)*8-1))-1))
#define INT_MIN     (-(INT_MIN)-1)
#endif

#ifdef HAVE_DMALLOC_H
#include <dmalloc.h>			/* Use www.dmalloc.com debugger */
#endif
#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#ifdef HAVE_XOS_H
#include <xos.h>
#endif

#ifdef HAVE_SYS_FILE_H
#include <sys/file.h>
#endif

#ifndef GLOBAL
#define GLOBAL extern			/* global variables */
#define PUBLIC_GLOBAL extern		/* exported global variables */
#endif

#if defined(WIN32)
#define __pce_export __declspec(dllexport) extern
#else
#define __pce_export extern
#endif

#ifndef export				/* WIN32 DLL export stuff */
#define export
#endif

		 /********************************
		 * AVOID ACCIDENTAL USE OF STDIO *
		 ********************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
The XPCE library should not use STDIO   to allow for embedding in window
environments. We undefine these  symbols  here   to  make  the  compiler
generate warnings on accidental use of them.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#ifndef __osf__
#undef stdin
#undef stdout
#undef stderr
#endif
#undef printf
#undef putchar
#undef getchar


		 /*******************************
		 *	SOME SYSTEM STUFF	*
		 *******************************/

#ifdef SYSLIB_H
#include SYSLIB_H
#endif

		/********************************
		*             LIMITS		*
		********************************/

#define PCE_MAX_RECURSION	1000	/* maximum send() recursion */
#define METHOD_MAX_ARGS		16	/* maximum # args for C-method */
#define FWD_PCE_MAX_ARGS	10	/* @arg1 ... @arg10 */
#define SCAN_MAX_ARGS		32	/* scanstr maximum arguments */
#define PCE_MAX_INT		((intptr_t)1<<51)
#define PCE_MIN_INT		(-PCE_MAX_INT)
#ifndef INT_MAX
#define INT_MAX			((int)(((unsigned int)1<<(sizeof(int)*8-1))-1))
#define INT_MIN			(-(INT_MIN)-1)
#endif

#define LINESIZE		2048	/* maximum length of a line */
#define FORMATSIZE		10000	/* maximum length of a ->format */
#define BROWSER_LINE_WIDTH	256	/* maximum #chars of line in browser */

		/********************************
		*           OS STUFF		*
		********************************/

#ifndef SIGNAL_HANDLER_TYPE		/* type returned by signal-handler */
#define SIGNAL_HANDLER_TYPE void
#endif

		 /*******************************
		 *	       CLEANUP		*
		 *******************************/

#define ATEXIT_FILO	0x1
#define ATEXIT_FIFO	0x2

typedef void			(*atexit_function)(int status);

		 /*******************************
		 *	 VARARG FUNCTIONS	*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Handling of send(Receiver, Method, ..., EAV),  etc. Note that EAV cannot
be just 0, as  on  some  machines   int  and  pointers  are  promoted to
different types when passed to a vararg function.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define VA_PCE_MAX_ARGS		10	/* send(), etc. */
#define EAV			((Any)0) /* End of the list */


		/********************************
		*       SAVING OBJECTS		*
		********************************/

#define SAVEMAGIC		"PCE version 4"
#define SAVEVERSION		18	/* last increment for 5.6.14 */

		/********************************
		*             ASSERTS		*
		********************************/

#undef assert
#ifdef NOASSERT
#define assert(expr) ((void)0)
#else
#define assert(expr) ((expr) ? (void)0 : \
			       (void)pceAssert(0,#expr,__FILE__,__LINE__))
#endif

		/********************************
		*        COMPILER STUFF		*
		********************************/

#if __STRICT_ANSI__
#undef TAGGED_LVALUE
#endif

#ifdef __GNUC__
# if !__STRICT_ANSI__			/* gcc -ansi */
#  ifndef O_INLINE
#   define O_INLINE 1
#  endif
#  define O_CONST_FUNCTION 1
# endif
# define Promote(type) int
#else
# define Promote(type) type
#endif

#ifdef HAVE_VISIBILITY_ATTRIBUTE
#define SO_LOCAL __attribute__((visibility("hidden")))
#else
#define SO_LOCAL
#endif

#if !O_INLINE
#define inline
#endif

#ifdef __GNUC__
#define PURE_FUNCTION __attribute__((pure))
#else
#define PURE_FUNCTION
#endif

#define forwards	static		/* Local functions */

#if __GNUC__ && !__STRICT_ANSI__
#define LocalArray(t, n, s)	t n[s]
#else
#define LocalArray(t, n, s)	t *n = (t *) alloca((s)*sizeof(t))
#endif

#define ArgVector(name, s)	LocalArray(Any, name, s)
#define CharBuf(name, s)	LocalArray(unsigned char, name, (s)+1)

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
cpdata(to, from, type, n)
    copies n objects of type type from `from' to `to'.  Does not deal with
    overlapping, but is much faster on relatively small data pieces then
    memcpy(to, from, (n)*sizeof(type)), to which it is equivalent.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#if 1
#define cpdata(to, from, type, n) memcpy(to, from, (n)*sizeof(type))
#else
#define cpdata(to, from, type, n) do \
	{ type *_t = (type*)(to)-1; \
	  type *_f = (type*)(from)-1; \
	  int   _i = (n); \
	  while(--_i >= 0) *++_t = *++_f; \
	} while(0)
#endif
#define setdata(to, val, type, n) do \
	{ type *_t = (to)-1; \
	  int   _i = (n); \
	  type  _v = (val); \
	  while(--_i >= 0) *++_t = _v; \
	} while(0)

#define NOTREACHED	assert(0)	/* should not get here */

#ifdef O_EXTRA_SYSTEM_TYPES
#include O_EXTRA_SYSTEM_TYPES
#endif

#define functionToPtr(f)   ((void*)(intptr_t)(f))
#define PtrToFunction(ptr) ((Any(*)())(intptr_t)(ptr))


		 /*******************************
		 * OS-IDENTIFIERS (STRICT_ANSI) *
		 *******************************/

#ifndef __unix__
#if defined(_AIX) || defined(__APPLE__) || defined(__unix) || defined(__BEOS__) || defined(__NetBSD__)
#define __unix__ 1
#endif
#endif

#if defined(__unix__) && !defined(unix)
#define unix 1
#endif

		/********************************
		*         NAME CONFLICTS	*
		********************************/

#define	CtoInt(i)	toInt(i)		/* int --> Int */
#define CtoName(s)	(Name)cToPceName((s))	/* const char * --> Name */
#define CtoType(s)	nameToType(CtoName(s))  /* char * --> type object */
#define WCtoType(s)	nameToType(WCToName(s, -1)) /* wchar_t * --> type object */
#define	pp(x)		pcePP((Any)(x))		/* interface name */
#define get             getPCE			/* avoid common name-conflict */
#define send            sendPCE			/* same */
#define toString	toStringPCE		/* SWI-Prolog name-conflict */
#define valReal		valPceReal		/* and another */

#undef hyper

		 /*******************************
		 *	    BASIC TYPES		*
		 *******************************/

typedef int			status;		/* FAIL, SUCCEED */
typedef void *			Any;		/* Arbitrary object */

typedef Any			Int;		/* ZERO, ONE, ... */
typedef Any			Num;		/* tagged doubles */
typedef Any			(*Func)();	/* Absolete GetFunc (TBD) */
typedef Any			(*GetFunc)();	/* GetMethod implementation */
typedef status			(*SendFunc)();	/* SendMethod implementation */
typedef void			(*VoidFunc)();

typedef void *			WsRef;		/* Window-system reference */
typedef struct xref *		Xref;		/* Entry in ws-table */

typedef struct classdef        *ClassDef;	/* See pce-save.c */
typedef struct dCell	      **DelegateList;   /* See msg-passing.c */

#include "types.h"

#define INVOKE_FUNC ((SendFunc)~0L)


		/********************************
		*           TAG MASKS		*
		********************************/

#define INT_MASK	((uintptr_t)0x01) /* 01 mask for Int (integers) */
#define MASK_MASK	((uintptr_t)0x01) /* 11 Mask Mask */
#define TAG_BITS	1		  /* number of mask bits for INT */

#define MaskOf(obj)		((uintptr_t)(obj) & MASK_MASK)
#define UnMask(obj)		((uintptr_t)(obj) & ~MASK_MASK)


		/********************************
		*           EQUALITY		*
		********************************/

#define EQI(o1, o2)	((Any)(o1) == (Any)(o2))
#define EQ(o1, o2)	EQI(o1, o2)


		/********************************
		*             TYPES		*
		********************************/

#define ARGC_UNKNOWN		(-1)
#define ARGC_INHERIT		(-2)	/* classdecl */

		/********************************
		*           FUNCTIONS		*
		********************************/

#define isFunction(obj)		(isObject(obj) && onFlag(obj, F_ACTIVE))
#define isHostData(obj)		(isObject(obj) && onFlag(obj, F_ISHOSTDATA))


		/********************************
		*         PCE INTEGERS		*
		********************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PCE uses tagged integers rather than C   integers. The top TAG_BITS bits
hold the MASK whereas the remaining bits  hold the integer itself. A PCE
integer is declared as of type Int (for casting purposes). The following
test, conversion and computation macro's are provided.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#undef max
#undef min
#define max(a, b)	((a) > (b) ? (a) : (b))
#define min(a, b)	((a) < (b) ? (a) : (b))

typedef union
{ double d;
  uintptr_t u;
  intptr_t i;
  Int I;
} cvt_double;

static inline Int
toNum(double v)
{ cvt_double c = {.d = v};
  Int i = (Int)(c.u|INT_MASK);
  return i;
}

static double
valNum(Int i)
{ cvt_double c = {.I = i};
  c.u &= ~INT_MASK;
  return c.d;
}

static inline intptr_t
valInt(Int i)
{ return (intptr_t)valNum(i);
}

static inline Int
toInt(intptr_t i)
{ return toNum((double)i);
}

#define isInteger(i)	((uintptr_t)(i) & INT_MASK)
#define incrInt(i)	((i) = toInt(valInt(i)+1))
#define decrInt(i)	((i) = toInt(valInt(i)-1))
#define addInt(i, j)	((i) = toInt(valInt(i) + valInt(j)))
#define subInt(i, j)	((i) = toInt(valInt(i) - valInt(j)))
#define maxInt(i, j)	toInt(max(valInt(i), valInt(j)))
#define absInt(i)	(valInt(i) < 0 ? neg(i) : i)

#undef div
#define neg(i)		(toInt(-valInt(i)))
#define add(i, j)	(toInt(valInt(i) + valInt(j)))
#define sub(i, j)	(toInt(valInt(i) - valInt(j)))
#define div(i, j)	(toInt(valInt(i) / valInt(j)))
#define mul(i, j)	(toInt(valInt(i) * valInt(j)))
#define avg(i, j)	(toInt((valInt(i) + valInt(j))/2))
#define mid(i, j)	(toInt((valInt(i) + valInt(j)/2)))
#define dif(i, j)	(toInt((valInt(i) - valInt(j)/2)))
#define inc(i)		(toInt(valInt(i) + 1))
#define dec(i)		(toInt(valInt(i) - 1))

#define ZERO		((Int)(uintptr_t)1)
#define ONE		toInt(1)	/* PCE Int 1 */
#define TWO		toInt(2)	/* PCE Int 2 */


		/********************************
		*          DFLAG VALUES		*
		********************************/


#define makeDFlag(n)		(1L << ((n) - 1 + TAG_BITS))
#define DFlags(obj)		(((ProgramObject)(obj))->dflags)
#ifndef TAGGED_LVALUE
#define setDFlag(obj, mask)     setDFlagProgramObject((obj), (mask))
#define clearDFlag(obj, mask)	clearDFlagProgramObject((obj), (mask))
#else
#define setDFlag(obj, mask)	(DFlags(obj) |= (mask))
#define clearDFlag(obj, mask)	(DFlags(obj) &= ~(mask))
#endif
#define onDFlag(obj, mask)	(DFlags(obj) & (mask))
#define offDFlag(obj, mask)	(!onDFlag(obj, mask))

					/* Debugging flags */
#define D_TRACE_ENTER	  makeDFlag(1)	/* Trace enter port of method */
#define D_TRACE_EXIT	  makeDFlag(2)	/* Trace exit port of method */
#define D_TRACE_FAIL	  makeDFlag(3)	/* Trace fail port of method */
#define D_TRACE		  (D_TRACE_ENTER|D_TRACE_EXIT|D_TRACE_FAIL)

#define D_BREAK_ENTER	  makeDFlag(4)	/* Break enter port of method */
#define D_BREAK_EXIT	  makeDFlag(5)	/* Break exit port of method */
#define D_BREAK_FAIL	  makeDFlag(6)	/* Break fail port of method */
#define D_BREAK		  (D_BREAK_ENTER|D_BREAK_EXIT|D_BREAK_FAIL)

#define D_SYSTEM	  makeDFlag(7) /* Generate system trace frame */

					/* Variable attributes */
#define D_SAVE_NORMAL	  makeDFlag(8) /* Save normally */
#define D_SAVE_NIL	  makeDFlag(9) /* Save as NIL */
#define D_SAVE		  (D_SAVE_NORMAL|D_SAVE_NIL)

#define D_CLONE_RECURSIVE makeDFlag(10) /* Clone object recursively */
#define D_CLONE_REFERENCE makeDFlag(11) /* Clone object reference */
#define D_CLONE_NIL	  makeDFlag(12) /* Cloned value is @nil */
#define D_CLONE_VALUE	  makeDFlag(13) /* Clone the plain PCE value */
#define D_CLONE_ALIEN	  makeDFlag(14) /* Clone alien values */
#define D_CLONE_REFCHAIN  makeDFlag(15) /* Value is a reference chain */
#define D_CLONE		  (D_CLONE_RECURSIVE|D_CLONE_REFERENCE|\
			   D_CLONE_NIL|D_CLONE_VALUE|D_CLONE_ALIEN|\
			   D_CLONE_REFCHAIN)

#define D_ALIEN		  makeDFlag(16) /* Variable is alien */
#define D_TYPENOWARN	  makeDFlag(17) /* Methods: donot warn */

					 /* Class attributes */
#define DC_LAZY_GET	  makeDFlag(18) /* bind get-behaviour lazy */
#define DC_LAZY_SEND	  makeDFlag(19) /* bind send-behaviour lazy */
#define D_CXX		  makeDFlag(20) /* C++ defined method/class */

					 /* ClassVariable attributes */
#define DCV_TEXTUAL	  makeDFlag(21) /* Default is textual */

					/* Method */
#define D_HOSTMETHOD	  makeDFlag(22) /* Implementation is in the host */
#define D_SERVICE	  makeDFlag(23)	/* Execute in `service' mode */


		/********************************
		*       CHAR_ARRAY, STRING	*
		********************************/

#include "str.h"			/* string type and friends */
#include "../txt/proto.h"		/* prototypes */

#define LocalString(name, iswide, size) \
  string _s_ ## name ## _hdr; \
  void  *_s_ ## name ## _buf = alloca((iswide) ? (size) * sizeof(charW)	\
					       : (size) * sizeof(charA)); \
  PceString name = fstr_inithdr(&_s_ ## name ## _hdr, iswide, _s_ ## name ## _buf, size)

		/********************************
		*         OBJECT HEADER		*
		********************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
[q]assign(obj, slot, value)
    assign() assigns a slot a value, qassign() does the same, but bypasses
    the object management system.  It should be used in very time-critical
    code where the value is constant (Int, Name, Constant).  Nowhere else!
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define assign(o, s, v)	assignField((Instance) (o), \
				    (Any *) &((o)->s), \
				    (Any) (v))
#define qassign(o, s, v) ((o)->s = (v))

#define makeFlag(n)		(1L << ((n) - 1))
#define setFlag(obj, mask)	(((Instance)(obj))->flags |= (mask))
#define clearFlag(obj, mask)	(((Instance)(obj))->flags &= ~(mask))
#define onFlag(obj, mask)	(((Instance)(obj))->flags & (mask))
#define offFlag(obj, mask)	(!onFlag(obj, mask))

#define	F_LOCKED		makeFlag(1)
#define	F_CREATING		makeFlag(2)
#define	F_FREED			makeFlag(3)
#define	F_FREEING		makeFlag(4)
#define	F_PROTECTED		makeFlag(5)
#define	F_ANSWER		makeFlag(6)
#define F_INSPECT		makeFlag(7)
#define F_ACTIVE		makeFlag(8)  /* Active object */
#define F_CONSTRAINT		makeFlag(9)  /* has constraints */
#define F_ATTRIBUTE		makeFlag(10) /* has attributes */
#define F_SENDMETHOD		makeFlag(11) /* has send-methods */
#define F_GETMETHOD		makeFlag(12) /* has get-methods */
#define F_HYPER			makeFlag(13) /* has hypers */
#define F_RECOGNISER		makeFlag(14) /* has recognisers */
#define F_ASSOC			makeFlag(15) /* has name-assoc */
#define F_ITFNAME		makeFlag(16) /* Name known to itf table */
#define F_SOLID			makeFlag(17) /* Solid graphical object */
#define F_OBTAIN_CLASSVARS	makeFlag(18) /* obtainClassVariablesObject() */
#define F_TEMPLATE_METHOD	makeFlag(19) /* method<-instantiate_template */
#define F_ISBINDING		makeFlag(20) /* instanceOf(x, ClassBinding) */
#define F_ISNAME		makeFlag(21) /* instanceOf(x, ClassName) */
#define F_ISREAL		makeFlag(22) /* instanceOf(x, ClassReal) */
#define F_ISHOSTDATA		makeFlag(23) /* instanceOf(x, ClassHostData) */
#define F_NOTANY		makeFlag(24) /* Not acceptable to any/object */

#define OBJ_MAGIC		((uintptr_t)0x14 << 25)
#define OBJ_MAGIC_MASK		((uintptr_t)0x7e << 25)

#define hasObjectMagic(obj)	((((Instance)(obj))->flags&OBJ_MAGIC_MASK) == \
					OBJ_MAGIC)

#define initHeaderObj(obj, cl) \
  { (obj)->class	= (cl); \
    (obj)->flags        = F_CREATING|OBJ_MAGIC; \
    (obj)->references   = 0L; \
  }

#define classOfObject(obj)	(((Instance)(obj))->class)

#define	setProtectedObj(obj)	setFlag(obj, F_PROTECTED)
#define	clearProtectedObj(obj)	clearFlag(obj, F_PROTECTED)
#define	isProtectedObj(obj)	onFlag(obj, F_PROTECTED)
#define	setCreatingObj(obj)	setFlag(obj, F_CREATING)
#define	clearCreatingObj(obj)	clearFlag(obj, F_CREATING)
#define	isCreatingObj(obj)	onFlag(obj, F_CREATING)
#define	setAnswerObj(obj)	setFlag(obj, F_ANSWER)
#define	clearAnswerObj(obj)	clearFlag(obj, F_ANSWER)
#define	isAnswerObj(obj)	onFlag(obj, F_ANSWER)

#define ONE_CODE_REF		(1L<<20)

#define refsObject(obj)		(((Instance)obj)->references % ONE_CODE_REF)
#define codeRefsObject(obj)	(((Instance)obj)->references / ONE_CODE_REF)
#define noRefsObj(obj)		(((Instance)obj)->references == 0L)
#define addRefObj(obj)		(((Instance)obj)->references++)
#define delRefObj(obj)		(((Instance)obj)->references--)
#define lockObj(obj)		setFlag(obj, F_LOCKED)
#define unlockObj(obj)		clearFlag(obj, F_LOCKED)
#define lockedObj(obj)		onFlag(obj, F_LOCKED)
#define setFreedObj(obj)	setFlag(obj, F_FREED)
#define isFreedObj(obj)		onFlag(obj, F_FREED)
#define setFreeingObj(obj)	setFlag(obj, F_FREEING)
#define isFreeingObj(obj)	onFlag(obj, F_FREEING)
#define isVirginObj(o)		(refsObject(o) == 0 && \
				 !onFlag(o, F_LOCKED|F_PROTECTED|F_ANSWER))
#define freeableObj(o)		if ( isVirginObj(o) ) \
				  freeObject(o)
#define checkDeferredUnalloc(o)	if ( (((Instance)o)->references) <= 0 ) \
				  unreferencedObject(o)

#define GcProtect(o, g)		do { \
				addCodeReference(o); \
				g; \
				delCodeReference(o); } while(0)



		/********************************
		*            CONSTANTS		*
		********************************/

#define NIL		((Any)(&ConstantNil))
#define DEFAULT		((Any)(&ConstantDefault))
#define CLASSDEFAULT	((Any)(&ConstantClassDefault))
#define ON		(&BoolOn)
#define OFF		(&BoolOff)

#define isOn(val)	((BoolObj)(val) == ON)
#define isOff(val)	((BoolObj)(val) == OFF)
#define isBoolean(val)	((BoolObj)(val) == ON || (BoolObj)(val) == OFF)

#define isNil(o)	((Constant)(o) == NIL)
#define notNil(o)	((Constant)(o) != NIL)
#define isDefault(o)	((Constant)(o) == DEFAULT)
#define notDefault(o)	((Constant)(o) != DEFAULT)
#define isClassDefault(o)	((Constant)(o) == CLASSDEFAULT)
#define notClassDefault(o)	((Constant)(o) != CLASSDEFAULT)

#define TrueOrFalse(b)	(isOn(b) ? TRUE : FALSE)

#define nonObject(obj)	(MaskOf(obj) || !(obj))
#define isObject(obj)	(!nonObject(obj))

		/********************************
		*         CAREFUL CHECKERS	*
		********************************/

#define validAddress(a)	((uintptr_t)(a) >= allocBase && \
			 (uintptr_t)(a) < allocTop)
#define isAddress(a)	(validAddress(a) && \
			 !((uintptr_t)(a) & (sizeof(Any)-1)))
#define validPceDatum(x) (isInteger(x) || isProperObject(x))


#ifndef TRUE
#define TRUE		1	/* boolean truth value */
#define FALSE		0	/* boolean false value */
#endif

#define FAIL		0	/* message failed */
#define SUCCEED		1	/* message completed successful */

#define fail		return FAIL
#define succeed		return SUCCEED
#define answer(v)	return (v)

#define DONE(goal)	if ( (goal)  ) succeed
#define TRY(goal)	if ( !(goal) ) fail
#define EXISTS(object)	if ( isNil(object) ) fail


		/********************************
		*       CLASS STRUCTURES	*
		********************************/

#define OBJECT_HEADER \
  uintptr_t     flags;			/* general flag field */ \
  uintptr_t     references;		/* reference count */ \
  Class		class;			/* Associated class */

#define ABSTRACT_OBJECT

#define ABSTRACT_PROGRAM_OBJECT \
  uintptr_t	dflags;			/* Debugging flags */

#define ABSTRACT_RECOGNISER \
  BoolObj		active;			/* Does accept events? */

#define ABSTRACT_CODE \
  ABSTRACT_PROGRAM_OBJECT

#define ABSTRACT_FUNCTION  \
  ABSTRACT_CODE

#define ABSTRACT_BINARY_EXPRESSION \
  ABSTRACT_FUNCTION \
  Expression	left;			/* Left-hand side */ \
  Expression	right;			/* Right-hand side */

#define ABSTRACT_BINARY_CONDITION \
  ABSTRACT_CODE \
  Expression	left;			/* Left-hand side */ \
  Expression	right;			/* Right-hand side */

#define ABSTRACT_VISUAL

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
NewClass(class) privides the structure header for any class  that is a
subclass of class `object'.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define NewClass(x) \
  struct x \
  { OBJECT_HEADER \
    ABSTRACT_OBJECT
#define End \
  }

struct instance
{ OBJECT_HEADER				/* non-pce header */
  Any		slots[];		/* array of slots. */
};

NewClass(object)
End;

NewClass(program_object)
  ABSTRACT_PROGRAM_OBJECT
End;

NewClass(vmi)
  ABSTRACT_PROGRAM_OBJECT
  Name		name;			/* Name of vmi */
End;

NewClass(c_pointer)
  void *	pointer;		/* the pointer value */
End;

NewClass(area)
  Int		x;			/* position and dimension */
  Int		y;
  Int		w;
  Int		h;
End;

NewClass(atable)
  Vector	keys;			/* bool vector stating key fields */
  Vector	names;			/* parameter names of the entries */
  Vector	tables;			/* hash tables */
End;

NewClass(tuple)
  Any		first;			/* first of tuple */
  Any		second;			/* second element of tuple */
End;

#define ABSTRACT_BEHAVIOUR \
  ABSTRACT_PROGRAM_OBJECT \
  Name		name;			/* Name of the behaviour */ \
  Any		context;		/* Object or class I belong too */

#define ABSTRACT_VARIABLE \
  ABSTRACT_BEHAVIOUR \
  Name		group;			/* Conceptual group */ \
  Name		access;			/* whether send/get may be used */ \
  Type		type;			/* type of contents */ \
  Int		offset;			/* offset from base (from 0) */ \
  StringObj	summary;		/* Summary for variable */ \
  Any		init_function;		/* Function to initialise */ \
  Any		alloc_value;		/* Allocate value of variable */

#ifndef O_RUNTIME
#define ABSTRACT_METHOD \
  ABSTRACT_BEHAVIOUR \
  Name		group;			/* Conceptual group */ \
  Vector	types;			/* type checking codes */ \
  StringObj	summary;		/* Summary of this method */ \
  SourceLocation source;		/* Location of def in sources */ \
  Code		message;		/* message implementing method */

#else /*O_RUNTIME*/

#define ABSTRACT_METHOD \
  ABSTRACT_BEHAVIOUR \
  Name		group;			/* Conceptual group */ \
  Vector	types;			/* type checking codes */ \
  StringObj	summary;		/* Summary of this method */ \
  Code		message;		/* message implementing method */
#endif/*O_RUNTIME*/

NewClass(behaviour)
  ABSTRACT_BEHAVIOUR
End;

NewClass(method)
  ABSTRACT_METHOD
  Func		function;		/* C-function implementing method */
End;

NewClass(send_method)
  ABSTRACT_METHOD
  SendFunc	function;		/* C-function implementing method */
End;

NewClass(get_method)
  ABSTRACT_METHOD
  GetFunc	function;		/* C-function implementing method */
  Type		return_type;		/* Type of returned value */
End;

NewClass(variable)
  ABSTRACT_VARIABLE
End;

NewClass(attribute)
  ABSTRACT_PROGRAM_OBJECT
  Any		name;			/* name of the attribute */
  Any		value;			/* value for the attribute */
End;

NewClass(class_variable)
  ABSTRACT_BEHAVIOUR
  Type		type;			/* Type of this variable */
  Any		value;			/* Value of the variable */
  Any		cv_default;		/* Default value */
  StringObj	summary;		/* Short documentation */
End;

NewClass(binding)
  Name		name;			/* name of the binding */
  Any		value;			/* Value of the binding */
End;

NewClass(error)
  Name		id;			/* Id of the error */
  Name		format;			/* Format of the error message */
  Name		kind;			/* {message,warning,error} */
  Name		feedback;		/* {inform,print} */
End;

NewClass(chain)
  Int		size;			/* # elements in the chain */
  Cell		head;			/* first element */
  Cell		tail;			/* last element */
  Cell		current;		/* current element */
End;

typedef struct instance_proto *InstanceProto;

struct instance_proto
{ int		size;			/* Size of the prototype (bytes) */
  struct object proto;			/* the proto itself */
};

		 /*******************************
		 *	CLASS AND LAZY STUFF	*
		 *******************************/

typedef struct _vardecl
{ Name		name;			/* name of the instance var */
  char         *type;			/* type */
  int		flags;			/* IV_<flag> bitwise or */
  void	       *context;		/* wrapper or function ptr */
  Name		group;			/* group identifier */
  char	       *summary;		/* documentation summary */
} vardecl;

typedef struct _senddecl
{ Name		name;			/* name of the method */
  int		arity;			/* arity thereof */
  void	       *types;			/* type or type-vector */
  SendFunc	function;		/* implementation */
  Name		group;			/* group id */
  char		*summary;		/* documentation summary */
} senddecl;

typedef struct _getdecl
{ Name		name;			/* name of the method */
  int		arity;			/* arity thereof */
  char	       *rtype;			/* return type */
  void	       *types;			/* type or type-vector */
  GetFunc	function;		/* implementation */
  Name		group;			/* group id */
  char	       *summary;		/* documentation summary */
} getdecl;

typedef struct _classvardecl
{ Name		name;			/* Name of the class-variable */
  char	       *type;			/* type description */
  char	       *value;			/* (default) value */
  char	       *summary;		/* documentation summary */
} classvardecl;

typedef struct _classdecl
{ vardecl      *variables;		/* Instance variables */
  senddecl     *send_methods;		/* Send methods of class */
  getdecl      *get_methods;		/* get methods of class */
  classvardecl *class_variables;	/* Variables of the class */
  int		nvar;			/* number of entries in tables */
  int		nsend;
  int		nget;
  int		nclassvars;
  int		term_arity;		/* Arity of term description */
  Name	       *term_names;		/* Array of term-names */
  char	       *source_file;		/* Name of the source-file */
  char	       *rcs_revision;		/* RCS version info */
} classdecl;

#define ClassDecl(name, vs, ss, gs, rs, ta, tn, rcs) \
	static classdecl name = \
	{ vs, ss, gs, rs, \
	  IVEntries(vs), SMEntries(ss), GMEntries(gs), RCEntries(rs), \
	  ta, tn, __FILE__, rcs \
	}

					/* Dont change IV_GET and IV_SEND */
#define IV_NONE		0x00		/* No access, nothing */
#define IV_GET		0x01		/* instance var get-access */
#define IV_SEND		0x02		/* instance var send-access */
#define IV_BOTH		(IV_GET|IV_SEND) /* convenience */
#define IV_SUPER	0x04		/* delegation variable */
#define IV_STORE	0x08		/* has store method */
#define IV_FETCH	0x10		/* has fetch method */
#define IV_REDEFINE	0x20		/* redefine existing variable */

#define RC_REFINE	(char *)(-1)	/* refinement of class-variable */

#define SM(n, a, t, f, g, s)	{ n, a, t, (SendFunc) f, (Name) g, s }
#define GM(n, a, r, t, f, g, s) { n, a, r, t, (GetFunc) f, (Name) g, s }
#define RC(n, t, d, s)		{ n, t, d, s }
#define IV(n, t, f, g, s)	{ n, t, f, NULL,        (Name) g, s }
#define SV(n, t, f, c, g, s)	{ n, t, f, functionToPtr(c), (Name) g, s }
#define IVEntries(l)		(sizeof(l) / sizeof(vardecl))
#define SMEntries(l)		(sizeof(l) / sizeof(senddecl))
#define GMEntries(l)		(sizeof(l) / sizeof(getdecl))
#define RCEntries(l)		(sizeof(l) / sizeof(classvardecl))
#define TNEntries(l)		(sizeof(l) / sizeof(Name))

#ifndef UXWIN
#ifdef WIN32_GRAPHICS
#define UXWIN(unx, win) win
#else
#define UXWIN(unx, win) unx
#endif
#endif

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE

If you  add/delete slots, do  not forget to  change PCE_CLASS_SLOTS in
pce-class.c
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

NewClass(class)
  ABSTRACT_PROGRAM_OBJECT \
  Name		name;			/* (2) name for this class */ \
  StringObj	summary;		/* Summary of the class */ \
  Name		creator;		/* Created from where? */ \
  Class		super_class;		/* (abstract) super-class */ \
  Chain		sub_classes;		/* list of sub-classes */
  Vector	instance_variables;	/* (7) local variables */
  Chain		send_methods;		/* send methods for this class */
  Chain		get_methods;		/* get methods for this class */
  Vector	term_names;		/* get method to obtain arguments */
  Chain		delegate;		/* variables I delegate to */
  Chain		class_variables;	/* Class variables of this class */
  Name		cloneStyle;		/* style of clone method */
  Name		saveStyle;		/* special save method */
  Sheet		features;		/* installed features */
  Int		no_created;		/* how many were created */
  Int		no_freed;		/* how many were freed */
  BoolObj		solid;			/* graphicals: OFF by default */
  Name		selection_style;	/* graphicals: feedback selected */
  Chain		handles;		/* graphicals only: connection pts */
  Int		instance_size;		/* Instance size in bytes */
  Int		slots;			/* # instance variables */
  SourceLocation source;		/* Source location */
  Name		rcs_revision;		/* Current rcs-revision of source */
  Chain		changed_messages;	/* Trap instance changes */
  Chain		created_messages;	/* Trap instance creation */
  Chain		freed_messages;		/* Trap instance destruction */
  BoolObj		un_answer;		/* Decide on slot assignment */

  Code		make_class_message;	/* Message to build the class */

  SendMethod	initialise_method;	/* Initialise instance */
  SendMethod	send_catch_all;		/* Catch failed sends */
  GetMethod	get_catch_all;		/* Catch failed gets */
  GetMethod	convert_method;		/* Convert to this type */
  GetMethod	lookup_method;		/* Reusable object-lookup */

  Code		resolve_method_message;	/* Lazy definition of methods */

  HashTable	send_table;		/* hash-table of send methods */
  HashTable	get_table;		/* hash-table of get methods */
  HashTable	local_table;		/* hash-table of instance variables */
  HashTable	class_variable_table;	/* hash-table of class-variables */
  HashTable	instances;		/* hash-table holding the instances */

  BoolObj		realised;		/* Class has been realised? */
  Name		init_variables;		/* How to initialise slots */

  InstanceProto	proto;			/* Prototype instance */
  intptr_t	tree_index;		/* Index in depth-first tree */
  intptr_t	neighbour_index;	/* Index of my neighbour */

  Any	      (*get_function)(Function); /* `Get' on Code objects */
  status      (*send_function)(Code);	/* `Send' on Code objects */
  status      (*saveFunction)(Any obj, Any file); /* function handling saveFile */
  status      (*loadFunction)(Any obj, Any file, Any def); /* function handling loadFile */
  status      (*cloneFunction)(Instance, Instance); /* function to clone object */
  SendFunc	redrawFunction;		/* redraw a graphical */
  status      (*changedFunction)(Instance, Any*);	/* Trap instance changes */
  status      (*in_event_area_function)(Any gr, Int xc, Int yc); /* Test if event is in area */
  status      (*make_class_function)(Class);	/* makeClass function pointer */
  intptr_t	boot;			/* When booting: #pce-slots; else 0 */

  classdecl    *c_declarations;		/* Non-object declarations */
End;

NewClass(type)
  ABSTRACT_PROGRAM_OBJECT
  Name		kind;			/* Kind of type */
  Name		fullname;		/* Logical name of the type */
  Name		argument_name;		/* Name of the argument */
  Chain		supers;			/* Super-types */
  Any		context;		/* Context argument for functions */
  BoolObj	vector;			/* Method: vector of these */
  intptr_t	validate_function;	/* Function to check the type */
  Any	      (*translate_function)(Type t, Any val, Any ctx);	/* Function to convert the type */
End;

NewClass(constraint)
  Any		from;			/* 'From' object of constraint */
  Any		to;			/* 'To' object of constraint */
  Relation	relation;		/* relation they have */
  Name		locked;			/* locked fro further messages? */
End;

NewClass(date)
  union
  { intptr_t	date;			/* Unix view of time */
    Any		slot;			/* dummy */
  } date;
End;

NewClass(dict)
  Any		browser;		/* browser showing contents */
  Chain		members;		/* list of dict_items */
  HashTable	table;			/* hash table for associative lookup */
  Code		sort_by;		/* Sort cirterium */
End;

NewClass(dictitem)
  ABSTRACT_VISUAL
  Any		key;			/* key (often same as label) */
  CharArray	label;			/* label displayed in browser */
  Any		object;			/* associated object (often a sheet) */
  Name		style;			/* Display style */
  Int		index;			/* index number (0 upwards) */
  Dict		dict;			/* dict object in which item resides */
End;

NewClass(divide)
  ABSTRACT_BINARY_EXPRESSION
End;

NewClass(equation)
  ABSTRACT_BINARY_CONDITION
End;

NewClass(binary_expression)
  ABSTRACT_BINARY_EXPRESSION
End;

NewClass(binary_condition)
  ABSTRACT_BINARY_CONDITION
End;

NewClass(handle)
  Expression	xPosition;		/* X position of handle */
  Expression	yPosition;		/* Y position of handle */
  Name		kind;			/* Kind of handle */
  Name		name;			/* Logical nam of connection */
End;

NewClass(modifier)
  Name		shift;			/* {up,down,@default} */
  Name		control;		/* {up,down,@default} */
  Name		meta;			/* {up,down,@default} */
  Name		gui;			/* {up,down,@default} */
End;


#define ABSTRACT_GESTURE \
  ABSTRACT_RECOGNISER \
  Name		button;			/* {left,middle,right} */ \
  Modifier	modifier;		/* shift-control-meta */ \
  Code		condition;		/* Additional conditions */ \
  Name		status;			/* {inactive, ...} */ \
  Any		cursor;			/* Cursor while acitive */ \
  Name		drag_scroll;		/* Scroll when dragging out */ \
  Timer		drag_scroll_timer;	/* Associated timer */ \
  EventObj	drag_scroll_event;	/* Last event for drag-scroll */

NewClass(gesture)
  ABSTRACT_GESTURE
End;

NewClass(handler)
  ABSTRACT_RECOGNISER
  Name		event;			/* type of event handled by handler */
  Code		message;		/* message associated with handler */
  RegionObj	region;			/* region of the receiver */
End;

NewClass(handlergroup)
  ABSTRACT_RECOGNISER
  Chain		members;		/* Handlers of the group */
End;

#define ABSTRACT_HASH_TABLE \
  Name		refer;			/* Maintain references */ \
  Int		size;			/* # symbols in table */ \
  intptr_t	buckets;		/* # buckets in symbol-array */ \
  Symbol	symbols;		/* Symbol-array */

NewClass(hash_table)
  ABSTRACT_HASH_TABLE
End;

NewClass(chain_table)
  ABSTRACT_HASH_TABLE
End;

NewClass(hyper)
  ABSTRACT_PROGRAM_OBJECT
  Any		from;			/* first linked object */
  Any		to;			/* second linked object */
  Name		forward_name;		/* name of the link from <-from */
  Name		backward_name;		/* name of the link from <-to */
End;

NewClass(identity)
  Name		from;			/* selector of 'from' object */
  Name		to;			/* selector of 'to' object */
End;

NewClass(minus)
  ABSTRACT_BINARY_EXPRESSION
End;

#define ABSTRACT_SOURCE_SINK \
  Name		encoding;		/* used encoding */

#define ABSTRACT_CHAR_ARRAY \
  string	data;			/* the represented data */

NewClass(char_array)
  ABSTRACT_CHAR_ARRAY
End;

NewClass(name)
  ABSTRACT_CHAR_ARRAY
End;

NewClass(string)
  ABSTRACT_CHAR_ARRAY
End;

NewClass(source_sink)
  ABSTRACT_SOURCE_SINK
End;

NewClass(number)
  intptr_t	value;			/* value of the number */
End;

NewClass(pce)
#ifndef O_RUNTIME
  BoolObj		debugging;		/* debugging? (watching spy points) */
  BoolObj		trap_errors;		/* Trap tracer on errors */
#endif
  Name		last_error;		/* Last error occurred */
  Chain		catched_errors;		/* Stack of catched error-id's */
  BoolObj		catch_error_signals;	/* Catch Unix signals */

  Chain		exit_messages;		/* Called on exit */
  Sheet		exception_handlers;	/* exception-name --> code */

  Name		home;			/* Home directory */
  SourceSink	defaults;		/* Location to load defaults from */
  Directory	application_data;	/* User application data */

  Name		version;		/* Version number of PCE */
  Name		machine;		/* Architecture */
  Name		operating_system;	/* Name of operating system*/
  Name		window_system;		/* x11, windows or sdl */
  Int		window_system_version;	/* Major version of window system */
  Int		window_system_revision;	/* Minor version of window_system */
  Name		window_system_driver;	/* Backend driver */
  Chain		features;		/* Installed features */
End;

NewClass(plus)
  ABSTRACT_BINARY_EXPRESSION
End;

NewClass(point)
  Int		x;			/* the x- and y-coordinates */
  Int		y;
End;

#define ABSTRACT_HOST \
  Name		language;		/* Prolog, Lisp, ... */ \
  Name		system;			/* host system we are connected to */ \
  BoolObj		callBack;		/* if @on can be called directly */ \
  Chain		messages;		/* messages waiting in queue */


NewClass(host)
  ABSTRACT_HOST
End;

NewClass(host_data)
  void *	handle;			/* the host handle */
End;

NewClass(real)
#if SIZEOF_VOIDP == SIZEOF_DOUBLE
#define REAL_IN_ONE 1
  double	value;			/* can store in one slot */
#else
  uintptr_t value1;			/* 1-st part of double */
  uintptr_t value2;			/* 2nd-part of double */
#endif
End;

NewClass(recogniser)
  ABSTRACT_RECOGNISER
End;

NewClass(region)
  Expression	x;			/* describe x of region */
  Expression	y;			/* describe y of region */
  Expression	w;			/* describe w of region */
  Expression	h;			/* describe h of region */
End;

NewClass(relation)			/* empty abstract super class */
End;

NewClass(size)
  Int		w;			/* width and height */
  Int		h;
End;

#define ABSTRACT_SHEET \
  Chain		attributes;		/* list of attributes */

NewClass(sheet)
  ABSTRACT_SHEET
End;

NewClass(source_location)
  Name		file_name;		/* Name of the file */
  Int		line_no;		/* Line of the source location */
End;

NewClass(spatial)
  Equation	xFrom;			/* X reference point of from */
  Equation	yFrom;			/* Y reference point of from */
  Equation	xTo;			/* X reference point of to */
  Equation	yTo;			/* Y reference point of to */
  Equation	wTo;			/* W of to */
  Equation	hTo;			/* H of to */
End;

NewClass(times)
  ABSTRACT_BINARY_EXPRESSION
End;

#define ABSTRACT_VECTOR \
  Int		offset;			/* index of element 0 of array */ \
  Int		size;			/* number of valid entries */ \
  Int		allocated;		/* # allocated cells */ \
  Any		*elements;		/* array of elements */

NewClass(vector)
  ABSTRACT_VECTOR
End;

NewClass(visual)
  ABSTRACT_VISUAL
End;


struct cell
{ Cell		next;			/* pointer to next cell */
  Any		value;			/* value pointer */
};


struct symbol
{ Any		name;			/* name entry of symbol */
  Any		value;			/* associated value with name */
};

#define ABSTRACT_CONSTANT \
  Name		name;			/* Name of the constant */ \
  StringObj	summary;		/* Summary description */

NewClass(constant)			/* @nil, @default */
  ABSTRACT_CONSTANT
End;

NewClass(boolean)
/* @on, @off */
  ABSTRACT_CONSTANT
End;

NewClass(code)
  ABSTRACT_CODE
End;

NewClass(function)
  ABSTRACT_FUNCTION
End;

NewClass(quote_function)
  Function	function;		/* the function quoted */
End;

#define ABSTRACT_AND \
  ABSTRACT_CODE \
  Chain		members;		/* members of the and */

NewClass(and)
  ABSTRACT_AND
End;

NewClass(assignment)
  ABSTRACT_CODE
  Var		var;			/* Variable to bind */
  Any		value;			/* Value (or function) */
  Name		scope;			/* Local or global binding */
End;

NewClass(var)
  ABSTRACT_FUNCTION
  Name		name;			/* Name of the variable */
  Type		type;			/* Type of the variable */
  Any		global_value;		/* Initial or global value */
End;

NewClass(obtain)
  ABSTRACT_FUNCTION
  Any		receiver;		/* receiver of the message */
  Name		selector;		/* selector of the message */
  Vector	arguments;		/* argument vector of the message */
  Any		context;		/* Host context */
End;

NewClass(create_obj)
  ABSTRACT_FUNCTION
  Class		c_class;		/* Class to create instance from */
  Vector	arguments;		/* Initialisation arguments */
End;

NewClass(message)
  ABSTRACT_CODE
  Any		receiver;		/* receiver of the message */
  Name		selector;		/* selector of the message */
  Int		arg_count;		/* number of arguments */
  Vector	arguments;		/* argument vector of the message */
  Any		context;		/* Host context */
End;

NewClass(block)
  ABSTRACT_AND
  Vector	parameters;		/* formal-parameter-list */
End;

NewClass(if_obj)
  ABSTRACT_CODE
  Code		condition;		/* codition of the `if' */
  Code		then_branch;		/* if condition succeeds */
  Code		else_branch;		/* if condition fails */
End;

NewClass(while_obj)
  ABSTRACT_CODE
  Code		condition;		/* condition of the `while' */
  Code		body;			/* body of the `while' */
End;

NewClass(equal)				/* == */
  ABSTRACT_CODE
  Any		left;
  Any		right;
End;

NewClass(non_equal)			/* \== */
  ABSTRACT_CODE
  Any		left;
  Any		right;
End;

NewClass(or)
  ABSTRACT_CODE
  Chain		members;		/* members of the or */
End;

NewClass(not)
  ABSTRACT_CODE
       Code		argument;	/* Its argument */
End;

NewClass(progn)
  ABSTRACT_FUNCTION
  Chain			members;	/* statements */
End;

NewClass(when)
  ABSTRACT_FUNCTION
  Code		condition;		/* codition of the `when' */
  Function	then_branch;		/* value if condition succeeds */
  Function	else_branch;		/* value if condition fails */
End;

		 /*******************************
		 *	     CLASSES		*
		 *******************************/

struct class_definition
{ Name		name;			/* name of the class */
  Name		super;			/* Name of the super-class */
  SendFunc	makefunction;		/* Built the class */
  Class *	global;			/* Pointer to global class var */
  char *	summary;		/* Summary description */
};

		 /*******************************
		 *	       NAMES		*
		 *******************************/

#ifndef NO_BUILT_IN_DECL
extern struct name builtin_names[];	/* object-array of built-in's */
#endif
#include "h/names.ih"			/* #defines for code used names */

#define isName(name)	(isObject(name) && onFlag((name), F_ISNAME))
#define notName(name)	(!isName(name))
#define equalName(a, b) ((a) == (b))
#define strName(s)	((char *)((Name)(s))->data.s_textA)

#define getAppendName(n, s) \
	((Name) getAppendCharArray((CharArray)(n), (CharArray)(s)))


		/********************************
		*         FORWARDING		*
		********************************/

#define Arg(i)			(ARG[((i)-1)])
#define	setVar(v, val)		((v)->value = val)

typedef struct
{ Var	variable;
  Any	value;
} var_binding, *VarBinding;

#define BINDINGBLOCKSIZE 8

typedef struct var_environment * VarEnvironment;
typedef struct var_extension * VarExtension;

struct var_environment
{ VarEnvironment parent;
  int		 size;
  var_binding	 bindings[BINDINGBLOCKSIZE];
  VarExtension   extension;
};


struct var_extension
{ int		 allocated;
  var_binding	 bindings[BINDINGBLOCKSIZE];
};

#define withLocalVars(code) \
  { struct var_environment _var_env; \
 \
    _var_env.size = 0; \
    _var_env.parent = varEnvironment; \
    _var_env.extension = NULL; \
    varEnvironment = &_var_env; \
 \
    code; \
 \
    popVarEnvironment(); \
  }


#define withArgs(ac, av, code) \
  { struct var_environment _var_env; \
    int _i; \
 \
    _var_env.parent = varEnvironment; \
    _var_env.extension = NULL; \
    varEnvironment = &_var_env; \
 \
    if ( ac <= BINDINGBLOCKSIZE ) \
    { Var *_v = &ARG[0]; \
      VarBinding _b = &_var_env.bindings[0]; \
      const Any *_val = (av); \
      for( _i=ac; --_i >= 0; _b++, _v++, _val++) \
      { _b->variable = *_v; \
	_b->value = *_val; \
	if ( isObject(*_val) ) \
	  addCodeReference(*_val); \
      } \
      _var_env.size = (ac); \
    } else \
    { _var_env.size = 0; \
      for(_i=0; _i<ac; _i++) \
	assignVar(Arg(_i+1), (av)[_i], DEFAULT); \
    } \
 \
    code; \
 \
    popVarEnvironment(); \
  }

#define withReceiver(r, c, code)			\
  withLocalVars(					\
  { assignVar(RECEIVER, (r), NAME_local);		\
    assignVar(RECEIVER_CLASS, (c), NAME_local);		\
    code;						\
  })


		/********************************
		*        INCREMENTAL GC		*
		********************************/

typedef struct to_cell *ToCell;		/* TemporaryObjectCell */

struct to_cell
{ ToCell	next;			/* Next of the stack */
  Any		value;			/* Object there */
  long		index;			/* Index of the mark */
};

GLOBAL int	deferredUnalloced;	/* # deferred unallocs in ->free */

typedef intptr_t AnswerMark;

#define markAnswerStack(mark)	{(mark) = AnswerStack->index;}
#define rewindAnswerStack(mark, obj) \
	{ if ( (mark) != AnswerStack->index ) \
	    _rewindAnswerStack(&(mark), obj); }


		 /*******************************
		 *	 GLOBAL FUNCTIONS	*
		 *******************************/

#include "../ker/proto.h"
#include "../msg/proto.h"
#include "../adt/proto.h"
#include "../rel/proto.h"

/* Pointer <-> integer conversion */

#ifdef VARIABLE_POINTER_OFFSET
#undef POINTER_OFFSET
GLOBAL uintptr_t pce_data_pointer_offset;
#define POINTER_OFFSET pce_data_pointer_offset
#else
#ifndef POINTER_OFFSET
#define POINTER_OFFSET (0L)
#endif
#endif

#define longToPointer(i) ((Any) (i * sizeof(void*) + POINTER_OFFSET))
#define IntToPointer(i)  longToPointer(valInt(i))

static inline uintptr_t
PointerToCInt(void *p)
{ uintptr_t i = ((uintptr_t)(p) - POINTER_OFFSET)/sizeof(void*);

  assert(longToPointer(i) == p);
  return i;
}

#define PointerToInt(p)	 toInt(PointerToCInt(p))


#define getSubName(n, f, t) (Name)getSubCharArray((CharArray)(n), f, t)

					/* Interface callback stubs */
__pce_export void	Cprintf(const char *fmt, ...);
__pce_export void	Cvprintf(const char *fmt, va_list args);
__pce_export int	Cputchar(int chr);
__pce_export char *	Cgetline(char *line, int size);

					/* interface prototypes */
__pce_export Any	cToPceName(const char *text);
COMMON(CPointer) CtoCPointer(void *);
COMMON(status)	makeClassC(Class class);
COMMON(status)	makeClassRC(Class class);
COMMON(status)	makeClassCPointer(Class class);
COMMON(status)	initialiseHost(Host h, Name which);
COMMON(status)	makeClassHost(Class class);
COMMON(status)	makeClassHostData(Class class);
COMMON(status)	makeClassSourceSink(Class class);
COMMON(Host)	HostObject(void);
COMMON(int)	hostGetc(void);
COMMON(void)	pceWriteErrorGoal(void);
COMMON(int)	initPublicInterface(void);

COMMON(status)	initialiseSourceSink(SourceSink ss);
COMMON(status)	checkErrorSourceSink(SourceSink ss, IOSTREAM *fd);
COMMON(status)	initialiseSourceSink(SourceSink ss);
COMMON(IOSTREAM *)	Sopen_object(Any obj, const char *mode);
COMMON(status)	setStreamEncodingSourceSink(SourceSink ss, IOSTREAM *fd);
COMMON(Name)	encoding_to_name(IOENC encoding);

#if O_CPLUSPLUS
COMMON(status )	callCPlusPlusProc(void *f, int ac, const Any av[]);
COMMON(Any)	callCPlusPlusFunc(void *f, int ac, const Any av[]);
COMMON(status )	callCPlusPlusPceMethodProc(Any o, void *f,
					   int ac, const Any av[]);
COMMON(Any )	callCPlusPlusPceMethodFunc(Any o, void *f,
					   int ac, const Any av[]);
COMMON(status )	callCPlusPlusMethodProc(Any o, void *f,
					int ac, const Any av[]);
COMMON(Any )	callCPlusPlusMethodFunc(Any o, void *f,
					int ac, const Any av[]);
#endif
COMMON(void)	initCGlobals(void);

		/********************************
		*       GLOBAL VARIABLES	*
		********************************/

GLOBAL int	XPCE_initialised;	/* Is system initialised? */
GLOBAL Pce	PCE;			/* the one and only Pce object */
GLOBAL Host	HOST;			/* the one and only Host object */
GLOBAL status	(*DispatchEvents)(IOSTREAM*, int); /* Dispatch function */
GLOBAL int	changedLevel;		/* Change forwarding levels */
GLOBAL HashTable ErrorTable;		/* @error_database */
GLOBAL bool	XPCE_mt;			/* we are multi-threaded */

GLOBAL struct constant ConstantNil;	/* MUST be first! */
GLOBAL struct constant ConstantDefault;
GLOBAL struct constant ConstantClassDefault;
GLOBAL struct boolean  BoolOn;
GLOBAL struct boolean  BoolOff;

GLOBAL Var	RECEIVER;		/* @receiver */
GLOBAL Var	RECEIVER_CLASS;		/* @receiver_class */
GLOBAL Var	EVENT;			/* @event */
GLOBAL Var	SELECTOR;		/* @selector */
GLOBAL Var	REPORTEE;		/* @reportee */
GLOBAL Var	ARG[FWD_PCE_MAX_ARGS];  /* @arg1 ... */
GLOBAL Var	VarX;			/* x */
GLOBAL Var	VarY;			/* y */
GLOBAL Var	VarW;			/* w */
GLOBAL Var	VarH;			/* h */
GLOBAL Var	VarW2;			/* w2 */
GLOBAL Var	VarH2;			/* h2 */
GLOBAL Var	VarXref;		/* xref */
GLOBAL Var	VarYref;		/* yref */


GLOBAL HashTable classTable;		/* @classes (name --> class) */
GLOBAL HashTable TypeTable;		/* @types (name --> type) */

#define CTE_OK			0	/* CheckType success */
#define CTE_OBTAINER_FAILED	1	/* Obtainer failed */

GLOBAL int	CheckTypeError;		/* Why did checkType fail? */
GLOBAL int	restoreVersion;		/* Version of save file */
GLOBAL SourceSink LoadFile;		/* Current file for <-object */
GLOBAL char    *SaveMagic;		/* Magic string for saved objects */
GLOBAL int	inBoot;			/* is the system in the boot cycle? */
GLOBAL uintptr_t allocBase;		/* lowest allocated memory */
GLOBAL uintptr_t allocTop;		/* highest allocated memory */
#ifndef O_RUNTIME
GLOBAL int	PCEdebugging;		/* PCE->debugging == ON */
GLOBAL int	PCEdebugBoot;		/* Debug booting phase? */
GLOBAL Chain	PCEdebugSubjects;	/* Names of things we are debugging */
GLOBAL char    *symbolFile;		/* current symbol file */
#else
#define PCEdebugging FALSE
#endif /*O_RUNTIME*/
GLOBAL int	PCEargc;		/* main() argument count */
GLOBAL char   **PCEargv;		/* main() argument vector */
GLOBAL char    *(*getFunctionNameFromAddress)();
					/* stack trace (pce-debug.c) */

GLOBAL HashTable ObjectConstraintTable;	/* object-level constraints */
GLOBAL HashTable ObjectAttributeTable;	/* object-level attributes */
GLOBAL HashTable ObjectSendMethodTable;	/* object-level send_methods */
GLOBAL HashTable ObjectGetMethodTable;	/* object-level get_methods */
GLOBAL HashTable ObjectRecogniserTable;	/* object-level recognisers */
GLOBAL HashTable ObjectHyperTable;	/* object-level hypers */

GLOBAL Name	name_procent_s;		/* "%s" */
GLOBAL Name	name_cxx;		/* "C++" */
GLOBAL Name	name_nil;		/* "[]" */
GLOBAL Name	name_space;		/* " " */
GLOBAL Code	qsortCompareCode;	/* used by qsortCompareObjects() */
GLOBAL int	qsortReverse;		/* used by qsortCompareObjects() */

		 /*******************************
		 *	    GLOBAL TYPES	*
		 *******************************/

extern char *T_report[];		/* ->report: kind, format, args... */

		/********************************
		*        SET ITERATION		*
		********************************/

#define copyArgs(n, f, t) \
  { int _i; for(_i=0; _i < (n); _i++) (t)[_i] = (f)[_i]; }

#define for_chain(ch, val, code) \
  { intptr_t _i=0, _size  = valInt(ch->size); \
    Any *_array = (Any *)alloca((size_t)_size * sizeof(Any)); \
    Cell _cell = ch->head; \
	\
    for( ; notNil(_cell); _cell = _cell->next, _i++ ) \
    { _array[_i] = _cell->value; \
      if ( isObject(_array[_i]) ) addCodeReference(_array[_i]); \
    } \
    for(_i = 0; _i < _size; _i++) \
    { (val) = _array[_i]; \
      if ( nonObject(val) || !isFreedObj(val) ) \
      { code; \
      } \
      if ( isObject(val) ) delCodeReference(val); \
    } \
  }

#define for_vector(v, val, code) \
  { intptr_t _iv, _sizev = valInt((v)->size); \
    for(_iv = 0; _iv < _sizev; _iv++) \
    { val = (v)->elements[_iv]; \
      code; \
    } \
  }

#define for_vector_i(v, val, i, code) \
  { intptr_t _iv, _sizev = valInt((v)->size); \
    intptr_t _offv = valInt((v)->offset)+1; \
    for(_iv = 0; _iv < _sizev; _iv++) \
    { intptr_t i = _iv + _offv; \
      val = (v)->elements[_iv]; \
      code; \
    } \
  }


#define for_hash_table(ht, var, code) \
  { intptr_t _iht, _sizeht = (ht)->buckets; \
    for(_iht = 0; _iht < _sizeht; _iht++) \
    { Symbol var = &(ht)->symbols[_iht]; \
      if ( var->name != NULL ) \
      { code; \
      } \
    } \
  }


/* Iterate over a chain.  The body may remove the cell `c`, but __not__
 * the cell that follows `c`.
 */

#define for_cell(c, ch)							\
  if (notNil(c=(ch)->head))						\
    for(Cell _q=c->next; notNil(c); c=_q, _q=(isNil(_q) ? _q : _q->next))


		/********************************
		*          EXPRESSIONS		*
		********************************/

#define LEFTHAND(e)	(((BinaryExpression)e)->left)
#define RIGHTHAND(e)	(((BinaryExpression)e)->right)


		/********************************
		*             AREAS		*
		********************************/

/* An area has an orientation defined as the point where the origin
 * of the area is:
 *
 *   northWest	    northEast
 *	-----------------
 *      |		|
 *      |		|
 *	-----------------
 *   southWest	    southEast
 */

#define OrientationArea(w, h)	(w>=0 ? (h>=0 ? NAME_northWest		\
					       : NAME_southWest)	\
				       : (h>=0 ? NAME_northEast		\
					       : NAME_southEast))


#define OrientateArea(x, y, w, h, d) \
  { if ( equalName(d, NAME_northWest) ) \
    { if (w < 0) x += w+1, w = -w; \
      if (h < 0) y += h+1, h = -h; \
    } else if ( equalName(d, NAME_southWest) ) \
    { if (w < 0) x += w+1, w = -w; \
      if (h > 0) y += h-1, h = -h; \
    } else if ( equalName(d, NAME_northEast) ) \
    { if (w > 0) x += w-1, w = -w; \
      if (h < 0) y += h+1, h = -h; \
    } else if ( equalName(d, NAME_southEast) ) \
    { if (w > 0) x += w-1, w = -w; \
      if (h > 0) y += h-1, h = -h; \
    } \
  }


/* Normalise the area given by the C integers x, y, w, h
 * such that w and h are always positive.
 */
#define NormaliseArea(x,y,w,h)	{ if (w < 0) x += w+1, w = -w; \
				  if (h < 0) y += h+1, h = -h; \
				}

#ifndef O_RUNTIME
#define DEBUGGING(subject)	( PCEdebugging && pceDebugging(subject) )
#define DEBUG(subject, goal)	{ if ( DEBUGGING(subject) ) \
				  { goal; \
				  } \
				}

#define DEBUG_BOOT(goal)	{ if ( PCEdebugBoot ) \
				  { goal; \
				  } \
				}
#else /*O_RUNTIME*/
#define DEBUG(subject, goal)
#define DEBUG_BOOT(goal)
#define tracePce(pce, how)
#endif

#ifndef O_RUNTIME
#define O_COUNT 0			/* we've had that */
#else
#define O_COUNT 0
#endif

		/********************************
		*             SYNTAX		*
		********************************/

#include <h/syntax.h>
#include <h/utf8.h>

		 /*******************************
		 *	 SPEEDUP MACROS		*
		 *******************************/

#define sendv(rec, sel, ac, av) vm_send((rec), (sel), NULL, (ac), (av))
#define getv(rec, sel, ac, av) vm_get((rec), (sel), NULL, (ac), (av))
#define FixSendFunctionClass(cl, m) if ( !(cl)->send_function ) \
				      fixSendFunctionClass((cl), (m))
#define FixGetFunctionClass(cl, m) if ( !(cl)->get_function ) \
				      fixGetFunctionClass((cl), (m))

		 /*******************************
		 *	  HOST INTERFACE	*
		 *******************************/

#include <h/interface.h>
#include <h/thread.h>


		/********************************
		*        INLINE SUPPORT		*
		********************************/

#if O_COUNT
#define COUNT(g) {g;}

GLOBAL int hash_cmp_failed;		/* failed comparisons for lookup */
GLOBAL int hash_lookups;		/* Total lookups */
GLOBAL int hash_resizes;		/* # resizes done */
GLOBAL int hash_shifts;			/* Shifts in append */
#else
#define COUNT(g)
#endif

#define unboundedKey(name) (isInteger(name) ? (uintptr_t)(name)>>1 \
					    : (uintptr_t)(name)>>2)

#if USE_PRIMES
#define hashKey(name, buckets) (unboundedKey(name) % (buckets))
#else
#define hashKey(name, buckets) (unboundedKey(name) & ((buckets)-1))
#endif


#include "../ker/inline.c"
