1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: wielemak@science.uva.nl
5 WWW: http://www.swi.psy.uva.nl/projects/xpce/
6 Copyright (c) 1985-2007, University of Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #define PCE_INCLUDED 1
36
37 #include <md.h>
38
39 #define O_NOX11RESOURCES 1 /* use own resource parser */
40
41 #include <stdio.h>
42 #include <string.h>
43 #include <stdlib.h>
44 #include <stdarg.h>
45 #ifdef __APPLE__ /* defines INT_MAX, so we must */
46 #include <time.h> /* do that before we do it here */
47 #endif
48 #include <h/stream.h> /* IOSTREAM interface */
49 #include <limits.h>
50
51 #ifndef INT_MAX
52 #define INT_MAX ((int)(((unsigned int)1<<(sizeof(int)*8-1))-1))
53 #define INT_MIN (-(INT_MIN)-1)
54 #endif
55
56 #ifdef HAVE_DMALLOC_H
57 #include <dmalloc.h> /* Use www.dmalloc.com debugger */
58 #endif
59 #ifdef HAVE_MALLOC_H
60 #include <malloc.h>
61 #endif
62
63 #ifdef HAVE_XOS_H
64 #include <xos.h>
65 #endif
66
67 #ifdef HAVE_SYS_FILE_H
68 #include <sys/file.h>
69 #endif
70
71 #ifndef GLOBAL
72 #define GLOBAL extern /* global variables */
73 #define PUBLIC_GLOBAL extern /* exported global variables */
74 #endif
75
76 #if defined(WIN32) || defined(__CYGWIN__)
77 #define __pce_export __declspec(dllexport)
78 #else
79 #define __pce_export extern
80 #endif
81
82 #ifndef export /* WIN32 DLL export stuff */
83 #define export
84 #endif
85
86 /********************************
87 * AVOID ACCIDENTAL USE OF STDIO *
88 ********************************/
89
90 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
91 The XPCE library should not use STDIO to allow for embedding in window
92 environments. We undefine these symbols here to make the compiler
93 generate warnings on accidental use of them.
94 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
95
96 #ifndef __osf__
97 #undef stdin
98 #undef stdout
99 #undef stderr
100 #endif
101 #undef printf
102 #undef putchar
103 #undef getchar
104
105
106 /*******************************
107 * SOME SYSTEM STUFF *
108 *******************************/
109
110 #ifdef SYSLIB_H
111 #include SYSLIB_H
112 #endif
113
114 /********************************
115 * LIMITS *
116 ********************************/
117
118 #define PCE_MAX_RECURSION 1000 /* maximum send() recursion */
119 #define METHOD_MAX_ARGS 16 /* maximum # args for C-method */
120 #define FWD_PCE_MAX_ARGS 10 /* @arg1 ... @arg10 */
121 #define SCAN_MAX_ARGS 32 /* scanstr maximum arguments */
122 #define PCE_MAX_INT ((intptr_t)(((intptr_t)1<<(sizeof(Any)*8 - TAG_BITS-1))-1))
123 #define PCE_MIN_INT (-(PCE_MAX_INT-1))
124 #ifndef INT_MAX
125 #define INT_MAX ((int)(((unsigned int)1<<(sizeof(int)*8-1))-1))
126 #define INT_MIN (-(INT_MIN)-1)
127 #endif
128
129 #define LINESIZE 2048 /* maximum length of a line */
130 #define FORMATSIZE 10000 /* maximum length of a ->format */
131 #define BROWSER_LINE_WIDTH 256 /* maximum #chars of line in browser */
132
133 /********************************
134 * OS STUFF *
135 ********************************/
136
137 #ifndef SIGNAL_HANDLER_TYPE /* type returned by signal-handler */
138 #define SIGNAL_HANDLER_TYPE void
139 #endif
140
141 /*******************************
142 * CLEANUP *
143 *******************************/
144
145 #define ATEXIT_FILO 0x1
146 #define ATEXIT_FIFO 0x2
147
148 typedef void (*atexit_function)(int status);
149
150 /*******************************
151 * VARARG FUNCTIONS *
152 *******************************/
153
154 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
155 Handling of send(Receiver, Method, ..., EAV), etc. Note that EAV cannot
156 be just 0, as on some machines int and pointers are promoted to
157 different types when passed to a vararg function.
158 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
159
160 #define VA_PCE_MAX_ARGS 10 /* send(), etc. */
161 #define EAV ((Any)0) /* End of the list */
162
163
164 /********************************
165 * SAVING OBJECTS *
166 ********************************/
167
168 #define SAVEMAGIC "PCE version 4"
169 #define SAVEVERSION 18 /* last increment for 5.6.14 */
170
171 /********************************
172 * ASSERTS *
173 ********************************/
174
175 #undef assert
176 #ifdef NOASSERT
177 #define assert(expr) ((void)0)
178 #else
179 #define assert(expr) ((expr) ? (void)0 : \
180 (void)pceAssert(0,#expr,__FILE__,__LINE__))
181 #endif
182
183 /********************************
184 * COMPILER STUFF *
185 ********************************/
186
187 #if __STRICT_ANSI__
188 #undef TAGGED_LVALUE
189 #endif
190
191 #ifdef __GNUC__
192 # if !__STRICT_ANSI__ /* gcc -ansi */
193 # ifndef O_INLINE
194 # define O_INLINE 1
195 # endif
196 # define O_CONST_FUNCTION 1
197 # endif
198 # define Promote(type) int
199 #else
200 # define Promote(type) type
201 #endif
202
203 #ifdef HAVE_VISIBILITY_ATTRIBUTE
204 #define SO_LOCAL __attribute__((visibility("hidden")))
205 #else
206 #define SO_LOCAL
207 #endif
208
209 #if !O_INLINE
210 #define inline
211 #endif
212
213 #ifdef __GNUC__
214 #define PURE_FUNCTION __attribute__((pure))
215 #else
216 #define PURE_FUNCTION
217 #endif
218
219 #define forwards static /* Local functions */
220
221 #if __GNUC__ && !__STRICT_ANSI__
222 #define LocalArray(t, n, s) t n[s]
223 #else
224 #define LocalArray(t, n, s) t *n = (t *) alloca((s)*sizeof(t))
225 #endif
226
227 #define ArgVector(name, s) LocalArray(Any, name, s)
228 #define CharBuf(name, s) LocalArray(unsigned char, name, (s)+1)
229
230 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
231 cpdata(to, from, type, n)
232 copies n objects of type type from `from' to `to'. Does not deal with
233 overlapping, but is much faster on relatively small data pieces then
234 memcpy(to, from, (n)*sizeof(type)), to which it is equivalent.
235 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
236
237 #if 1
238 #define cpdata(to, from, type, n) memcpy(to, from, (n)*sizeof(type))
239 #else
240 #define cpdata(to, from, type, n) do \
241 { type *_t = (type*)(to)-1; \
242 type *_f = (type*)(from)-1; \
243 int _i = (n); \
244 while(--_i >= 0) *++_t = *++_f; \
245 } while(0)
246 #endif
247 #define setdata(to, val, type, n) do \
248 { type *_t = (to)-1; \
249 int _i = (n); \
250 type _v = (val); \
251 while(--_i >= 0) *++_t = _v; \
252 } while(0)
253
254 #define NOTREACHED assert(0) /* should not get here */
255
256 #ifdef O_EXTRA_SYSTEM_TYPES
257 #include O_EXTRA_SYSTEM_TYPES
258 #endif
259
260 /*******************************
261 * OS-IDENTIFIERS (STRICT_ANSI) *
262 *******************************/
263
264 #ifndef __unix__
265 #if defined(_AIX) || defined(__APPLE__) || defined(__unix) || defined(__BEOS__) || defined(__NetBSD__)
266 #define __unix__ 1
267 #endif
268 #endif
269
270 #if defined(__unix__) && !defined(unix)
271 #define unix 1
272 #endif
273
274 /*******************************
275 * LIBRARY PROBLEMS *
276 *******************************/
277
278 #ifndef StrTod
279 #define StrTod(s, e) strtod(s, e)
280 #endif
281
282 /********************************
283 * NAME CONFLICTS *
284 ********************************/
285
286 #define CtoInt(i) toInt(i) /* int --> Int */
287 #define CtoName(s) (Name)cToPceName((s)) /* const char * --> Name */
288 #define CtoType(s) nameToType(CtoName(s)) /* char * --> type object */
289 #define WCtoType(s) nameToType(WCToName(s, -1)) /* wchar_t * --> type object */
290 #define pp(x) pcePP((Any)(x)) /* interface name */
291 #define get getPCE /* avoid common name-conflict */
292 #define send sendPCE /* same */
293 #define toString toStringPCE /* SWI-Prolog name-conflict */
294 #define valReal valPceReal /* and another */
295
296 #undef hyper
297
298 /*******************************
299 * BASIC TYPES *
300 *******************************/
301
302 typedef int status; /* FAIL, SUCCEED */
303 typedef void * Any; /* Arbitrary object */
304
305 typedef Any Int; /* ZERO, ONE, ... */
306 typedef Any (*Func)(); /* Absolete GetFunc (TBD) */
307 typedef Any (*GetFunc)(); /* GetMethod implementation */
308 typedef status (*SendFunc)(); /* SendMethod implementation */
309 typedef void (*VoidFunc)();
310
311 typedef void * WsRef; /* Window-system reference */
312 typedef struct xref * Xref; /* Entry in ws-table */
313
314 typedef struct classdef *ClassDef; /* See pce-save.c */
315 typedef struct dCell **DelegateList; /* See msg-passing.c */
316
317 #include "types.h"
318
319 #define INVOKE_FUNC ((SendFunc)~0L)
320
321 /********************************
322 * POINTERS *
323 ********************************/
324
325 #ifdef VARIABLE_POINTER_OFFSET
326 #undef POINTER_OFFSET
327 GLOBAL uintptr_t pce_data_pointer_offset;
328 #define POINTER_OFFSET pce_data_pointer_offset
329 #else
330 #ifndef POINTER_OFFSET
331 #define POINTER_OFFSET (0L)
332 #endif
333 #endif
334
335 #define PointerToCInt(p) (((uintptr_t)(p) - POINTER_OFFSET)/sizeof(void*))
336 #define PointerToInt(p) toInt(PointerToCInt(p))
337 #define longToPointer(i) ((Any) (i * sizeof(void*) + POINTER_OFFSET))
338 #define IntToPointer(i) longToPointer(valInt(i))
339
340
341 /********************************
342 * TAG MASKS *
343 ********************************/
344
345 #define INT_MASK 0x00000001 /* 10 mask for Int (integers) */
346 #define MASK_MASK 0x00000001 /* 11 Mask Mask */
347 #define TAG_BITS 1 /* number of mask bits for INT */
348
349 #define MaskOf(obj) ((uintptr_t)(obj) & MASK_MASK)
350 #define UnMask(obj) ((uintptr_t)(obj) & ~MASK_MASK)
351
352
353 /********************************
354 * EQUALITY *
355 ********************************/
356
357 #define EQI(o1, o2) ((Any)(o1) == (Any)(o2))
358 #define EQ(o1, o2) EQI(o1, o2)
359
360
361 /********************************
362 * TYPES *
363 ********************************/
364
365 #define ARGC_UNKNOWN (-1)
366 #define ARGC_INHERIT (-2) /* classdecl */
367
368 /********************************
369 * FUNCTIONS *
370 ********************************/
371
372 #define isFunction(obj) (isObject(obj) && onFlag(obj, F_ACTIVE))
373 #define isHostData(obj) (isObject(obj) && onFlag(obj, F_ISHOSTDATA))
374
375
376 /********************************
377 * PCE INTEGERS *
378 ********************************/
379
380 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
381 PCE uses tagged integers rather than C integers. The top TAG_BITS bits
382 hold the MASK whereas the remaining bits hold the integer itself. A PCE
383 integer is declared as of type Int (for casting purposes). The following
384 test, conversion and computation macro's are provided.
385 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
386
387 /* TBD: INTPTR_FORMAT is available as PRTdPTR from <inttypes.h>. Our
388 include for fixed size integers is a bit flaky on various platforms
389 though
390 */
391
392 #ifndef INTPTR_FORMAT /* printf format for intptr_t */
393 #if SIZEOF_INT == SIZEOF_VOIDP
394 #define INTPTR_FORMAT "%d"
395 #elif SIZEOF_LONG == SIZEOF_VOIDP
396 #define INTPTR_FORMAT "%ld"
397 #elif defined(__WIN64)
398 #define INTPTR_FORMAT "%I64d"
399 #else
400 #error "Config needs INTPTR_FORMAT"
401 #endif
402 #endif
403
404 #undef max
405 #undef min
406 #define max(a, b) ((a) > (b) ? (a) : (b))
407 #define min(a, b) ((a) < (b) ? (a) : (b))
408
409 #define isInteger(i) ((uintptr_t)(i) & INT_MASK)
410 #define toInt(i) ((Int)(((uintptr_t)(i)<<TAG_BITS)|INT_MASK))
411 #define valInt(i) (((intptr_t)(i))>>TAG_BITS)
412 #define incrInt(i) ((i) = toInt(valInt(i)+1))
413 #define decrInt(i) ((i) = toInt(valInt(i)-1))
414 #define addInt(i, j) ((i) = toInt(valInt(i) + valInt(j)))
415 #define subInt(i, j) ((i) = toInt(valInt(i) - valInt(j)))
416 #define maxInt(i, j) toInt(max(valInt(i), valInt(j)))
417 #define absInt(i) (valInt(i) < 0 ? neg(i) : i)
418
419 #undef div
420 #define neg(i) (toInt(-valInt(i)))
421 #define add(i, j) (toInt(valInt(i) + valInt(j)))
422 #define sub(i, j) (toInt(valInt(i) - valInt(j)))
423 #define div(i, j) (toInt(valInt(i) / valInt(j)))
424 #define mul(i, j) (toInt(valInt(i) * valInt(j)))
425 #define avg(i, j) (toInt((valInt(i) + valInt(j))/2))
426 #define mid(i, j) (toInt((valInt(i) + valInt(j)/2)))
427 #define dif(i, j) (toInt((valInt(i) - valInt(j)/2)))
428 #define inc(i) (toInt(valInt(i) + 1))
429 #define dec(i) (toInt(valInt(i) - 1))
430 #define minInt(i) (toInt(-valInt(i)))
431
432 #define ZERO toInt(0) /* PCE Int 0 */
433 #define ONE toInt(1) /* PCE Int 1 */
434 #define TWO toInt(2) /* PCE Int 2 */
435
436
437 /********************************
438 * DFLAG VALUES *
439 ********************************/
440
441
442 #define makeDFlag(n) (1L << ((n) - 1 + TAG_BITS))
443 #define DFlags(obj) (((ProgramObject)(obj))->dflags)
444 #ifndef TAGGED_LVALUE
445 #define setDFlag(obj, mask) setDFlagProgramObject((obj), (mask))
446 #define clearDFlag(obj, mask) clearDFlagProgramObject((obj), (mask))
447 #else
448 #define setDFlag(obj, mask) (DFlags(obj) |= (mask))
449 #define clearDFlag(obj, mask) (DFlags(obj) &= ~(mask))
450 #endif
451 #define onDFlag(obj, mask) (DFlags(obj) & (mask))
452 #define offDFlag(obj, mask) (!onDFlag(obj, mask))
453
454 /* Debugging flags */
455 #define D_TRACE_ENTER makeDFlag(1) /* Trace enter port of method */
456 #define D_TRACE_EXIT makeDFlag(2) /* Trace exit port of method */
457 #define D_TRACE_FAIL makeDFlag(3) /* Trace fail port of method */
458 #define D_TRACE (D_TRACE_ENTER|D_TRACE_EXIT|D_TRACE_FAIL)
459
460 #define D_BREAK_ENTER makeDFlag(4) /* Break enter port of method */
461 #define D_BREAK_EXIT makeDFlag(5) /* Break exit port of method */
462 #define D_BREAK_FAIL makeDFlag(6) /* Break fail port of method */
463 #define D_BREAK (D_BREAK_ENTER|D_BREAK_EXIT|D_BREAK_FAIL)
464
465 #define D_SYSTEM makeDFlag(7) /* Generate system trace frame */
466
467 /* Variable attributes */
468 #define D_SAVE_NORMAL makeDFlag(8) /* Save normally */
469 #define D_SAVE_NIL makeDFlag(9) /* Save as NIL */
470 #define D_SAVE (D_SAVE_NORMAL|D_SAVE_NIL)
471
472 #define D_CLONE_RECURSIVE makeDFlag(10) /* Clone object recursively */
473 #define D_CLONE_REFERENCE makeDFlag(11) /* Clone object reference */
474 #define D_CLONE_NIL makeDFlag(12) /* Cloned value is @nil */
475 #define D_CLONE_VALUE makeDFlag(13) /* Clone the plain PCE value */
476 #define D_CLONE_ALIEN makeDFlag(14) /* Clone alien values */
477 #define D_CLONE_REFCHAIN makeDFlag(15) /* Value is a reference chain */
478 #define D_CLONE (D_CLONE_RECURSIVE|D_CLONE_REFERENCE|\
479 D_CLONE_NIL|D_CLONE_VALUE|D_CLONE_ALIEN|\
480 D_CLONE_REFCHAIN)
481
482 #define D_ALIEN makeDFlag(16) /* Variable is alien */
483 #define D_TYPENOWARN makeDFlag(17) /* Methods: donot warn */
484
485 /* Class attributes */
486 #define DC_LAZY_GET makeDFlag(18) /* bind get-behaviour lazy */
487 #define DC_LAZY_SEND makeDFlag(19) /* bind send-behaviour lazy */
488 #define D_CXX makeDFlag(20) /* C++ defined method/class */
489
490 /* ClassVariable attributes */
491 #define DCV_TEXTUAL makeDFlag(21) /* Default is textual */
492
493 /* Method */
494 #define D_HOSTMETHOD makeDFlag(22) /* Implementation is in the host */
495 #define D_SERVICE makeDFlag(23) /* Execute in `service' mode */
496
497
498 /********************************
499 * CHAR_ARRAY, STRING *
500 ********************************/
501
502 #include "str.h" /* string type and friends */
503 #include "../txt/proto.h" /* prototypes */
504
505 #define LocalString(name, iswide, size) \
506 string _s_ ## name ## _hdr; \
507 void *_s_ ## name ## _buf = (void *)alloca(iswide ? (size) * sizeof(charW) \
508 : (size) * sizeof(charA)); \
509 PceString name = fstr_inithdr(&_s_ ## name ## _hdr, iswide, _s_ ## name ## _buf, size)
510
511 /********************************
512 * OBJECT HEADER *
513 ********************************/
514
515 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
516 [q]assign(obj, slot, value)
517 assign() assigns a slot a value, qassign() does the same, but bypasses
518 the object management system. It should be used in very time-critical
519 code where the value is constant (Int, Name, Constant). Nowhere else!
520 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
521
522 #define assign(o, s, v) assignField((Instance) (o), \
523 (Any *) &((o)->s), \
524 (Any) (v))
525 #define qassign(o, s, v) ((o)->s = (v))
526
527 #define makeFlag(n) (1L << ((n) - 1))
528 #define setFlag(obj, mask) (((Instance)(obj))->flags |= (mask))
529 #define clearFlag(obj, mask) (((Instance)(obj))->flags &= ~(mask))
530 #define onFlag(obj, mask) (((Instance)(obj))->flags & (mask))
531 #define offFlag(obj, mask) (!onFlag(obj, mask))
532
533 #define F_LOCKED makeFlag(1)
534 #define F_CREATING makeFlag(2)
535 #define F_FREED makeFlag(3)
536 #define F_FREEING makeFlag(4)
537 #define F_PROTECTED makeFlag(5)
538 #define F_ANSWER makeFlag(6)
539 #define F_INSPECT makeFlag(7)
540 #define F_ACTIVE makeFlag(8) /* Active object */
541 #define F_CONSTRAINT makeFlag(9) /* has constraints */
542 #define F_ATTRIBUTE makeFlag(10) /* has attributes */
543 #define F_SENDMETHOD makeFlag(11) /* has send-methods */
544 #define F_GETMETHOD makeFlag(12) /* has get-methods */
545 #define F_HYPER makeFlag(13) /* has hypers */
546 #define F_RECOGNISER makeFlag(14) /* has recognisers */
547 #define F_ASSOC makeFlag(15) /* has name-assoc */
548 #define F_ITFNAME makeFlag(16) /* Name known to itf table */
549 #define F_SOLID makeFlag(17) /* Solid graphical object */
550 #define F_OBTAIN_CLASSVARS makeFlag(18) /* obtainClassVariablesObject() */
551 #define F_TEMPLATE_METHOD makeFlag(19) /* method<-instantiate_template */
552 #define F_ISBINDING makeFlag(20) /* instanceOf(x, ClassBinding) */
553 #define F_ISNAME makeFlag(21) /* instanceOf(x, ClassName) */
554 #define F_ISREAL makeFlag(22) /* instanceOf(x, ClassReal) */
555 #define F_ISHOSTDATA makeFlag(23) /* instanceOf(x, ClassHostData) */
556 #define F_NOTANY makeFlag(24) /* Not acceptable to any/object */
557
558 #define OBJ_MAGIC ((uintptr_t)0x14 << 25)
559 #define OBJ_MAGIC_MASK ((uintptr_t)0x7e << 25)
560
561 #define hasObjectMagic(obj) ((((Instance)(obj))->flags&OBJ_MAGIC_MASK) == \
562 OBJ_MAGIC)
563
564 #define initHeaderObj(obj, cl) \
565 { (obj)->class = (cl); \
566 (obj)->flags = F_CREATING|OBJ_MAGIC; \
567 (obj)->references = 0L; \
568 }
569
570 #define classOfObject(obj) (((Instance)(obj))->class)
571
572 #define setProtectedObj(obj) setFlag(obj, F_PROTECTED)
573 #define clearProtectedObj(obj) clearFlag(obj, F_PROTECTED)
574 #define isProtectedObj(obj) onFlag(obj, F_PROTECTED)
575 #define setCreatingObj(obj) setFlag(obj, F_CREATING)
576 #define clearCreatingObj(obj) clearFlag(obj, F_CREATING)
577 #define isCreatingObj(obj) onFlag(obj, F_CREATING)
578 #define setAnswerObj(obj) setFlag(obj, F_ANSWER)
579 #define clearAnswerObj(obj) clearFlag(obj, F_ANSWER)
580 #define isAnswerObj(obj) onFlag(obj, F_ANSWER)
581
582 #define ONE_CODE_REF (1L<<20)
583
584 #define refsObject(obj) (((Instance)obj)->references % ONE_CODE_REF)
585 #define codeRefsObject(obj) (((Instance)obj)->references / ONE_CODE_REF)
586 #define noRefsObj(obj) (((Instance)obj)->references == 0L)
587 #define addRefObj(obj) (((Instance)obj)->references++)
588 #define delRefObj(obj) (((Instance)obj)->references--)
589 #define lockObj(obj) setFlag(obj, F_LOCKED)
590 #define unlockObj(obj) clearFlag(obj, F_LOCKED)
591 #define lockedObj(obj) onFlag(obj, F_LOCKED)
592 #define setFreedObj(obj) setFlag(obj, F_FREED)
593 #define isFreedObj(obj) onFlag(obj, F_FREED)
594 #define setFreeingObj(obj) setFlag(obj, F_FREEING)
595 #define isFreeingObj(obj) onFlag(obj, F_FREEING)
596 #define isVirginObj(o) (noRefsObj(o) && \
597 !onFlag(o, F_LOCKED|F_PROTECTED|F_ANSWER))
598 #define freeableObj(o) if ( isVirginObj(o) ) \
599 freeObject(o)
600 #define checkDeferredUnalloc(o) if ( (((Instance)o)->references) <= 0 ) \
601 unreferencedObject(o)
602
603 #define GcProtect(o, g) do { \
604 addCodeReference(o); \
605 g; \
606 delCodeReference(o); } while(0)
607
608
609
610 /********************************
611 * CONSTANTS *
612 ********************************/
613
614 #define NIL ((Any)(&ConstantNil))
615 #define DEFAULT ((Any)(&ConstantDefault))
616 #define CLASSDEFAULT ((Any)(&ConstantClassDefault))
617 #define ON (&BoolOn)
618 #define OFF (&BoolOff)
619
620 #define isOn(val) ((BoolObj)(val) == ON)
621 #define isOff(val) ((BoolObj)(val) == OFF)
622 #define isBoolean(val) ((BoolObj)(val) == ON || (BoolObj)(val) == OFF)
623
624 #define isNil(o) ((Constant)(o) == NIL)
625 #define notNil(o) ((Constant)(o) != NIL)
626 #define isDefault(o) ((Constant)(o) == DEFAULT)
627 #define notDefault(o) ((Constant)(o) != DEFAULT)
628 #define isClassDefault(o) ((Constant)(o) == CLASSDEFAULT)
629 #define notClassDefault(o) ((Constant)(o) != CLASSDEFAULT)
630
631 #define TrueOrFalse(b) (isOn(b) ? TRUE : FALSE)
632
633 #define nonObject(obj) (MaskOf(obj) || !(obj))
634 #define isObject(obj) (!nonObject(obj))
635
636 /********************************
637 * CAREFUL CHECKERS *
638 ********************************/
639
640 #define validAddress(a) ((uintptr_t)(a) >= allocBase && \
641 (uintptr_t)(a) < allocTop)
642 #define isAddress(a) (validAddress(a) && \
643 !((uintptr_t)(a) & (sizeof(Any)-1)))
644 #define validPceDatum(x) (isInteger(x) || isProperObject(x))
645
646
647 #ifndef TRUE
648 #define TRUE 1 /* boolean truth value */
649 #define FALSE 0 /* boolean false value */
650 #endif
651
652 #define FAIL 0 /* message failed */
653 #define SUCCEED 1 /* message completed successful */
654
655 #define fail return FAIL
656 #define succeed return SUCCEED
657 #define answer(v) return (v)
658
659 #define DONE(goal) if ( (goal) ) succeed
660 #define TRY(goal) if ( !(goal) ) fail
661 #define EXISTS(object) if ( isNil(object) ) fail
662
663
664 /********************************
665 * CLASS STRUCTURES *
666 ********************************/
667
668 #define OBJECT_HEADER \
669 uintptr_t flags; /* general flag field */ \
670 uintptr_t references; /* reference count */ \
671 Class class; /* Associated class */
672
673 #define ABSTRACT_OBJECT
674
675 #define ABSTRACT_PROGRAM_OBJECT \
676 uintptr_t dflags; /* Debugging flags */
677
678 #define ABSTRACT_RECOGNISER \
679 BoolObj active; /* Does accept events? */
680
681 #define ABSTRACT_CODE \
682 ABSTRACT_PROGRAM_OBJECT
683
684 #define ABSTRACT_FUNCTION \
685 ABSTRACT_CODE
686
687 #define ABSTRACT_BINARY_EXPRESSION \
688 ABSTRACT_FUNCTION \
689 Expression left; /* Left-hand side */ \
690 Expression right; /* Right-hand side */
691
692 #define ABSTRACT_BINARY_CONDITION \
693 ABSTRACT_CODE \
694 Expression left; /* Left-hand side */ \
695 Expression right; /* Right-hand side */
696
697 #define ABSTRACT_VISUAL
698
699 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
700 NewClass(class) privides the structure header for any class that is a
701 subclass of class `object'.
702 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
703
704 #define NewClass(x) \
705 struct x \
706 { OBJECT_HEADER \
707 ABSTRACT_OBJECT
708 #define End \
709 }
710
711 struct instance
712 { OBJECT_HEADER /* non-pce header */
713 Any slots[1]; /* array of slots. */
714 };
715
716 NewClass(object)
717 End;
718
719 NewClass(program_object)
720 ABSTRACT_PROGRAM_OBJECT
721 End;
722
723 NewClass(vmi)
724 ABSTRACT_PROGRAM_OBJECT
725 Name name; /* Name of vmi */
726 End;
727
728 NewClass(c_pointer)
729 void * pointer; /* the pointer value */
730 End;
731
732 NewClass(area)
733 Int x; /* position and dimension */
734 Int y;
735 Int w;
736 Int h;
737 End;
738
739 NewClass(atable)
740 Vector keys; /* bool vector stating key fields */
741 Vector names; /* parameter names of the entries */
742 Vector tables; /* hash tables */
743 End;
744
745 NewClass(tuple)
746 Any first; /* first of tuple */
747 Any second; /* second element of tuple */
748 End;
749
750 #define ABSTRACT_BEHAVIOUR \
751 ABSTRACT_PROGRAM_OBJECT \
752 Name name; /* Name of the behaviour */ \
753 Any context; /* Object or class I belong too */
754
755 #define ABSTRACT_VARIABLE \
756 ABSTRACT_BEHAVIOUR \
757 Name group; /* Conceptual group */ \
758 Name access; /* whether send/get may be used */ \
759 Type type; /* type of contents */ \
760 Int offset; /* offset from base (from 0) */ \
761 StringObj summary; /* Summary for variable */ \
762 Any init_function; /* Function to initialise */ \
763 Any alloc_value; /* Allocate value of variable */
764
765 #ifndef O_RUNTIME
766 #define ABSTRACT_METHOD \
767 ABSTRACT_BEHAVIOUR \
768 Name group; /* Conceptual group */ \
769 Vector types; /* type checking codes */ \
770 StringObj summary; /* Summary of this method */ \
771 SourceLocation source; /* Location of def in sources */ \
772 Code message; /* message implementing method */
773
774 #else /*O_RUNTIME*/
775
776 #define ABSTRACT_METHOD \
777 ABSTRACT_BEHAVIOUR \
778 Name group; /* Conceptual group */ \
779 Vector types; /* type checking codes */ \
780 StringObj summary; /* Summary of this method */ \
781 Code message; /* message implementing method */
782 #endif/*O_RUNTIME*/
783
784 NewClass(behaviour)
785 ABSTRACT_BEHAVIOUR
786 End;
787
788 NewClass(method)
789 ABSTRACT_METHOD
790 Func function; /* C-function implementing method */
791 End;
792
793 NewClass(send_method)
794 ABSTRACT_METHOD
795 SendFunc function; /* C-function implementing method */
796 End;
797
798 NewClass(get_method)
799 ABSTRACT_METHOD
800 GetFunc function; /* C-function implementing method */
801 Type return_type; /* Type of returned value */
802 End;
803
804 NewClass(variable)
805 ABSTRACT_VARIABLE
806 End;
807
808 NewClass(attribute)
809 ABSTRACT_PROGRAM_OBJECT
810 Any name; /* name of the attribute */
811 Any value; /* value for the attribute */
812 End;
813
814 NewClass(class_variable)
815 ABSTRACT_BEHAVIOUR
816 Type type; /* Type of this variable */
817 Any value; /* Value of the variable */
818 Any cv_default; /* Default value */
819 StringObj summary; /* Short documentation */
820 End;
821
822 NewClass(binding)
823 Name name; /* name of the binding */
824 Any value; /* Value of the binding */
825 End;
826
827 NewClass(error)
828 Name id; /* Id of the error */
829 Name format; /* Format of the error message */
830 Name kind; /* {message,warning,error} */
831 Name feedback; /* {inform,print} */
832 End;
833
834 NewClass(chain)
835 Int size; /* # elements in the chain */
836 Cell head; /* first element */
837 Cell tail; /* last element */
838 Cell current; /* current element */
839 End;
840
841 typedef struct instance_proto *InstanceProto;
842
843 struct instance_proto
844 { int size; /* Size of the prototype (bytes) */
845 struct object proto; /* the proto itself */
846 };
847
848 /*******************************
849 * CLASS AND LAZY STUFF *
850 *******************************/
851
852 typedef struct _vardecl
853 { Name name; /* name of the instance var */
854 char *type; /* type */
855 int flags; /* IV_<flag> bitwise or */
856 void *context; /* wrapper or function ptr */
857 Name group; /* group identifier */
858 char *summary; /* documentation summary */
859 } vardecl;
860
861 typedef struct _senddecl
862 { Name name; /* name of the method */
863 int arity; /* arity thereof */
864 void *types; /* type or type-vector */
865 SendFunc function; /* implementation */
866 Name group; /* group id */
867 char *summary; /* documentation summary */
868 } senddecl;
869
870 typedef struct _getdecl
871 { Name name; /* name of the method */
872 int arity; /* arity thereof */
873 char *rtype; /* return type */
874 void *types; /* type or type-vector */
875 GetFunc function; /* implementation */
876 Name group; /* group id */
877 char *summary; /* documentation summary */
878 } getdecl;
879
880 typedef struct _classvardecl
881 { Name name; /* Name of the class-variable */
882 char *type; /* type description */
883 char *value; /* (default) value */
884 char *summary; /* documentation summary */
885 } classvardecl;
886
887 typedef struct _classdecl
888 { vardecl *variables; /* Instance variables */
889 senddecl *send_methods; /* Send methods of class */
890 getdecl *get_methods; /* get methods of class */
891 classvardecl *class_variables; /* Variables of the class */
892 int nvar; /* number of entries in tables */
893 int nsend;
894 int nget;
895 int nclassvars;
896 int term_arity; /* Arity of term description */
897 Name *term_names; /* Array of term-names */
898 char *source_file; /* Name of the source-file */
899 char *rcs_revision; /* RCS version info */
900 } classdecl;
901
902 #define ClassDecl(name, vs, ss, gs, rs, ta, tn, rcs) \
903 static classdecl name = \
904 { vs, ss, gs, rs, \
905 IVEntries(vs), SMEntries(ss), GMEntries(gs), RCEntries(rs), \
906 ta, tn, __FILE__, rcs \
907 }
908
909 /* Dont change IV_GET and IV_SEND */
910 #define IV_NONE 0x00 /* No access, nothing */
911 #define IV_GET 0x01 /* instance var get-access */
912 #define IV_SEND 0x02 /* instance var send-access */
913 #define IV_BOTH (IV_GET|IV_SEND) /* convenience */
914 #define IV_SUPER 0x04 /* delegation variable */
915 #define IV_STORE 0x08 /* has store method */
916 #define IV_FETCH 0x10 /* has fetch method */
917 #define IV_REDEFINE 0x20 /* redefine existing variable */
918
919 #define RC_REFINE (char *)(-1) /* refinement of class-variable */
920
921 #define SM(n, a, t, f, g, s) { n, a, t, (SendFunc) f, (Name) g, s }
922 #define GM(n, a, r, t, f, g, s) { n, a, r, t, (GetFunc) f, (Name) g, s }
923 #define RC(n, t, d, s) { n, t, d, s }
924 #define IV(n, t, f, g, s) { n, t, f, NULL, (Name) g, s }
925 #define SV(n, t, f, c, g, s) { n, t, f, (void *)(c), (Name) g, s }
926 #define IVEntries(l) (sizeof(l) / sizeof(vardecl))
927 #define SMEntries(l) (sizeof(l) / sizeof(senddecl))
928 #define GMEntries(l) (sizeof(l) / sizeof(getdecl))
929 #define RCEntries(l) (sizeof(l) / sizeof(classvardecl))
930 #define TNEntries(l) (sizeof(l) / sizeof(Name))
931
932 #ifndef UXWIN
933 #ifdef WIN32_GRAPHICS
934 #define UXWIN(unx, win) win
935 #else
936 #define UXWIN(unx, win) unx
937 #endif
938 #endif
939
940 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
941 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
942
943 If you add/delete slots, do not forget to change PCE_CLASS_SLOTS in
944 pce-class.c
945 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
946
947 NewClass(class)
948 ABSTRACT_PROGRAM_OBJECT \
949 Name name; /* (2) name for this class */ \
950 StringObj summary; /* Summary of the class */ \
951 Name creator; /* Created from where? */ \
952 Class super_class; /* (abstract) super-class */ \
953 Chain sub_classes; /* list of sub-classes */
954 Vector instance_variables; /* (7) local variables */
955 Chain send_methods; /* send methods for this class */
956 Chain get_methods; /* get methods for this class */
957 Vector term_names; /* get method to obtain arguments */
958 Chain delegate; /* variables I delegate to */
959 Chain class_variables; /* Class variables of this class */
960 Name cloneStyle; /* style of clone method */
961 Name saveStyle; /* special save method */
962 Sheet features; /* installed features */
963 Int no_created; /* how many were created */
964 Int no_freed; /* how many were freed */
965 BoolObj solid; /* graphicals: OFF by default */
966 Name selection_style; /* graphicals: feedback selected */
967 Chain handles; /* graphicals only: connection pts */
968 Int instance_size; /* Instance size in bytes */
969 Int slots; /* # instance variables */
970 SourceLocation source; /* Source location */
971 Name rcs_revision; /* Current rcs-revision of source */
972 Chain changed_messages; /* Trap instance changes */
973 Chain created_messages; /* Trap instance creation */
974 Chain freed_messages; /* Trap instance destruction */
975 BoolObj un_answer; /* Decide on slot assignment */
976
977 Code make_class_message; /* Message to build the class */
978
979 SendMethod initialise_method; /* Initialise instance */
980 SendMethod send_catch_all; /* Catch failed sends */
981 GetMethod get_catch_all; /* Catch failed gets */
982 GetMethod convert_method; /* Convert to this type */
983 GetMethod lookup_method; /* Reusable object-lookup */
984
985 Code resolve_method_message; /* Lazy definition of methods */
986
987 HashTable send_table; /* hash-table of send methods */
988 HashTable get_table; /* hash-table of get methods */
989 HashTable local_table; /* hash-table of instance variables */
990 HashTable class_variable_table; /* hash-table of class-variables */
991 HashTable instances; /* hash-table holding the instances */
992
993 BoolObj realised; /* Class has been realised? */
994 Name init_variables; /* How to initialise slots */
995
996 InstanceProto proto; /* Prototype instance */
997 intptr_t tree_index; /* Index in depth-first tree */
998 intptr_t neighbour_index; /* Index of my neighbour */
999
1000 GetFunc get_function; /* `Get' on Code objects */
1001 SendFunc send_function; /* `Send' on Code objects */
1002 SendFunc saveFunction; /* function handling saveFile */
1003 SendFunc loadFunction; /* function handling loadFile */
1004 SendFunc cloneFunction; /* function to clone object */
1005 SendFunc redrawFunction; /* redraw a graphical */
1006 SendFunc changedFunction; /* Trap instance changes */
1007 SendFunc in_event_area_function; /* Test if event is in area */
1008 SendFunc make_class_function; /* makeClass function pointer */
1009 intptr_t boot; /* When booting: #pce-slots; else 0 */
1010
1011 classdecl *c_declarations; /* Non-object declarations */
1012 End;
1013
1014 NewClass(type)
1015 ABSTRACT_PROGRAM_OBJECT
1016 Name kind; /* Kind of type */
1017 Name fullname; /* Logical name of the type */
1018 Name argument_name; /* Name of the argument */
1019 Chain supers; /* Super-types */
1020 Any context; /* Context argument for functions */
1021 BoolObj vector; /* Method: vector of these */
1022 intptr_t validate_function; /* Function to check the type */
1023 Func translate_function; /* Function to convert the type */
1024 End;
1025
1026 NewClass(constraint)
1027 Any from; /* 'From' object of constraint */
1028 Any to; /* 'To' object of constraint */
1029 Relation relation; /* relation they have */
1030 Name locked; /* locked fro further messages? */
1031 End;
1032
1033 NewClass(date)
1034 union
1035 { intptr_t date; /* Unix view of time */
1036 Any slot; /* dummy */
1037 } date;
1038 End;
1039
1040 NewClass(dict)
1041 Any browser; /* browser showing contents */
1042 Chain members; /* list of dict_items */
1043 HashTable table; /* hash table for associative lookup */
1044 Code sort_by; /* Sort cirterium */
1045 End;
1046
1047 NewClass(dictitem)
1048 ABSTRACT_VISUAL
1049 Any key; /* key (often same as label) */
1050 CharArray label; /* label displayed in browser */
1051 Any object; /* associated object (often a sheet) */
1052 Name style; /* Display style */
1053 Int index; /* index number (0 upwards) */
1054 Dict dict; /* dict object in which item resides */
1055 End;
1056
1057 NewClass(divide)
1058 ABSTRACT_BINARY_EXPRESSION
1059 End;
1060
1061 NewClass(equation)
1062 ABSTRACT_BINARY_CONDITION
1063 End;
1064
1065 NewClass(binary_expression)
1066 ABSTRACT_BINARY_EXPRESSION
1067 End;
1068
1069 NewClass(binary_condition)
1070 ABSTRACT_BINARY_CONDITION
1071 End;
1072
1073 NewClass(handle)
1074 Expression xPosition; /* X position of handle */
1075 Expression yPosition; /* Y position of handle */
1076 Name kind; /* Kind of handle */
1077 Name name; /* Logical nam of connection */
1078 End;
1079
1080 NewClass(modifier)
1081 Name shift; /* {up,down,@default} */
1082 Name control; /* {up,down,@default} */
1083 Name meta; /* {up,down,@default} */
1084 End;
1085
1086
1087 #define ABSTRACT_GESTURE \
1088 ABSTRACT_RECOGNISER \
1089 Name button; /* {left,middle,right} */ \
1090 Modifier modifier; /* shift-control-meta */ \
1091 Code condition; /* Additional conditions */ \
1092 Name status; /* {inactive, ...} */ \
1093 Any cursor; /* Cursor while acitive */ \
1094 Name drag_scroll; /* Scroll when dragging out */ \
1095 Timer drag_scroll_timer; /* Associated timer */ \
1096 EventObj drag_scroll_event; /* Last event for drag-scroll */
1097
1098 NewClass(gesture)
1099 ABSTRACT_GESTURE
1100 End;
1101
1102 NewClass(handler)
1103 ABSTRACT_RECOGNISER
1104 Name event; /* type of event handled by handler */
1105 Code message; /* message associated with handler */
1106 RegionObj region; /* region of the receiver */
1107 End;
1108
1109 NewClass(handlergroup)
1110 ABSTRACT_RECOGNISER
1111 Chain members; /* Handlers of the group */
1112 End;
1113
1114 #define ABSTRACT_HASH_TABLE \
1115 Name refer; /* Maintain references */ \
1116 Int size; /* # symbols in table */ \
1117 intptr_t buckets; /* # buckets in symbol-array */ \
1118 Symbol symbols; /* Symbol-array */
1119
1120 NewClass(hash_table)
1121 ABSTRACT_HASH_TABLE
1122 End;
1123
1124 NewClass(chain_table)
1125 ABSTRACT_HASH_TABLE
1126 End;
1127
1128 NewClass(hyper)
1129 ABSTRACT_PROGRAM_OBJECT
1130 Any from; /* first linked object */
1131 Any to; /* second linked object */
1132 Name forward_name; /* name of the link from <-from */
1133 Name backward_name; /* name of the link from <-to */
1134 End;
1135
1136 NewClass(identity)
1137 Name from; /* selector of 'from' object */
1138 Name to; /* selector of 'to' object */
1139 End;
1140
1141 NewClass(minus)
1142 ABSTRACT_BINARY_EXPRESSION
1143 End;
1144
1145 #define ABSTRACT_SOURCE_SINK \
1146 Name encoding; /* used encoding */
1147
1148 #define ABSTRACT_CHAR_ARRAY \
1149 string data; /* the represented data */
1150
1151 NewClass(char_array)
1152 ABSTRACT_CHAR_ARRAY
1153 End;
1154
1155 NewClass(name)
1156 ABSTRACT_CHAR_ARRAY
1157 End;
1158
1159 NewClass(string)
1160 ABSTRACT_CHAR_ARRAY
1161 End;
1162
1163 NewClass(source_sink)
1164 ABSTRACT_SOURCE_SINK
1165 End;
1166
1167 NewClass(number)
1168 intptr_t value; /* value of the number */
1169 End;
1170
1171 NewClass(pce)
1172 #ifndef O_RUNTIME
1173 BoolObj debugging; /* debugging? (watching spy points) */
1174 BoolObj trap_errors; /* Trap tracer on errors */
1175 #endif
1176 Name last_error; /* Last error occurred */
1177 Chain catched_errors; /* Stack of catched error-id's */
1178 BoolObj catch_error_signals; /* Catch Unix signals */
1179
1180 Chain exit_messages; /* Called on exit */
1181 Sheet exception_handlers; /* exception-name --> code */
1182
1183 Name home; /* Home directory */
1184 SourceSink defaults; /* Location to load defaults from */
1185 Directory application_data; /* User application data */
1186
1187 Name version; /* Version number of PCE */
1188 Name machine; /* Architecture */
1189 Name operating_system; /* Name of operating system*/
1190 Name window_system; /* X or windows */
1191 Int window_system_version; /* Version of Xt library used */
1192 Int window_system_revision; /* Revision of Xt library used */
1193 Chain features; /* Installed features */
1194 End;
1195
1196 NewClass(plus)
1197 ABSTRACT_BINARY_EXPRESSION
1198 End;
1199
1200 NewClass(point)
1201 Int x; /* the x- and y-coordinates */
1202 Int y;
1203 End;
1204
1205 #define ABSTRACT_HOST \
1206 Name language; /* Prolog, Lisp, ... */ \
1207 Name system; /* host system we are connected to */ \
1208 BoolObj callBack; /* if @on can be called directly */ \
1209 Chain messages; /* messages waiting in queue */
1210
1211
1212 NewClass(host)
1213 ABSTRACT_HOST
1214 End;
1215
1216 NewClass(host_data)
1217 void * handle; /* the host handle */
1218 End;
1219
1220 NewClass(real)
1221 #if SIZEOF_VOIDP == SIZEOF_DOUBLE
1222 #define REAL_IN_ONE 1
1223 double value; /* can store in one slot */
1224 #else
1225 uintptr_t value1; /* 1-st part of double */
1226 uintptr_t value2; /* 2nd-part of double */
1227 #endif
1228 End;
1229
1230 NewClass(recogniser)
1231 ABSTRACT_RECOGNISER
1232 End;
1233
1234 NewClass(region)
1235 Expression x; /* describe x of region */
1236 Expression y; /* describe y of region */
1237 Expression w; /* describe w of region */
1238 Expression h; /* describe h of region */
1239 End;
1240
1241 NewClass(relation) /* empty abstract super class */
1242 End;
1243
1244 NewClass(size)
1245 Int w; /* width and height */
1246 Int h;
1247 End;
1248
1249 #define ABSTRACT_SHEET \
1250 Chain attributes; /* list of attributes */
1251
1252 NewClass(sheet)
1253 ABSTRACT_SHEET
1254 End;
1255
1256 NewClass(source_location)
1257 Name file_name; /* Name of the file */
1258 Int line_no; /* Line of the source location */
1259 End;
1260
1261 NewClass(spatial)
1262 Equation xFrom; /* X reference point of from */
1263 Equation yFrom; /* Y reference point of from */
1264 Equation xTo; /* X reference point of to */
1265 Equation yTo; /* Y reference point of to */
1266 Equation wTo; /* W of to */
1267 Equation hTo; /* H of to */
1268 End;
1269
1270 NewClass(times)
1271 ABSTRACT_BINARY_EXPRESSION
1272 End;
1273
1274 #define ABSTRACT_VECTOR \
1275 Int offset; /* index of element 0 of array */ \
1276 Int size; /* number of valid entries */ \
1277 Int allocated; /* # allocated cells */ \
1278 Any *elements; /* array of elements */
1279
1280 NewClass(vector)
1281 ABSTRACT_VECTOR
1282 End;
1283
NewClass(visual)1284 NewClass(visual)
1285 ABSTRACT_VISUAL
1286 End;
1287
1288
1289 struct cell
1290 { Cell next; /* pointer to next cell */
1291 Any value; /* value pointer */
1292 };
1293
1294
1295 struct symbol
1296 { Any name; /* name entry of symbol */
1297 Any value; /* associated value with name */
1298 };
1299
1300 #define ABSTRACT_CONSTANT \
1301 Name name; /* Name of the constant */ \
1302 StringObj summary; /* Summary description */
1303
1304 NewClass(constant) /* @nil, @default */
1305 ABSTRACT_CONSTANT
1306 End;
1307
1308 NewClass(bool) /* @on, @off */
1309 ABSTRACT_CONSTANT
1310 End;
1311
1312 NewClass(code)
1313 ABSTRACT_CODE
1314 End;
1315
1316 NewClass(function)
1317 ABSTRACT_FUNCTION
1318 End;
1319
1320 NewClass(quote_function)
1321 Function function; /* the function quoted */
1322 End;
1323
1324 #define ABSTRACT_AND \
1325 ABSTRACT_CODE \
1326 Chain members; /* members of the and */
1327
1328 NewClass(and)
1329 ABSTRACT_AND
1330 End;
1331
1332 NewClass(assignment)
1333 ABSTRACT_CODE
1334 Var var; /* Variable to bind */
1335 Any value; /* Value (or function) */
1336 Name scope; /* Local or global binding */
1337 End;
1338
1339 NewClass(var)
1340 ABSTRACT_FUNCTION
1341 Name name; /* Name of the variable */
1342 Type type; /* Type of the variable */
1343 Any value; /* Current value of the variable */
1344 Any global_value; /* Initial or global value */
1345 End;
1346
1347 NewClass(obtain)
1348 ABSTRACT_FUNCTION
1349 Any receiver; /* receiver of the message */
1350 Name selector; /* selector of the message */
1351 Vector arguments; /* argument vector of the message */
1352 Any context; /* Host context */
1353 End;
1354
1355 NewClass(create_obj)
1356 ABSTRACT_FUNCTION
1357 Class c_class; /* Class to create instance from */
1358 Vector arguments; /* Initialisation arguments */
1359 End;
1360
1361 NewClass(message)
1362 ABSTRACT_CODE
1363 Any receiver; /* receiver of the message */
1364 Name selector; /* selector of the message */
1365 Int arg_count; /* number of arguments */
1366 Vector arguments; /* argument vector of the message */
1367 Any context; /* Host context */
1368 End;
1369
1370 NewClass(block)
1371 ABSTRACT_AND
1372 Vector parameters; /* formal-parameter-list */
1373 End;
1374
1375 NewClass(if_obj)
1376 ABSTRACT_CODE
1377 Code condition; /* codition of the `if' */
1378 Code then_branch; /* if condition succeeds */
1379 Code else_branch; /* if condition fails */
1380 End;
1381
1382 NewClass(while_obj)
1383 ABSTRACT_CODE
1384 Code condition; /* condition of the `while' */
1385 Code body; /* body of the `while' */
1386 End;
1387
1388 NewClass(equal) /* == */
1389 ABSTRACT_CODE
1390 Any left;
1391 Any right;
1392 End;
1393
1394 NewClass(non_equal) /* \== */
1395 ABSTRACT_CODE
1396 Any left;
1397 Any right;
1398 End;
1399
1400 NewClass(or)
1401 ABSTRACT_CODE
1402 Chain members; /* members of the or */
1403 End;
1404
1405 NewClass(not)
1406 ABSTRACT_CODE
1407 Code argument; /* Its argument */
1408 End;
1409
1410 NewClass(progn)
1411 ABSTRACT_FUNCTION
1412 Chain members; /* statements */
1413 End;
1414
1415 NewClass(when)
1416 ABSTRACT_FUNCTION
1417 Code condition; /* codition of the `when' */
1418 Function then_branch; /* value if condition succeeds */
1419 Function else_branch; /* value if condition fails */
1420 End;
1421
1422 /*******************************
1423 * CLASSES *
1424 *******************************/
1425
1426 struct class_definition
1427 { Name name; /* name of the class */
1428 Name super; /* Name of the super-class */
1429 SendFunc makefunction; /* Built the class */
1430 Class * global; /* Pointer to global class var */
1431 char * summary; /* Summary description */
1432 };
1433
1434 /*******************************
1435 * NAMES *
1436 *******************************/
1437
1438 #ifndef NO_BUILT_IN_DECL
1439 extern struct name builtin_names[]; /* object-array of built-in's */
1440 #endif
1441 #include "h/names.ih" /* #defines for code used names */
1442
1443 #define isName(name) (isObject(name) && onFlag((name), F_ISNAME))
1444 #define notName(name) (!isName(name))
1445 #define equalName(a, b) ((a) == (b))
1446 #define strName(s) ((char *)((Name)(s))->data.s_textA)
1447
1448 #define getAppendName(n, s) \
1449 ((Name) getAppendCharArray((CharArray)(n), (CharArray)(s)))
1450
1451
1452 /********************************
1453 * FORWARDING *
1454 ********************************/
1455
1456 #define Arg(i) (ARG[((i)-1)])
1457 #define setVar(v, val) ((v)->value = val)
1458
1459 typedef struct
1460 { Var variable;
1461 Any value;
1462 } var_binding, *VarBinding;
1463
1464 #define BINDINGBLOCKSIZE 8
1465
1466 typedef struct var_environment * VarEnvironment;
1467 typedef struct var_extension * VarExtension;
1468
1469 GLOBAL VarEnvironment varEnvironment;
1470
1471 struct var_environment
1472 { VarEnvironment parent;
1473 int size;
1474 var_binding bindings[BINDINGBLOCKSIZE];
1475 VarExtension extension;
1476 };
1477
1478
1479 struct var_extension
1480 { int allocated;
1481 var_binding bindings[BINDINGBLOCKSIZE];
1482 };
1483
1484
1485 #define withLocalVars(code) \
1486 { struct var_environment _var_env; \
1487 \
1488 _var_env.size = 0; \
1489 _var_env.parent = varEnvironment; \
1490 _var_env.extension = NULL; \
1491 varEnvironment = &_var_env; \
1492 \
1493 code; \
1494 \
1495 popVarEnvironment(); \
1496 }
1497
1498
1499 #define withArgs(ac, av, code) \
1500 { struct var_environment _var_env; \
1501 int _i; \
1502 \
1503 _var_env.parent = varEnvironment; \
1504 _var_env.extension = NULL; \
1505 varEnvironment = &_var_env; \
1506 \
1507 if ( ac <= BINDINGBLOCKSIZE ) \
1508 { Var *_v = &ARG[0]; \
1509 VarBinding _b = &_var_env.bindings[0]; \
1510 const Any *_val = (av); \
1511 for( _i=ac; --_i >= 0; _b++, _v++, _val++) \
1512 { _b->variable = *_v; \
1513 _b->value = _b->variable->value; \
1514 _b->variable->value = *_val; \
1515 if ( isObject(*_val) ) \
1516 addCodeReference(*_val); \
1517 } \
1518 _var_env.size = (ac); \
1519 } else \
1520 { _var_env.size = 0; \
1521 for(_i=0; _i<ac; _i++) \
1522 assignVar(Arg(_i+1), (av)[_i], DEFAULT); \
1523 } \
1524 \
1525 code; \
1526 \
1527 popVarEnvironment(); \
1528 }
1529
1530 #define withReceiver(r, c, code) \
1531 { Any _rs = RECEIVER->value; \
1532 Any _rc = RECEIVER_CLASS->value; \
1533 RECEIVER->value = (r); \
1534 RECEIVER_CLASS->value = (c); \
1535 code; \
1536 RECEIVER_CLASS->value = _rc; \
1537 RECEIVER->value = _rs; \
1538 }
1539
1540
1541 /********************************
1542 * INCREMENTAL GC *
1543 ********************************/
1544
1545 typedef struct to_cell *ToCell; /* TemporaryObjectCell */
1546
1547 struct to_cell
1548 { ToCell next; /* Next of the stack */
1549 Any value; /* Object there */
1550 long index; /* Index of the mark */
1551 };
1552
1553 GLOBAL ToCell AnswerStack; /* Stack of `answer objects' */
1554 GLOBAL int deferredUnalloced; /* # deferred unallocs in ->free */
1555
1556 typedef intptr_t AnswerMark;
1557
1558 #define markAnswerStack(mark) {(mark) = AnswerStack->index;}
1559 #define rewindAnswerStack(mark, obj) \
1560 { if ( (mark) != AnswerStack->index ) \
1561 _rewindAnswerStack(&(mark), obj); }
1562
1563
1564 /*******************************
1565 * GLOBAL FUNCTIONS *
1566 *******************************/
1567
1568 #include "../ker/proto.h"
1569 #include "../msg/proto.h"
1570 #include "../adt/proto.h"
1571 #include "../rel/proto.h"
1572
1573 #define getSubName(n, f, t) (Name)getSubCharArray((CharArray)(n), f, t)
1574
1575 /* Interface callback stubs */
1576 __pce_export void Cprintf(const char *fmt, ...);
1577 __pce_export void Cvprintf(const char *fmt, va_list args);
1578 __pce_export int Cputchar(int chr);
1579 __pce_export char * Cgetline(char *line, int size);
1580
1581 /* interface prototypes */
1582 __pce_export Any cToPceName(const char *text);
1583 COMMON(CPointer) CtoCPointer(void *);
1584 COMMON(status) makeClassC(Class class);
1585 COMMON(status) makeClassRC(Class class);
1586 COMMON(status) makeClassCPointer(Class class);
1587 COMMON(status) initialiseHost(Host h, Name which);
1588 COMMON(status) makeClassHost(Class class);
1589 COMMON(status) makeClassHostData(Class class);
1590 COMMON(status) makeClassSourceSink(Class class);
1591 COMMON(Host) HostObject(void);
1592 COMMON(int) hostGetc(void);
1593 COMMON(void) pceWriteErrorGoal(void);
1594 COMMON(int) initPublicInterface(void);
1595
1596 COMMON(status) initialiseSourceSink(SourceSink ss);
1597 COMMON(status) checkErrorSourceSink(SourceSink ss, IOSTREAM *fd);
1598 COMMON(status) initialiseSourceSink(SourceSink ss);
1599 COMMON(IOSTREAM *) Sopen_object(Any obj, const char *mode);
1600 COMMON(status) setStreamEncodingSourceSink(SourceSink ss, IOSTREAM *fd);
1601 COMMON(Name) encoding_to_name(IOENC encoding);
1602
1603 #if O_CPLUSPLUS
1604 COMMON(status ) callCPlusPlusProc(void *f, int ac, const Any av[]);
1605 COMMON(Any) callCPlusPlusFunc(void *f, int ac, const Any av[]);
1606 COMMON(status ) callCPlusPlusPceMethodProc(Any o, void *f,
1607 int ac, const Any av[]);
1608 COMMON(Any ) callCPlusPlusPceMethodFunc(Any o, void *f,
1609 int ac, const Any av[]);
1610 COMMON(status ) callCPlusPlusMethodProc(Any o, void *f,
1611 int ac, const Any av[]);
1612 COMMON(Any ) callCPlusPlusMethodFunc(Any o, void *f,
1613 int ac, const Any av[]);
1614 #endif
1615 COMMON(void) initCGlobals(void);
1616
1617 /********************************
1618 * GLOBAL VARIABLES *
1619 ********************************/
1620
1621 GLOBAL int XPCE_initialised; /* Is system initialised? */
1622 GLOBAL Pce PCE; /* the one and only Pce object */
1623 GLOBAL Host HOST; /* the one and only Host object */
1624 GLOBAL SendFunc DispatchEvents; /* Dispatch function */
1625 GLOBAL int changedLevel; /* Change forwarding levels */
1626 GLOBAL HashTable ErrorTable; /* @error_database */
1627 GLOBAL int XPCE_mt; /* we are multi-threaded */
1628
1629 GLOBAL struct constant ConstantNil; /* MUST be first! */
1630 GLOBAL struct constant ConstantDefault;
1631 GLOBAL struct constant ConstantClassDefault;
1632 GLOBAL struct bool BoolOn;
1633 GLOBAL struct bool BoolOff;
1634
1635 GLOBAL Var RECEIVER; /* @receiver */
1636 GLOBAL Var RECEIVER_CLASS; /* @receiver_class */
1637 GLOBAL Var EVENT; /* @event */
1638 GLOBAL Var SELECTOR; /* @selector */
1639 GLOBAL Var REPORTEE; /* @reportee */
1640 GLOBAL Var ARG[FWD_PCE_MAX_ARGS]; /* @arg1 ... */
1641 GLOBAL Var VarX; /* x */
1642 GLOBAL Var VarY; /* y */
1643 GLOBAL Var VarW; /* w */
1644 GLOBAL Var VarH; /* h */
1645 GLOBAL Var VarW2; /* w2 */
1646 GLOBAL Var VarH2; /* h2 */
1647 GLOBAL Var VarXref; /* xref */
1648 GLOBAL Var VarYref; /* yref */
1649
1650
1651 GLOBAL HashTable classTable; /* @classes (name --> class) */
1652 GLOBAL HashTable TypeTable; /* @types (name --> type) */
1653
1654 #define CTE_OK 0 /* CheckType success */
1655 #define CTE_OBTAINER_FAILED 1 /* Obtainer failed */
1656
1657 GLOBAL int CheckTypeError; /* Why did checkType fail? */
1658 GLOBAL int restoreVersion; /* Version of save file */
1659 GLOBAL SourceSink LoadFile; /* Current file for <-object */
1660 GLOBAL char *SaveMagic; /* Magic string for saved objects */
1661 GLOBAL int inBoot; /* is the system in the boot cycle? */
1662 GLOBAL uintptr_t allocBase; /* lowest allocated memory */
1663 GLOBAL uintptr_t allocTop; /* highest allocated memory */
1664 #ifndef O_RUNTIME
1665 GLOBAL int PCEdebugging; /* PCE->debugging == ON */
1666 GLOBAL int PCEdebugBoot; /* Debug booting phase? */
1667 GLOBAL Chain PCEdebugSubjects; /* Names of things we are debugging */
1668 GLOBAL char *symbolFile; /* current symbol file */
1669 #else
1670 #define PCEdebugging FALSE
1671 #endif /*O_RUNTIME*/
1672 GLOBAL int PCEargc; /* main() argument count */
1673 GLOBAL char **PCEargv; /* main() argument vector */
1674 GLOBAL char *(*getFunctionNameFromAddress)();
1675 /* stack trace (pce-debug.c) */
1676
1677 GLOBAL HashTable ObjectConstraintTable; /* object-level constraints */
1678 GLOBAL HashTable ObjectAttributeTable; /* object-level attributes */
1679 GLOBAL HashTable ObjectSendMethodTable; /* object-level send_methods */
1680 GLOBAL HashTable ObjectGetMethodTable; /* object-level get_methods */
1681 GLOBAL HashTable ObjectRecogniserTable; /* object-level recognisers */
1682 GLOBAL HashTable ObjectHyperTable; /* object-level hypers */
1683
1684 GLOBAL Name name_procent_s; /* "%s" */
1685 GLOBAL Name name_cxx; /* "C++" */
1686 GLOBAL Name name_nil; /* "[]" */
1687 GLOBAL Name name_space; /* " " */
1688 GLOBAL Code qsortCompareCode; /* used by qsortCompareObjects() */
1689 GLOBAL int qsortReverse; /* used by qsortCompareObjects() */
1690
1691 /*******************************
1692 * GLOBAL TYPES *
1693 *******************************/
1694
1695 extern char *T_report[]; /* ->report: kind, format, args... */
1696
1697 /********************************
1698 * SET ITERATION *
1699 ********************************/
1700
1701 #define copyArgs(n, f, t) \
1702 { int _i; for(_i=0; _i < (n); _i++) (t)[_i] = (f)[_i]; }
1703
1704 #define for_chain(ch, val, code) \
1705 { intptr_t _i=0, _size = valInt(ch->size); \
1706 Any *_array = (Any *)alloca((size_t)_size * sizeof(Any)); \
1707 Cell _cell = ch->head; \
1708 \
1709 for( ; notNil(_cell); _cell = _cell->next, _i++ ) \
1710 { _array[_i] = _cell->value; \
1711 if ( isObject(_array[_i]) ) addCodeReference(_array[_i]); \
1712 } \
1713 for(_i = 0; _i < _size; _i++) \
1714 { (val) = _array[_i]; \
1715 if ( nonObject(val) || !isFreedObj(val) ) \
1716 { code; \
1717 } \
1718 if ( isObject(val) ) delCodeReference(val); \
1719 } \
1720 }
1721
1722 #define for_vector(v, val, code) \
1723 { intptr_t _iv, _sizev = valInt((v)->size); \
1724 for(_iv = 0; _iv < _sizev; _iv++) \
1725 { val = (v)->elements[_iv]; \
1726 code; \
1727 } \
1728 }
1729
1730 #define for_vector_i(v, val, i, code) \
1731 { intptr_t _iv, _sizev = valInt((v)->size); \
1732 intptr_t _offv = valInt((v)->offset)+1; \
1733 for(_iv = 0; _iv < _sizev; _iv++) \
1734 { intptr_t i = _iv + _offv; \
1735 val = (v)->elements[_iv]; \
1736 code; \
1737 } \
1738 }
1739
1740
1741 #define for_hash_table(ht, var, code) \
1742 { intptr_t _iht, _sizeht = (ht)->buckets; \
1743 for(_iht = 0; _iht < _sizeht; _iht++) \
1744 { Symbol var = &(ht)->symbols[_iht]; \
1745 if ( var->name != NULL ) \
1746 { code; \
1747 } \
1748 } \
1749 }
1750
1751
1752 #define for_cell(c, ch) for(c=(ch)->head; notNil(c); c=c->next)
1753 #define for_cell_save(p, q, ch) if (notNil(p=(ch)->head))\
1754 for(q=p->next; notNil(p); p=q, q=(isNil(q) ? q : q->next))
1755
1756 /********************************
1757 * EXPRESSIONS *
1758 ********************************/
1759
1760 #define LEFTHAND(e) (((BinaryExpression)e)->left)
1761 #define RIGHTHAND(e) (((BinaryExpression)e)->right)
1762
1763
1764 /********************************
1765 * AREAS *
1766 ********************************/
1767
1768 /* An area has an orientation defined as the point where the origin
1769 * of the area is:
1770 *
1771 * northWest northEast
1772 * -----------------
1773 * | |
1774 * | |
1775 * -----------------
1776 * southWest southEast
1777 */
1778
1779 #define OrientationArea(w, h) (w>=0 ? (h>=0 ? NAME_northWest \
1780 : NAME_southWest) \
1781 : (h>=0 ? NAME_northEast \
1782 : NAME_southEast))
1783
1784
1785 #define OrientateArea(x, y, w, h, d) \
1786 { if ( equalName(d, NAME_northWest) ) \
1787 { if (w < 0) x += w+1, w = -w; \
1788 if (h < 0) y += h+1, h = -h; \
1789 } else if ( equalName(d, NAME_southWest) ) \
1790 { if (w < 0) x += w+1, w = -w; \
1791 if (h > 0) y += h-1, h = -h; \
1792 } else if ( equalName(d, NAME_northEast) ) \
1793 { if (w > 0) x += w-1, w = -w; \
1794 if (h < 0) y += h+1, h = -h; \
1795 } else if ( equalName(d, NAME_southEast) ) \
1796 { if (w > 0) x += w-1, w = -w; \
1797 if (h > 0) y += h-1, h = -h; \
1798 } \
1799 }
1800
1801
1802 /* Normalise the area given by the C integers x, y, w, h
1803 * such that w and h are always positive.
1804 */
1805 #define NormaliseArea(x,y,w,h) { if (w < 0) x += w+1, w = -w; \
1806 if (h < 0) y += h+1, h = -h; \
1807 }
1808
1809 #ifndef O_RUNTIME
1810 #define DEBUGGING(subject) ( PCEdebugging && pceDebugging(subject) )
1811 #define DEBUG(subject, goal) { if ( DEBUGGING(subject) ) \
1812 { goal; \
1813 } \
1814 }
1815
1816 #define DEBUG_BOOT(goal) { if ( PCEdebugBoot ) \
1817 { goal; \
1818 } \
1819 }
1820 #else /*O_RUNTIME*/
1821 #define DEBUG(subject, goal)
1822 #define DEBUG_BOOT(goal)
1823 #define tracePce(pce, how)
1824 #endif
1825
1826 #ifndef O_RUNTIME
1827 #define O_COUNT 0 /* we've had that */
1828 #else
1829 #define O_COUNT 0
1830 #endif
1831
1832 /********************************
1833 * SYNTAX *
1834 ********************************/
1835
1836 #include <h/syntax.h>
1837 #include <h/utf8.h>
1838
1839 /*******************************
1840 * SPEEDUP MACROS *
1841 *******************************/
1842
1843 #define sendv(rec, sel, ac, av) vm_send((rec), (sel), NULL, (ac), (av))
1844 #define getv(rec, sel, ac, av) vm_get((rec), (sel), NULL, (ac), (av))
1845 #define FixSendFunctionClass(cl, m) if ( !(cl)->send_function ) \
1846 fixSendFunctionClass((cl), (m))
1847 #define FixGetFunctionClass(cl, m) if ( !(cl)->get_function ) \
1848 fixGetFunctionClass((cl), (m))
1849
1850 /*******************************
1851 * HOST INTERFACE *
1852 *******************************/
1853
1854 #include <h/interface.h>
1855
1856 /********************************
1857 * INLINE SUPPORT *
1858 ********************************/
1859
1860 #if O_COUNT
1861 #define COUNT(g) {g;}
1862
1863 GLOBAL int hash_cmp_failed; /* failed comparisons for lookup */
1864 GLOBAL int hash_lookups; /* Total lookups */
1865 GLOBAL int hash_resizes; /* # resizes done */
1866 GLOBAL int hash_shifts; /* Shifts in append */
1867 #else
1868 #define COUNT(g)
1869 #endif
1870
1871 #define unboundedKey(name) (isInteger(name) ? (uintptr_t)(name)>>1 \
1872 : (uintptr_t)(name)>>2)
1873
1874 #if USE_PRIMES
1875 #define hashKey(name, buckets) (unboundedKey(name) % (buckets))
1876 #else
1877 #define hashKey(name, buckets) (unboundedKey(name) & ((buckets)-1))
1878 #endif
1879
1880
1881 #include "../ker/inline.c"
1882