1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: J.Wielemaker@uva.nl
5 WWW: http://www.swi-prolog.org/packages/xpce/
6 Copyright (c) 1985-2019, 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 #include <h/kernel.h>
36 #include "alloc.h"
37 #include <h/interface.h>
38 #include <h/trace.h>
39 #include <sys/types.h>
40 #include <sys/stat.h>
41 #ifdef HAVE_UNISTD_H
42 #include <unistd.h>
43 #endif
44 #include <time.h>
45 #include <h/graphics.h>
46 #include <h/unix.h>
47 #include <errno.h>
48
49 #ifdef __WINDOWS__
50 #undef PCE_MACHINE
51 #ifdef WIN64
52 #define PCE_MACHINE "x86_64"
53 #else
54 #define PCE_MACHINE "i386"
55 #endif
56 #undef OS
57 #define OS ws_os()
58 #endif
59
60 #if (defined(__sun__) && !STDC_HEADERS)
61 extern int gethostname(char *__name, size_t __len);
62 #endif
63
64 static void callExitMessagesPce(int stat, Pce pce);
65 static void exit_pce(int);
66 #ifdef HAVE_ON_EXIT
67 static void run_pce_onexit_hooks(int, void *);
68 #else
69 #ifdef HAVE_ATEXIT
70 static void run_pce_atexit_hooks(void);
71 #endif
72 #endif
73
74 static int
setAppDataPce(Pce pce,const char * dir)75 setAppDataPce(Pce pce, const char *dir)
76 { Name appdataname;
77
78 if ( dir )
79 { appdataname = CtoName(dir);
80 } else
81 {
82 #ifdef __WINDOWS__
83 if ( !(appdataname = ws_appdata("xpce")) )
84 appdataname = CtoName("~/.xpce");
85 #else
86 appdataname = CtoName("~/.xpce");
87 #endif
88 }
89 assign(pce, application_data, newObject(ClassDirectory, appdataname, EAV));
90
91 succeed;
92 }
93
94 /* The MacOS X hack. The mac loader doesn't want to load ker/glob.o, from
95 libXPCE.a as it only contains common variables. This is fixed by adding
96 a function and calling it from here. See __APPLE__ below.
97 */
98
99 static status
initialisePce(Pce pce)100 initialisePce(Pce pce)
101 { if ( PCE && notNil(PCE) )
102 return errorPce(classOfObject(pce), NAME_cannotCreateInstances);
103
104 PCE = pce;
105
106 #ifdef __APPLE__
107 { extern int IAmAGlobalFunctionToMakeMeLoad(void);
108
109 (void)IAmAGlobalFunctionToMakeMeLoad();
110 }
111 #endif
112
113 assert( sizeof(string) == 2*sizeof(void*) );
114
115 #ifndef O_RUNTIME
116 assign(pce, debugging, OFF);
117 assign(pce, trap_errors, ON);
118 #endif
119 assign(pce, catched_errors, newObject(ClassChain, EAV));
120 assign(pce, catch_error_signals, OFF);
121
122 assign(pce, exit_messages, newObject(ClassChain, EAV));
123 assign(pce, exception_handlers, newObject(ClassSheet, EAV));
124
125 assign(pce, home, DEFAULT);
126 assign(pce, defaults, CtoString("$PCEHOME/Defaults"));
127 assign(pce, version, CtoName(PCE_VERSION));
128 assign(pce, machine, CtoName(PCE_MACHINE));
129 assign(pce, operating_system, CtoName(PCE_OS));
130 #ifdef WIN32_GRAPHICS
131 assign(pce, window_system, NAME_windows);
132 #else
133 assign(pce, window_system, CtoName("X"));
134 #endif
135 assign(pce, window_system_version, toInt(ws_version()));
136 assign(pce, window_system_revision, toInt(ws_revision()));
137 assign(pce, features, newObject(ClassChain, EAV));
138
139 at_pce_exit(exit_pce, ATEXIT_FIFO);
140
141 initPublicInterface();
142
143 succeed;
144 }
145
146
147 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
148 Unicode note. Cprintf for SWI-Prolog maps to Svfprintf(), which is
149 designed to accept the argument of %Us as a UTF-8 string. Such a string
150 is produced by charArrayToUTF8() as well as pp().
151 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
152
153 static status
writePcev(Pce pce,int argc,Any * argv)154 writePcev(Pce pce, int argc, Any *argv)
155 { int i;
156
157 for(i=0; i<argc; i++)
158 { if ( i > 0 )
159 Cputchar(' ');
160
161 if ( instanceOfObject(argv[i], ClassCharArray) )
162 Cprintf("%Us", charArrayToUTF8(argv[i]));
163 else if ( isInteger(argv[i]) )
164 Cprintf("%ld", valInt(argv[i]));
165 else if ( instanceOfObject(argv[i], ClassReal) )
166 Cprintf("%g", valReal(argv[i]));
167 else
168 { char *s = pp(argv[i]);
169 Cprintf("%Us", s);
170 }
171 }
172
173 succeed;
174 }
175
176
177 static status
writeLnPcev(Pce pce,int argc,Any * argv)178 writeLnPcev(Pce pce, int argc, Any *argv)
179 { writePcev(pce, argc, argv);
180 Cputchar('\n');
181
182 succeed;
183 }
184
185
186 status
formatPcev(Pce pce,CharArray fmt,int argc,Any * argv)187 formatPcev(Pce pce, CharArray fmt, int argc, Any *argv)
188 { string s;
189
190 str_writefv(&s, fmt, argc, argv);
191 Cputstr(&s);
192 str_unalloc(&s);
193
194 succeed;
195 }
196
197 /*******************************
198 * CONSOLE OPERATIONS *
199 *******************************/
200
201 static status
showConsolePce(Pce pce,Name how)202 showConsolePce(Pce pce, Name how)
203 { return ws_show_console(how);
204 }
205
206
207 static status
exposeConsolePce(Pce pce)208 exposeConsolePce(Pce pce)
209 { return showConsolePce(pce, NAME_open);
210 }
211
212
213 static status
iconifyConsolePce(Pce pce)214 iconifyConsolePce(Pce pce)
215 { return showConsolePce(pce, NAME_iconic);
216 }
217
218
219 static status
consoleLabelPce(Pce pce,CharArray title)220 consoleLabelPce(Pce pce, CharArray title)
221 { ws_console_label(title);
222
223 succeed;
224 }
225
226
227 /*******************************
228 * ERROR HANDLING *
229 *******************************/
230
231 Name
getOsErrorPce(Pce pce)232 getOsErrorPce(Pce pce)
233 {
234 #if HAVE_STRERROR
235 #ifdef __WINDOWS__
236 return CtoName(strerror(_xos_errno()));
237 #else
238 return CtoName(strerror(errno));
239 #endif
240 #else /*HAVE_STRERROR*/
241 static char errmsg[64];
242 extern int sys_nerr;
243 extern char *sys_errlist[];
244 extern int errno;
245
246 if ( errno < sys_nerr )
247 return CtoName(sys_errlist[errno]);
248
249 sprintf(errmsg, "Unknown OS Error (%d)", errno);
250 return CtoName(errmsg);
251 #endif /*HAVE_STRERROR*/
252 }
253
254 #ifndef O_RUNTIME
255 static Chain
getUnresolvedTypesPce(Pce pce)256 getUnresolvedTypesPce(Pce pce)
257 { Chain ch = answerObject(ClassChain, EAV);
258
259 for_hash_table(TypeTable, s,
260 { Type t = s->value;
261 if ( t->kind == NAME_class )
262 { Class class = t->context;
263 if ( isNil(class->super_class) )
264 appendChain(ch, t);
265 if ( isName(class) )
266 { if ( (class = getMemberHashTable(classTable, class)) )
267 assign(t, context, class);
268 else
269 appendChain(ch, t);
270 }
271 }
272 });
273
274 answer(ch);
275 }
276 #endif /*O_RUNTIME*/
277
278
279 static status
crashPce(Pce pce)280 crashPce(Pce pce)
281 { int *p = 0;
282 *p = 1;
283 fail; /* 'ed to crash ... */
284 }
285
286
287 status
catchErrorPce(Pce pce,Any ids)288 catchErrorPce(Pce pce, Any ids)
289 { assign(pce, last_error, NIL);
290
291 return prependChain(pce->catched_errors, ids);
292 }
293
294
295 status
catchPopPce(Pce pce)296 catchPopPce(Pce pce)
297 { return deleteHeadChain(pce->catched_errors);
298 }
299
300
301 status
catchedErrorPce(Pce pce,Name id)302 catchedErrorPce(Pce pce, Name id)
303 { Cell cell;
304
305 for_cell(cell, pce->catched_errors)
306 { if ( isDefault(cell->value) )
307 succeed; /* catch all of them */
308
309 if ( (Name) cell->value == id )
310 succeed;
311
312 if ( instanceOfObject(cell->value, ClassChain) &&
313 memberChain(cell->value, id) )
314 succeed;
315 }
316
317 fail;
318 }
319
320
321 static Name
getHomePce(Pce pce)322 getHomePce(Pce pce)
323 { if ( isDefault(pce->home) )
324 { char *h;
325
326 if ( (h=getenv("PCEHOME")) )
327 assign(pce, home, CtoName(h));
328 else
329 assign(pce, home, CtoName("/usr/local/lib/xpce"));
330 }
331
332 answer(pce->home);
333 }
334
335
336 #ifdef __WINDOWS__
337 #define vareq(s, q) (stricmp(s, q) == 0)
338 #else
339 #define vareq(s, q) (strcmp(s,q) == 0)
340 #endif
341
342 Name
getEnvironmentVariablePce(Pce pce,Name name)343 getEnvironmentVariablePce(Pce pce, Name name)
344 { char *s;
345
346 if ( (s = getenv(strName(name))) )
347 answer(CtoName(s));
348 if ( vareq(strName(name), "PCEHOME") )
349 answer(get(PCE, NAME_home, EAV));
350 if ( vareq(strName(name), "PCEAPPDATA") )
351 { Directory dir = get(PCE, NAME_applicationData, EAV);
352
353 if ( dir )
354 return get(dir, NAME_path, EAV);
355 }
356
357 fail;
358 }
359
360
361 static status
exitMessagePce(Pce pce,Code code)362 exitMessagePce(Pce pce, Code code)
363 { return prependChain(pce->exit_messages, code);
364 }
365
366
367 static void
callExitMessagesPce(int stat,Pce pce)368 callExitMessagesPce(int stat, Pce pce)
369 { static int done = 0;
370
371 if ( !done++ && pce && notNil(pce) )
372 { Cell cell, q;
373
374 for_cell_save(cell, q, pce->exit_messages)
375 { addCodeReference(cell->value);
376 forwardCode(cell->value, toInt(stat), EAV);
377 }
378 }
379 }
380
381
382 static void
exit_pce(int rval)383 exit_pce(int rval)
384 { callExitMessagesPce(rval, PCE);
385 }
386
387 #ifdef HAVE_ON_EXIT
388 static void
run_pce_onexit_hooks(int rval,void * context)389 run_pce_onexit_hooks(int rval, void *context)
390 { run_pce_exit_hooks(rval);
391 }
392 #else
393
394 #ifdef HAVE_ATEXIT
395 static void /* for usage with ANSI atexit() */
run_pce_atexit_hooks(void)396 run_pce_atexit_hooks(void)
397 { run_pce_exit_hooks(0);
398 }
399 #endif
400 #endif
401
402
403 /********************************
404 * DEBUGGING *
405 ********************************/
406
407 static BoolObj
getIsRuntimeSystemPce(Pce pce)408 getIsRuntimeSystemPce(Pce pce)
409 {
410 #ifdef O_RUNTIME
411 answer(ON);
412 #else
413 answer(OFF);
414 #endif
415 }
416
417
418 static status
debuggingSubjectPce(Pce pce,Name what)419 debuggingSubjectPce(Pce pce, Name what)
420 {
421 #ifndef O_RUNTIME
422 if ( PCEdebugging && memberChain(PCEdebugSubjects, what) )
423 succeed;
424 #endif
425 fail;
426 }
427
428
429 #ifndef O_RUNTIME
430
431 static status
debugSubjectPce(Pce pce,Name what)432 debugSubjectPce(Pce pce, Name what)
433 { if ( !memberChain(PCEdebugSubjects, what) )
434 appendChain(PCEdebugSubjects, what);
435
436 return debuggingPce(pce, ON);
437 }
438
439
440 static status
nodebugSubjectPce(Pce pce,Name what)441 nodebugSubjectPce(Pce pce, Name what)
442 { deleteChain(PCEdebugSubjects, what);
443
444 succeed;
445 }
446
447
448 status
debuggingPce(Pce pce,BoolObj val)449 debuggingPce(Pce pce, BoolObj val)
450 { assign(pce, debugging, val);
451
452 PCEdebugging = (PCE->debugging == ON);
453
454 succeed;
455 }
456
457
458 static status
trapErrorsPce(Pce pce,BoolObj trap)459 trapErrorsPce(Pce pce, BoolObj trap)
460 { assign(pce, trap_errors, trap);
461
462 succeed;
463 }
464
465
466 static status
printStackPce(Pce pce,Int depth)467 printStackPce(Pce pce, Int depth)
468 { int n = isDefault(depth) ? 5 : valInt(depth);
469
470 pceBackTrace(NULL, n);
471
472 succeed;
473 }
474 #endif /*O_RUNTIME*/
475
476
477 static status
maxGoalDepthPce(Pce pce,Int depth)478 maxGoalDepthPce(Pce pce, Int depth)
479 { MaxGoalDepth = (isInteger(depth) ? valInt(depth) : NO_MAX_GOAL_DEPTH);
480
481 succeed;
482 }
483
484
485 static Int
getMaxGoalDepthPce(Pce pce)486 getMaxGoalDepthPce(Pce pce)
487 { answer(MaxGoalDepth == NO_MAX_GOAL_DEPTH ? NIL : toInt(MaxGoalDepth));
488 }
489
490
491
492 /********************************
493 * EXCEPTIONS *
494 ********************************/
495
496 status
exceptionPcev(Pce pce,Name name,int argc,Any * argv)497 exceptionPcev(Pce pce, Name name, int argc, Any *argv)
498 { Code msg;
499
500 if ( (msg = checkType(getValueSheet(pce->exception_handlers, (Any)name),
501 TypeCode, pce)) )
502 return forwardCodev(msg, argc, argv);
503
504 fail;
505 }
506
507
508 status
exceptionPce(Pce pce,Name kind,...)509 exceptionPce(Pce pce, Name kind, ...)
510 { va_list args;
511 Any argv[VA_PCE_MAX_ARGS];
512 int argc = 0;
513
514 va_start(args, kind);
515 for(; (argv[argc] = va_arg(args, Any)) != NULL; argc++)
516 assert(argc <= VA_PCE_MAX_ARGS);
517 va_end(args);
518
519 return exceptionPcev(pce, kind, argc, argv);
520 }
521
522
523 /********************************
524 * STATISTICS *
525 ********************************/
526
527 int
getFileDesCount(void)528 getFileDesCount(void)
529 {
530 #ifdef HAVE_GETDTABLESIZE
531 return getdtablesize();
532 #else
533 #ifdef HAVE_SYS_RESOURCE_H
534 #include <sys/resource.h>
535 struct rlimit rlp;
536 (void) getrlimit(RLIMIT_NOFILE, &rlp);
537
538 return (rlp.rlim_cur);
539 #else
540 #ifdef OPEN_MAX
541 return OPEN_MAX;
542 #else
543 #ifdef FOPEN_MAX
544 return FOPEN_MAX;
545 #else
546 #ifdef _NFILE
547 return _NFILE;
548 #endif
549 #endif
550 #endif
551 return 32; /* don't know */
552 #endif
553 #endif
554 }
555
556
557 static Int
getFdPce(Pce pce)558 getFdPce(Pce pce)
559 {
560 #if defined(HAVE_FSTAT) || defined(__linux)
561 int i, cntr = 0;
562 struct stat buf;
563 int mx = getFileDesCount();
564
565 for (i=0; i<mx; i++)
566 { if (fstat(i, &buf) == -1)
567 { cntr++;
568 continue;
569 }
570 }
571 answer(toInt(cntr));
572 #else
573 return toInt(ws_free_file_descriptors());
574 #endif
575 }
576
577
578 static Int
getCoreUsagePce(Pce pce)579 getCoreUsagePce(Pce pce)
580 { answer(toInt(allocbytes));
581 }
582
583
584 static Int
getWastedCorePce(Pce pce)585 getWastedCorePce(Pce pce)
586 { answer(toInt(wastedbytes));
587 }
588
589
590 static Int
getDeferredUnallocedPce(Pce pce)591 getDeferredUnallocedPce(Pce pce)
592 { answer(toInt(deferredUnalloced));
593 }
594
595
596 static Int
getAnswerStackSizePce(Pce pce)597 getAnswerStackSizePce(Pce pce)
598 { answer(countAnswerStack());
599 }
600
601
602 static Int
getNoCreatedPce(Pce pce)603 getNoCreatedPce(Pce pce)
604 { answer(getNoCreatedClass(ClassObject, ON));
605 }
606
607
608 static Int
getNoFreedPce(Pce pce)609 getNoFreedPce(Pce pce)
610 { answer(getNoFreedClass(ClassObject, ON));
611 }
612
613
614 static status
bannerPce(Pce pce)615 bannerPce(Pce pce)
616 { Name host = get(HostObject(), NAME_system, EAV);
617
618 #ifdef __WINDOWS__
619 #ifdef WIN64
620 writef("XPCE %s for %I%IWin64: XP 64-bit edition%I%I\n",
621 #else
622 writef("XPCE %s for %I%IWin32: NT,2000,XP%I%I\n",
623 #endif
624 #else
625 writef("XPCE %s for %s-%s and X%dR%d\n",
626 #endif
627 pce->version,
628 pce->machine,
629 pce->operating_system,
630 pce->window_system_version,
631 pce->window_system_revision);
632 writef("Copyright (C) 1993-2009 University of Amsterdam.\n"
633 "XPCE comes with ABSOLUTELY NO WARRANTY. "
634 "This is free software,\nand you are welcome to redistribute it "
635 "under certain conditions.\n");
636
637 if ( host != NAME_unknown )
638 writef("The host-language is %s\n", host);
639
640 succeed;
641 }
642
643
644 static Int
count_subclasses(Class class)645 count_subclasses(Class class)
646 { Int rval = ONE;
647 Cell cell;
648
649 if ( notNil(class->sub_classes) )
650 for_cell(cell, class->sub_classes)
651 rval = add(rval, count_subclasses(cell->value));
652
653 return rval;
654 }
655
656
657 static status
infoPce(Pce pce)658 infoPce(Pce pce)
659 { int classes;
660
661 classes = valInt(count_subclasses(ClassObject));
662
663 writef("Version:\n");
664 writef(" Release: %s\n", pce->version);
665 writef(" System: %s\n", pce->machine);
666 writef(" Operating System: %s\n", pce->operating_system);
667 #ifdef __WINDOWS__
668 writef(" Window System: windows %s.%s\n",
669 pce->window_system_version,
670 pce->window_system_revision);
671 #else
672 writef(" Window System: X%sR%s\n",
673 pce->window_system_version,
674 pce->window_system_revision);
675 #endif
676 writef("\n");
677 writef("Memory allocation:\n");
678 writef(" Core in use: %d Bytes\n", getCoreUsagePce(pce));
679 writef(" Core wasted: %d Bytes\n", getWastedCorePce(pce));
680 writef(" Objects allocated: %d\n", getNoCreatedPce(pce));
681 writef(" Objects freed: %d\n", getNoFreedPce(pce));
682 writef(" Objects in use: %d\n", sub(getNoCreatedPce(pce),
683 getNoFreedPce(pce)));
684 writef("\n");
685 writef("Other info:\n");
686 writef(" Classes: %d\n", toInt(classes));
687 writef("\n");
688 writef("Designed and implemented by:\n");
689 writef(" Anjo Anjewierden\n");
690 writef(" Jan Wielemaker\n");
691 writef("\n");
692
693 bannerPce(PCE);
694
695 succeed;
696 }
697
698 #ifdef HAVE_SYS_TIMES_H
699 #include <sys/times.h>
700
701 static Real
getCpuTimePce(Pce pce,Name which)702 getCpuTimePce(Pce pce, Name which)
703 { struct tms buffer;
704 float f;
705
706 times(&buffer);
707 if ( which == NAME_user )
708 f = (float) buffer.tms_utime / 60.0;
709 else if ( which == NAME_system )
710 f = (float) buffer.tms_stime / 60.0;
711 else
712 f = (float) (buffer.tms_utime + buffer.tms_stime) / 60.0;
713
714 answer(CtoReal(f));
715 }
716
717 #else /*HAVE_SYS_TIMES_H*/
718
719 /* DOS/Windows version */
720
721 static Real
getCpuTimePce(Pce pce,Name which)722 getCpuTimePce(Pce pce, Name which)
723 { /* TBD: warn on bad type? */
724 return CtoReal((float) clock()/(float)CLOCKS_PER_SEC);
725 }
726
727 #endif /*HAVE_SYS_TIMES_H*/
728
729 static Int
getMaxIntegerPce(Pce pce)730 getMaxIntegerPce(Pce pce)
731 { answer(toInt(PCE_MAX_INT));
732 }
733
734
735 static Int
getMinIntegerPce(Pce pce)736 getMinIntegerPce(Pce pce)
737 { answer(toInt(PCE_MIN_INT));
738 }
739
740
741 static status
featurePce(Pce pce,Any feature)742 featurePce(Pce pce, Any feature)
743 { return appendChain(pce->features, feature);
744 }
745
746
747 static status
hasFeaturePce(Pce pce,Any feature)748 hasFeaturePce(Pce pce, Any feature)
749 { return memberChain(pce->features, feature);
750 }
751
752
753 static StringObj
getDatePce(Pce pce)754 getDatePce(Pce pce)
755 { time_t clock;
756 char tmp[27];
757
758 clock = time(0);
759 strcpy(tmp, ctime(&clock));
760 tmp[24] = '\0';
761 answer(CtoString(tmp));
762 }
763
764
765 static Int
getMclockPce(Pce pce)766 getMclockPce(Pce pce)
767 { return toInt(mclock());
768 }
769
770
771 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
772 Linux sysinfo() is something completely different from Solaris sysinfo,
773 for which this code was designed.
774 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
775
776 #if defined (__linux__) || defined (__CYGWIN__)
777 #undef HAVE_SYSINFO
778 #endif
779
780 #if !defined(HAVE_GETHOSTNAME) || defined(HAVE_SYSINFO)
781 #undef gethostname
782 #define gethostname _emu_gethostname
783 #ifdef HAVE_SYSINFO /* solaris */
784 #include <sys/systeminfo.h>
785 #endif
786
787 static int
_emu_gethostname(char * buf,int len)788 _emu_gethostname(char *buf, int len)
789 {
790 #ifdef HAVE_SYSINFO
791 return sysinfo(SI_HOSTNAME, buf, len) > 0 ? 0 : -1;
792 #else
793 char *s;
794
795 if ( (s = getenv("HOSTNAME")) != NULL )
796 strcpy(buf, s);
797 else
798 strcpy(buf, "doshost");
799 #endif
800
801 return 0;
802 }
803
804 #endif /*HAVE_GETHOSTNAME*/
805
806 #ifdef HAVE_PWD_H
807 #include <pwd.h>
808 #endif
809
810 static Name
getUserPce(Pce pce)811 getUserPce(Pce pce)
812 { char *s;
813
814 if ( (s = ws_user()) )
815 answer(CtoName(s));
816 #if HAVE_PWD_H
817 { struct passwd *pwd;
818
819 if ( (pwd = getpwuid(getuid())) )
820 answer(CtoName(pwd->pw_name));
821 }
822 #endif
823
824 answer(NAME_unknown);
825 }
826
827
828 static Any
getUserInfoPce(Pce pce,Name what,Name user)829 getUserInfoPce(Pce pce, Name what, Name user)
830 {
831 #if HAVE_PWD_H
832 struct passwd *pwd;
833
834 if ( isDefault(user) )
835 pwd = getpwuid(getuid());
836 else
837 pwd = getpwnam(strName(user));
838
839 if ( pwd )
840 { if ( what == NAME_name )
841 answer(CtoName(pwd->pw_name));
842 else if ( what == NAME_password )
843 answer(CtoName(pwd->pw_passwd));
844 else if ( what == NAME_userId )
845 answer(toInt(pwd->pw_uid));
846 else if ( what == NAME_groupId )
847 answer(toInt(pwd->pw_gid));
848 else if ( what == NAME_gecos )
849 answer(CtoName(pwd->pw_gecos));
850 else if ( what == NAME_home )
851 answer(CtoName(pwd->pw_dir));
852 else if ( what == NAME_shell )
853 answer(CtoName(pwd->pw_shell));
854 }
855 #endif /*HAVE_PWD_H*/
856
857 fail;
858 }
859
860
861 Name
getHostnamePce(Pce pce)862 getHostnamePce(Pce pce)
863 { char buf[LINESIZE];
864
865 if ( gethostname(buf, LINESIZE) )
866 { errorPce(pce, NAME_hostname, getOsErrorPce(pce));
867 fail;
868 }
869
870 answer(CtoName(buf));
871 }
872
873
874 static Int
getPidPce(Pce pce)875 getPidPce(Pce pce)
876 {
877 #ifdef HAVE_GETPID
878 answer(toInt(getpid()));
879 #else
880 answer(toInt(ws_getpid()));
881 #endif
882 }
883
884 /* (JW) When switched on pce will catch all normal error signals, print the
885 C-stack and exit normally. Otherwise a core dump is produced.
886 */
887
888 status
catchErrorSignalsPce(Pce pce,BoolObj val)889 catchErrorSignalsPce(Pce pce, BoolObj val)
890 { if ( pce->catch_error_signals != val )
891 { assign(pce, catch_error_signals, val);
892 catchErrorSignals(val);
893 }
894
895 succeed;
896 }
897
898
899
900 /********************************
901 * DISPLAY MANAGEMENT *
902 ********************************/
903
904 static status
informPce(Pce pce,CharArray fmt,int argc,Any * argv)905 informPce(Pce pce, CharArray fmt, int argc, Any *argv)
906 { Any d = CurrentDisplay(NIL);
907
908 if ( d != NULL && getOpenDisplay(d) == ON )
909 return informDisplay(d, fmt, argc, argv);
910
911 return formatPcev(pce, fmt, argc, argv);
912 }
913
914
915 static status
confirmPce(Pce pce,CharArray fmt,int argc,Any * argv)916 confirmPce(Pce pce, CharArray fmt, int argc, Any *argv)
917 { Any d = CurrentDisplay(NIL);
918 int try;
919
920 if ( d != NULL && getOpenDisplay(d) == ON )
921 return confirmDisplay(d, fmt, argc, argv);
922
923 for(try = 0; try < 3; try++)
924 { char line[256];
925
926 formatPcev(pce, fmt, argc, argv);
927 Cprintf(" (y/n) ? ");
928 Cflush();
929
930 if ( Cgetline(line, sizeof(line)) )
931 { char *s = line;
932
933 while( *s && isblank(*s) )
934 s++;
935
936 switch(*s)
937 { case 'n':
938 fail;
939 case 'y':
940 succeed;
941 default:
942 writef("Please answer `y' or `n'\n");
943 }
944
945 continue;
946 }
947
948 break;
949 }
950
951 hostAction(HOST_HALT);
952 exit(1);
953 fail; /* fool compiler */
954 }
955
956
957 /********************************
958 * CASE HANDLING *
959 ********************************/
960
961 static status
syntaxPce(Pce pce,Name casemap,Int ws)962 syntaxPce(Pce pce, Name casemap, Int ws)
963 { Code msg;
964
965 /* realise all classes */
966 msg = answerObject(ClassMessage, Arg(2), NAME_realise, EAV);
967 send(classTable, NAME_forAll, msg, EAV);
968 doneObject(msg);
969
970 if ( isDefault(ws) )
971 ws = toInt('_');
972
973 msg = answerObject(ClassMessage, Arg(1), NAME_syntax, casemap, ws, EAV);
974 DEBUG(NAME_name, checkNames(1));
975 TRY(forNamePce(pce, msg));
976 DEBUG(NAME_name, checkNames(1));
977 doneObject(msg);
978
979 char_flags[(int)syntax.word_separator] = PU;
980 char_flags[valInt(ws)] = WS;
981 syntax.word_separator = valInt(ws);
982 syntax.uppercase = (casemap == NAME_uppercase);
983
984 succeed;
985 }
986
987
988 /********************************
989 * MISCELLANEOUS *
990 ********************************/
991
992 static status
failPce(Pce pce)993 failPce(Pce pce)
994 { fail;
995 }
996
997
998 static status
succeedPce(Pce pce)999 succeedPce(Pce pce)
1000 { succeed;
1001 }
1002
1003
1004 #ifndef O_RUNTIME
1005 static status
benchPce(Pce pce,Message msg,Int count,Name how)1006 benchPce(Pce pce, Message msg, Int count, Name how)
1007 { int cnt = valInt(count);
1008
1009 if ( how == NAME_forward )
1010 { while( cnt-- > 0 )
1011 forwardCodev((Code) msg, 0, NULL);
1012 } else if ( how == NAME_execute )
1013 { while( cnt-- > 0 )
1014 ExecuteMessage(msg);
1015 } else
1016 { Any receiver = msg->receiver;
1017 Name selector = msg->selector;
1018 Any *argv;
1019 int argc;
1020
1021 if ( msg->arg_count == ZERO )
1022 { argv = NULL;
1023 argc = 0;
1024 } else if ( msg->arg_count == ONE )
1025 { argv = (Any *)&msg->arguments;
1026 argc = 1;
1027 } else
1028 { argv = msg->arguments->elements;
1029 argc = valInt(msg->arguments->size);
1030 }
1031
1032 if ( how == NAME_send )
1033 { while( cnt-- > 0 )
1034 sendv(receiver, selector, argc, argv);
1035 } else if ( how == NAME_qad )
1036 { while( cnt-- > 0 )
1037 qadSendv(receiver, selector, argc, argv);
1038 }
1039 }
1040
1041 succeed;
1042 }
1043 #endif /*O_RUNTIME*/
1044
1045 status
resetPce(Pce pce)1046 resetPce(Pce pce)
1047 { Any dm;
1048
1049 changedLevel = 0;
1050 resetDebugger(); /* these first, so the system */
1051 resetAnswerStack(); /* can push/pop goal again */
1052 resetMessageResolve(); /* and resolve methods */
1053
1054 if ( notNil(pce) )
1055 {
1056 #ifndef O_RUNTIME
1057 debuggingPce(pce, OFF);
1058 #endif
1059 clearChain(pce->catched_errors);
1060 }
1061
1062 resetTypes();
1063 resetVars();
1064 resetDraw();
1065 resetDispatch();
1066
1067 resetApplications();
1068 if ( (dm = getObjectAssoc(NAME_displayManager)) )
1069 send(dm, NAME_reset, EAV);
1070
1071 succeed;
1072 }
1073
1074
1075 static status
diePce(Pce pce,Int rval)1076 diePce(Pce pce, Int rval)
1077 { static int dying = FALSE;
1078 int rv = isDefault(rval) ? 0 : valInt(rval);
1079
1080 if ( !dying++ ) /* avoid loops */
1081 { callExitMessagesPce(rv, pce);
1082
1083 hostAction(HOST_HALT, rv);
1084 /* should not get here */
1085 killAllProcesses(rv); /* should be done by above */
1086 }
1087
1088 exit(rv);
1089 fail; /* should not be reached */
1090 }
1091
1092
1093 static Any
getInstancePcev(Pce pce,Class class,int argc,Any * argv)1094 getInstancePcev(Pce pce, Class class, int argc, Any *argv)
1095 { answer(answerObjectv(class, argc, argv));
1096 }
1097
1098
1099 static Any
getConvertPce(Pce pce,Any obj,Type type)1100 getConvertPce(Pce pce, Any obj, Type type)
1101 { answer(checkType(obj, type, pce));
1102 }
1103
1104
1105 static status
makeClassUsingCode(Class class)1106 makeClassUsingCode(Class class)
1107 { if ( notNil(class->make_class_message) )
1108 return forwardCode(class->make_class_message, class->name, EAV);
1109
1110 fail;
1111 }
1112
1113
1114 static status
defineClassPce(Pce pce,Name name,Name super,StringObj summary,Code msg)1115 defineClassPce(Pce pce, Name name, Name super, StringObj summary, Code msg)
1116 { Class class;
1117
1118 TRY(class = nameToTypeClass(name));
1119
1120 if ( notDefault(class->realised) ) /* already existing */
1121 { Class superclass;
1122
1123 TRY(superclass = nameToTypeClass(super));
1124 if ( notNil(class->super_class) && class->super_class->name != super )
1125 return errorPce(class, NAME_cannotChangeSuperClass);
1126 } else
1127 { class = defineClass(name, super, summary, makeClassUsingCode);
1128 assign(class, make_class_message, msg);
1129 }
1130
1131 succeed;
1132 }
1133
1134
1135 /********************************
1136 * REFERENCES *
1137 ********************************/
1138
1139 Any
getObjectFromReferencePce(Pce pce,Any ref)1140 getObjectFromReferencePce(Pce pce, Any ref)
1141 { Any rval;
1142
1143 if ( isInteger(ref) )
1144 { rval = IntToPointer(ref);
1145
1146 if ( isProperObject(rval) && !isFreedObj(rval) )
1147 answer(rval);
1148 } else
1149 { assert(isName(ref));
1150
1151 answer(findGlobal(ref));
1152 }
1153
1154 fail;
1155 }
1156
1157
1158 static status
forNameReferencePce(Pce pce,Code msg)1159 forNameReferencePce(Pce pce, Code msg)
1160 { return forSomeAssoc(msg);
1161 }
1162
1163
1164 static status
renameReferencePce(Pce pce,Name old,Name new)1165 renameReferencePce(Pce pce, Name old, Name new)
1166 { return renameAssoc(old, new);
1167 }
1168
1169
1170 static Any
getVersionPce(Pce pce,Name how)1171 getVersionPce(Pce pce, Name how)
1172 { if ( isDefault(how) || how == NAME_string )
1173 answer(pce->version);
1174 if ( how == NAME_name )
1175 { char *s = strName(pce->version);
1176 char *q = s;
1177 char v[100];
1178 int n;
1179
1180 for(n=0; n<3; n++)
1181 { while(*q && isdigit(*q))
1182 q++;
1183 if ( *q == '.' )
1184 q++;
1185 }
1186 if ( q > s && q[-1] == '.' )
1187 q--;
1188 assert(q+1-s < (long)sizeof(v));
1189 strncpy(v, s, q-s);
1190 v[q-s] = EOS;
1191
1192 answer(CtoName(v));
1193 } else /* if ( how == NAME_number ) */
1194 { int major, minor, patchlevel;
1195 char *s = strName(pce->version);
1196
1197 if ( sscanf(s, "%d.%d.%d", &major, &minor, &patchlevel) == 3 )
1198 { answer(toInt(major*10000+minor*100+patchlevel));
1199 }
1200
1201 answer(toInt(-1));
1202 }
1203 }
1204
1205 /*******************************
1206 * THREADS *
1207 *******************************/
1208
1209
1210 static BoolObj
getMultiThreadingPce(Pce pce)1211 getMultiThreadingPce(Pce pce)
1212 { answer(XPCE_mt == TRUE ? ON : OFF);
1213 }
1214
1215
1216 /*******************************
1217 * CLASS DECLARATION *
1218 *******************************/
1219
1220 /* Type declaractions */
1221
1222 static char *T_instance[] =
1223 { "class=class", "argument=unchecked ..." };
1224 #ifndef O_RUNTIME
1225 static char *T_bench[] =
1226 { "message=message", "times=int",
1227 "how={forward,execute,qad,send}" };
1228 #endif /*O_RUNTIME*/
1229 static char *T_userInfo[] =
1230 { "field={name,password,user_id,group_id,gecos,home,shell}",
1231 "user=[name]" };
1232 static char *T_formatAchar_array_argumentAany_XXX[] =
1233 { "format=char_array", "argument=any ..." };
1234 static char *T_exception[] =
1235 { "identifier=name", "context=any ..." };
1236 static char *T_defineClass[] =
1237 { "name=name", "super=name", "summary=[string]", "realise=code" };
1238 static char *T_convert[] =
1239 { "object=unchecked", "type=type" };
1240 static char *T_renameReference[] =
1241 { "old=name", "new=name" };
1242 static char *T_syntax[] =
1243 { "syntax={uppercase}", "word_separator=[char]" };
1244
1245 /* Instance Variables */
1246
1247 static vardecl var_pce[] =
1248 {
1249 #ifndef O_RUNTIME
1250 SV(NAME_debugging, "bool", IV_GET|IV_STORE, debuggingPce,
1251 NAME_debugging, "Add consistency checks"),
1252 SV(NAME_trapErrors, "bool", IV_GET|IV_STORE, trapErrorsPce,
1253 NAME_debugging, "Trap tracer on errors"),
1254 #endif
1255 IV(NAME_lastError, "name*", IV_BOTH,
1256 NAME_exception, "Id of last occurred error"),
1257 IV(NAME_catchedErrors, "chain", IV_GET,
1258 NAME_exception, "Errors are expected by code"),
1259 SV(NAME_catchErrorSignals, "bool", IV_GET|IV_STORE, catchErrorSignalsPce,
1260 NAME_debugging, "Trap Unix signals to deal with errors"),
1261 IV(NAME_exitMessages, "chain", IV_GET,
1262 NAME_quit, "Executed when the process terminates"),
1263 IV(NAME_exceptionHandlers, "sheet", IV_GET,
1264 NAME_exception, "Exception-name -> handler mapping"),
1265 IV(NAME_home, "[name]", IV_SEND,
1266 NAME_environment, "PCE's home directory"),
1267 IV(NAME_defaults, "source_sink|char_array", IV_BOTH,
1268 NAME_environment, "File/rc from which to load defaults"),
1269 IV(NAME_applicationData, "directory", IV_BOTH,
1270 NAME_environment, "Directory for application data"),
1271 IV(NAME_version, "name", IV_NONE,
1272 NAME_version, "Version indication"),
1273 IV(NAME_machine, "name", IV_GET,
1274 NAME_version, "Name of this machine/architecture"),
1275 IV(NAME_operatingSystem, "name", IV_GET,
1276 NAME_version, "Name of operating system"),
1277 IV(NAME_windowSystem, "{X,windows}", IV_GET,
1278 NAME_version, "Basic window system used"),
1279 IV(NAME_windowSystemVersion, "int", IV_GET,
1280 NAME_version, "Version of Xt library used to compile xpce"),
1281 IV(NAME_windowSystemRevision, "int", IV_GET,
1282 NAME_version, "Revision of Xt library used to compile xpce"),
1283 IV(NAME_features, "chain", IV_GET,
1284 NAME_version, "List of installed features")
1285 };
1286
1287 /* Send Methods */
1288
1289 static senddecl send_pce[] =
1290 { SM(NAME_initialise, 0, NULL, initialisePce,
1291 DEFAULT, "Create @pce (done only once)"),
1292 SM(NAME_syntax, 2, T_syntax, syntaxPce,
1293 NAME_host, "Specify language compatible syntax"),
1294 SM(NAME_defineClass, 4, T_defineClass, defineClassPce,
1295 NAME_class, "Declare a class without details"),
1296 SM(NAME_consoleLabel, 1, "char_array", consoleLabelPce,
1297 NAME_console, "Set the label for the console window"),
1298 SM(NAME_exposeConsole, 0, NULL, exposeConsolePce,
1299 NAME_console, "Expose the PCE/host console window"),
1300 SM(NAME_iconifyConsole, 0, NULL, iconifyConsolePce,
1301 NAME_console, "Make PCE/host console window an icon"),
1302 SM(NAME_showConsole, 1, "{open,full_screen,iconic,hidden}", showConsolePce,
1303 NAME_console, "Control visibility of the console window"),
1304 SM(NAME_fail, 0, NULL, failPce,
1305 NAME_control, "Simply fails"),
1306 SM(NAME_succeed, 0, NULL, succeedPce,
1307 NAME_control, "Simply succeeds"),
1308 SM(NAME_info, 0, NULL, infoPce,
1309 NAME_debugging, "Write statistics/info to terminal"),
1310 SM(NAME_maxGoalDepth, 1, "[int]*", maxGoalDepthPce,
1311 NAME_debugging, "Set maximum recursion level"),
1312 #ifndef O_RUNTIME
1313 SM(NAME_listWastedCore, 1, "list_content=[bool]", listWastedCorePce,
1314 NAME_debugging, "List wasted core map"),
1315 SM(NAME_nodebugSubject, 1, "subject=name", nodebugSubjectPce,
1316 NAME_debugging, "Don't Report internal event on terminal"),
1317 SM(NAME_printStack, 1, "depth=[0..]", printStackPce,
1318 NAME_debugging, "Print PCE message stack to host-window"),
1319 SM(NAME_debugSubject, 1, "subject=name", debugSubjectPce,
1320 NAME_debugging, "Report internal event on terminal"),
1321 SM(NAME_bench, 3, T_bench, benchPce,
1322 NAME_statistics, "Benchmark for message passing"),
1323 #endif
1324 SM(NAME_debuggingSubject, 1, "subject=name", debuggingSubjectPce,
1325 NAME_debugging, "Succeed if we are debugging this subject"),
1326 SM(NAME_crash, 0, NULL, crashPce,
1327 NAME_debugging, "Write in an illegal address to force a crash"),
1328 SM(NAME_catchError, 1, "identifier=[name|chain]", catchErrorPce,
1329 NAME_exception, "Indicate code is prepared to handle errors"),
1330 SM(NAME_catchPop, 0, NULL, catchPopPce,
1331 NAME_exception, "Pop pushed error handlers"),
1332 SM(NAME_catched, 1, "identifier=name", catchedErrorPce,
1333 NAME_exception, "Test if error_id is catched"),
1334 SM(NAME_exception, 2, T_exception, exceptionPcev,
1335 NAME_exception, "Raise an exception"),
1336 SM(NAME_banner, 0, NULL, bannerPce,
1337 NAME_initialise, "Write standard banner to terminal"),
1338 SM(NAME_forName, 1, "message=code", forNamePce,
1339 NAME_name, "Execute code on all defined names"),
1340 SM(NAME_die, 1, "status=[int]", diePce,
1341 NAME_quit, "Exit this (Unix) process with status"),
1342 SM(NAME_exitMessage, 1, "message=code", exitMessagePce,
1343 NAME_quit, "Execute code while dying"),
1344 SM(NAME_forNameReference, 1, "message=code", forNameReferencePce,
1345 NAME_reference, "Run code on all name references (global objects)"),
1346 SM(NAME_renameReference, 2, T_renameReference, renameReferencePce,
1347 NAME_reference, "Rename global reference"),
1348 SM(NAME_confirm, 2, T_formatAchar_array_argumentAany_XXX, confirmPce,
1349 NAME_report, "Test if the user confirms string"),
1350 SM(NAME_format, 2, T_formatAchar_array_argumentAany_XXX, formatPcev,
1351 NAME_report, "Formatted like C's printf"),
1352 SM(NAME_inform, 2, T_formatAchar_array_argumentAany_XXX, informPce,
1353 NAME_report, "Inform the user of something"),
1354 SM(NAME_write, 1, "argument=any ...", writePcev,
1355 NAME_report, "Write arguments, separated by spaces"),
1356 SM(NAME_writeLn, 1, "argument=any ...", writeLnPcev,
1357 NAME_report, "Write arguments, separated by spaces, add nl"),
1358 SM(NAME_feature, 1, "any", featurePce,
1359 NAME_version, "Define new feature"),
1360 SM(NAME_hasFeature, 1, "any", hasFeaturePce,
1361 NAME_version, "Test if feature is defined"),
1362 SM(NAME_loadDefaults, 1, "source_sink", loadDefaultsPce,
1363 NAME_default, "Load class variable defaults from file")
1364 };
1365
1366 /* Get Methods */
1367
1368 static getdecl get_pce[] =
1369 { GM(NAME_home, 0, "name", NULL, getHomePce,
1370 DEFAULT, "Find XPCE's home directory"),
1371 GM(NAME_convert, 2, "converted=unchecked", T_convert, getConvertPce,
1372 NAME_conversion, "Convert anything to specified type"),
1373 #ifndef O_RUNTIME
1374 GM(NAME_unresolvedTypes, 0, "chain", NULL, getUnresolvedTypesPce,
1375 NAME_debugging, "New chain with unresolved types"),
1376 #endif
1377 GM(NAME_maxGoalDepth, 0, "int*", NULL, getMaxGoalDepthPce,
1378 NAME_debugging, "Maximum recursion level"),
1379 GM(NAME_environmentVariable, 1, "value=name", "name=name",
1380 getEnvironmentVariablePce,
1381 NAME_environment, "Unix environment variable (getenv)"),
1382 GM(NAME_hostname, 0, "host=name", NULL, getHostnamePce,
1383 NAME_environment, "Name of host on which PCE runs"),
1384 GM(NAME_user, 0, "user=name", NULL, getUserPce,
1385 NAME_environment, "Login name of user"),
1386 GM(NAME_userInfo, 2, "value=name|int", T_userInfo, getUserInfoPce,
1387 NAME_environment, "Get information on user (from the passwd file)"),
1388 GM(NAME_fd, 0, "number=int", NULL, getFdPce,
1389 NAME_file, "Number of free file descriptors"),
1390 GM(NAME_maxInteger, 0, "value=int", NULL, getMaxIntegerPce,
1391 NAME_limit, "Highest representable integer"),
1392 GM(NAME_minInteger, 0, "value=int", NULL, getMinIntegerPce,
1393 NAME_limit, "Lowest representable integer"),
1394 GM(NAME_instance, 2, "created=object|function", T_instance, getInstancePcev,
1395 NAME_oms, "Create instance of any class"),
1396 GM(NAME_objectFromReference, 1, "object=unchecked", "reference=int|name",
1397 getObjectFromReferencePce,
1398 NAME_oms, "Convert object-name or integer reference into object"),
1399 GM(NAME_pid, 0, "identifier=int", NULL, getPidPce,
1400 NAME_process, "Process id of this process"),
1401 GM(NAME_osError, 0, "identifier=name", NULL, getOsErrorPce,
1402 NAME_report, "Name of last operating system error"),
1403 GM(NAME_isRuntimeSystem, 0, "bool", NULL, getIsRuntimeSystemPce,
1404 NAME_runtime, "@on if this is the runtime library"),
1405 GM(NAME_answerStackSize, 0, "cells=int", NULL, getAnswerStackSizePce,
1406 NAME_statistics, "Number of cells (objects) in `answer' state"),
1407 GM(NAME_coreUsage, 0, "bytes=int", NULL, getCoreUsagePce,
1408 NAME_statistics, "Total core in active use"),
1409 GM(NAME_coreWasted, 0, "bytes=int", NULL, getWastedCorePce,
1410 NAME_statistics, "Core requested from system, but not in use"),
1411 GM(NAME_cpuTime, 1, "seconds=real", "kind=[{user,system}]", getCpuTimePce,
1412 NAME_statistics, "Total CPU time for this process"),
1413 GM(NAME_deferredUnalloced, 0, "number=int", NULL, getDeferredUnallocedPce,
1414 NAME_statistics, "# freed referenced objects"),
1415 GM(NAME_objectsAllocated, 0, "number=int", NULL, getNoCreatedPce,
1416 NAME_statistics, "Total number of objects created"),
1417 GM(NAME_objectsFreed, 0, "number=int", NULL, getNoFreedPce,
1418 NAME_statistics, "Total number of objects freed"),
1419 GM(NAME_date, 0, "string", NULL, getDatePce,
1420 NAME_time, "Unix's standard time string for now"),
1421 GM(NAME_mclock, 0, "int", NULL, getMclockPce,
1422 NAME_time, "#Elapsed milliseconds since XPCE was started"),
1423 GM(NAME_version, 1, "name|int", "how=[{string,name,number}]", getVersionPce,
1424 NAME_version, "Representation of the version number"),
1425 GM(NAME_multiThreading, 0, "bool", NULL, getMultiThreadingPce,
1426 NAME_thread, NULL)
1427 };
1428
1429 /* Resources */
1430
1431 static classvardecl rc_pce[] =
1432 { RC(NAME_initialise, "code*",
1433 UXWIN(/*UNIX*/
1434 "and(_dialog_bg @= colour(grey80),\n"
1435 " _button_elevation @= elevation(button, 1, grey80,\n"
1436 " grey95, grey50,\n"
1437 " '3d', grey70),\n"
1438 " _mark_elevation @= elevation(mark, 0),\n"
1439 " _win_pen @= number(0))",
1440 /*__WINDOWS__*/
1441 "and(_dialog_bg @= colour(win_btnface),\n"
1442 " _graph_bg @= colour(win_window),\n"
1443 " _win_pen @= number(1),\n"
1444 " _isearch_style @= style(background := green),\n"
1445 " _select_style @= style(background := win_highlight,\n"
1446 " colour := win_highlighttext),\n"
1447 " _txt_height @= elevation(@nil, 2, win_window))"),
1448 "Code object to run when initialising defaults")
1449 };
1450
1451 /* Class Declaration */
1452
1453 static Name pce_termnames[] = { NAME_version };
1454
1455 ClassDecl(pce_decls,
1456 var_pce, send_pce, get_pce, rc_pce,
1457 1, pce_termnames,
1458 "$Rev$");
1459
1460 status
makeClassPce(Class class)1461 makeClassPce(Class class)
1462 { declareClass(class, &pce_decls);
1463
1464 saveStyleClass(class, NAME_external);
1465 cloneStyleClass(class, NAME_none);
1466
1467 PCE = globalObject(NAME_pce, ClassPce, EAV);
1468 protectObject(PCE);
1469
1470 succeed;
1471 }
1472
1473
1474 /*******************************
1475 * INITIALISATION *
1476 *******************************/
1477
1478 static HashTable
objectAttributeTable(Name name)1479 objectAttributeTable(Name name)
1480 { HashTable ht = globalObject(name, ClassHashTable, EAV);
1481 assign(ht, refer, NAME_value);
1482
1483 return ht;
1484 }
1485
1486
1487 static void
protectConstant(Any obj)1488 protectConstant(Any obj)
1489 { Instance i = obj;
1490
1491 i->flags = F_PROTECTED|OBJ_MAGIC;
1492 }
1493
1494
1495 export status
pceInitialise(int handles,const char * home,const char * appdata,int argc,char ** argv)1496 pceInitialise(int handles, const char *home, const char *appdata,
1497 int argc, char **argv)
1498 { AnswerMark mark;
1499
1500 if ( XPCE_initialised )
1501 succeed;
1502
1503 XPCE_initialised = TRUE;
1504 inBoot = TRUE;
1505
1506 PCEargc = argc;
1507 PCEargv = argv;
1508
1509 MaxGoalDepth = NO_MAX_GOAL_DEPTH;
1510 initAnswerStack();
1511 initMClock();
1512
1513 #ifndef O_RUNTIME
1514 PCEdebugging = FALSE;
1515 if ( getenv("PCEDEBUGBOOT") != NULL )
1516 { PCEdebugBoot = TRUE;
1517 DEBUG_BOOT(Cprintf("Debugging boot cycle\n"));
1518 } else
1519 PCEdebugBoot = FALSE;
1520 #endif
1521
1522 PCE = NIL;
1523 pceReset(); /* reset important globals */
1524 markAnswerStack(mark);
1525 syntax.word_separator = '_';
1526
1527 protectConstant(NIL);
1528 protectConstant(DEFAULT);
1529 protectConstant(ON);
1530 protectConstant(OFF);
1531
1532 DEBUG_BOOT(Cprintf("Alloc ...\n"));
1533 pceInitAlloc();
1534 allocRange(&ConstantNil, sizeof(struct constant));
1535 allocRange(&ConstantDefault, sizeof(struct constant));
1536 allocRange(&ConstantClassDefault, sizeof(struct constant));
1537 allocRange(&BoolOff, sizeof(struct bool));
1538 allocRange(&BoolOn, sizeof(struct bool));
1539 initNamesPass1();
1540 DEBUG_BOOT(Cprintf("Types ...\n"));
1541 initTypes();
1542 DEBUG_BOOT(Cprintf("Names ...\n"));
1543 initCharArrays();
1544 initNamesPass2();
1545 DEBUG_BOOT(Cprintf("Name Assocs ...\n"));
1546 initAssoc(handles);
1547
1548 { Type t;
1549 t = createType(CtoName("any ..."), NAME_any, NIL);
1550 vectorType(t, ON);
1551 }
1552
1553 /* Make instanceOfObject(impl, ClassMethod) work ... */
1554 ClassMethod->tree_index = 1;
1555 ClassMethod->neighbour_index = 4;
1556 ClassSendMethod->tree_index = 2;
1557 ClassGetMethod->tree_index = 3;
1558
1559 DEBUG_BOOT(Cprintf("Boot classes ...\n"));
1560
1561 ClassObject =
1562 bootClass(NAME_object, /* Name */
1563 (Name) NIL, /* SuperClass */
1564 sizeof(struct object), /* Instance size */
1565 1, /* # PCE typed slots */
1566 initialiseObject, /* Initialisation function */
1567 0);
1568
1569 ClassChain =
1570 bootClass(NAME_chain,
1571 NAME_object,
1572 sizeof(struct chain),
1573 0,
1574 initialiseChainv,
1575 1, "any ...");
1576
1577 ClassProgramObject =
1578 bootClass(NAME_programObject,
1579 NAME_object,
1580 sizeof(struct program_object),
1581 1,
1582 initialiseProgramObject,
1583 0);
1584
1585 ClassType =
1586 bootClass(NAME_type,
1587 NAME_programObject,
1588 sizeof(struct type),
1589 6,
1590 initialiseType,
1591 4, "name", "name", "any", "any"); /* changed later!! */
1592 lookupBootClass(ClassType, (Func) getLookupType, 1, "name");
1593
1594 ClassSourceLocation =
1595 bootClass(NAME_sourceLocation,
1596 NAME_object,
1597 sizeof(struct source_location),
1598 2,
1599 initialiseSourceLocation,
1600 2, "name", "[int]*");
1601
1602 ClassVector =
1603 bootClass(NAME_vector,
1604 NAME_object,
1605 sizeof(struct vector),
1606 2,
1607 initialiseVectorv,
1608 1, "any ...");
1609
1610 ClassHashTable =
1611 bootClass(NAME_hashTable,
1612 NAME_object,
1613 sizeof(struct hash_table),
1614 1,
1615 initialiseHashTable,
1616 1, "[int]");
1617
1618 ClassBehaviour =
1619 bootClass(NAME_behaviour,
1620 NAME_programObject,
1621 sizeof(struct behaviour),
1622 2,
1623 initialiseBehaviour,
1624 0);
1625
1626 ClassMethod =
1627 bootClass(NAME_method,
1628 NAME_behaviour,
1629 sizeof(struct method),
1630 5,
1631 initialiseMethod,
1632 6, "name", "[vector]", "code|any", "[string]*",
1633 "[source_location]*", "[name]*");
1634
1635 ClassSendMethod =
1636 bootClass(NAME_sendMethod,
1637 NAME_method,
1638 sizeof(struct send_method),
1639 0,
1640 initialiseMethod,
1641 6, "name", "[vector]", "code|any",
1642 "[string]*", "[source_location]*", "[name]*");
1643
1644 ClassGetMethod =
1645 bootClass(NAME_getMethod,
1646 NAME_method,
1647 sizeof(struct get_method),
1648 0,
1649 initialiseGetMethod,
1650 7, "name", "[type]", "[vector]", "code|any",
1651 "[string]*", "[source_location]*", "[name]*");
1652
1653 ClassCharArray =
1654 bootClass(NAME_charArray,
1655 NAME_object,
1656 sizeof(struct char_array),
1657 0,
1658 initialiseCharArray,
1659 1, "char_array");
1660
1661 ClassName =
1662 bootClass(NAME_name,
1663 NAME_charArray,
1664 sizeof(struct name),
1665 1,
1666 initialiseName,
1667 1, "char_array");
1668
1669 ClassString =
1670 bootClass(NAME_string,
1671 NAME_charArray,
1672 sizeof(struct string),
1673 0,
1674 initialiseStringv,
1675 2, "[name]", "any ...");
1676
1677 ClassTuple =
1678 bootClass(NAME_tuple,
1679 NAME_object,
1680 sizeof(struct tuple),
1681 2,
1682 initialiseTuple,
1683 2, "any", "any");
1684
1685 DEBUG_BOOT(Cprintf("Initialised boot classes\n"));
1686
1687 classTable = globalObject(NAME_classes, ClassHashTable, EAV);
1688 #ifndef O_RUNTIME
1689 PCEdebugSubjects = globalObject(NAME_DebugSubjects, ClassChain, EAV);
1690 #endif
1691 initDebugger();
1692
1693 TypeTable->class = ClassHashTable;
1694 newAssoc(NAME_types, TypeTable);
1695 createdClass(ClassHashTable, TypeTable, NAME_new);
1696
1697 TypeExpression = newObject(ClassType, NAME_expression, NAME_compound, EAV);
1698 superType(TypeExpression, TypeInt);
1699 superType(TypeExpression, nameToType(NAME_function));
1700 superType(TypeExpression, nameToType(NAME_number));
1701 superType(TypeExpression, nameToType(NAME_real));
1702 superType(TypeExpression, nameToType(NAME_var));
1703
1704 TypeCode = nameToType(NAME_code);
1705 TypeImage = nameToType(NAME_image);
1706 TypeColour = nameToType(NAME_colour);
1707 TypeEquation = CtoType("=");
1708
1709 ObjectConstraintTable = objectAttributeTable(NAME_objectConstraintTable);
1710 ObjectAttributeTable = objectAttributeTable(NAME_objectAttributeTable);
1711 ObjectSendMethodTable = objectAttributeTable(NAME_objectSendMethodTable);
1712 ObjectGetMethodTable = objectAttributeTable(NAME_objectGetMethodTable);
1713 ObjectRecogniserTable = objectAttributeTable(NAME_objectRecogniserTable);
1714 ObjectHyperTable = objectAttributeTable(NAME_objectHyperTable);
1715
1716 name_procent_s = CtoName("%s");
1717 name_cxx = CtoName("C++");
1718 name_nil = CtoName("[]");
1719 name_space = CtoName(" ");
1720
1721 DEBUG_BOOT(Cprintf("Building class definitions\n"));
1722 initClassDefs();
1723 DEBUG_BOOT(Cprintf("Realising Boot classes ...\n"));
1724 realiseBootClass(ClassObject);
1725 realiseBootClass(ClassChain);
1726 realiseBootClass(ClassProgramObject);
1727 realiseBootClass(ClassType);
1728 realiseBootClass(ClassSourceLocation);
1729 realiseBootClass(ClassVector);
1730 realiseBootClass(ClassHashTable);
1731 realiseBootClass(ClassBehaviour);
1732 realiseBootClass(ClassMethod);
1733 realiseBootClass(ClassSendMethod);
1734 realiseBootClass(ClassGetMethod);
1735 realiseBootClass(ClassCharArray);
1736 realiseBootClass(ClassName);
1737 realiseBootClass(ClassString);
1738 realiseBootClass(ClassTuple);
1739 DEBUG_BOOT(Cprintf("Boot classes realised.\n"));
1740 initTypeAliases();
1741
1742 { for_hash_table(classTable, s,
1743 { Class class = s->value;
1744 if ( class->no_created != class->no_freed &&
1745 class->realised == OFF )
1746 realiseClass(class);
1747 });
1748 }
1749
1750 realiseClass(ClassPce); /* make @pce */
1751 realiseClass(ClassVar); /* @arg1, ... */
1752 realiseClass(ClassConstant); /* @default, @nil */
1753 realiseClass(ClassBool); /* @on, @off */
1754
1755 DEBUG_BOOT(Cprintf("Defining features\n"));
1756
1757 featurePce(PCE, NAME_process);
1758 #if defined(HAVE_SOCKET) || defined(HAVE_WINSOCK)
1759 featurePce(PCE, NAME_socket);
1760 #endif
1761
1762 DEBUG_BOOT(Cprintf("C/C++ global objects\n"));
1763 initCGlobals();
1764 if ( home )
1765 send(PCE, NAME_home, CtoName(home), EAV);
1766 if ( appdata )
1767 setAppDataPce(PCE, appdata);
1768
1769 rewindAnswerStack(mark, NIL);
1770 inBoot = FALSE;
1771
1772 ws_initialise(argc, argv);
1773 if ( !hostAction(HOST_ATEXIT, run_pce_exit_hooks) )
1774 {
1775 #ifdef HAVE_ON_EXIT
1776 on_exit(run_pce_onexit_hooks, NULL);
1777 #else
1778 #ifdef HAVE_ATEXIT
1779 atexit(run_pce_atexit_hooks);
1780 #endif
1781 #endif
1782 }
1783
1784 DEBUG_BOOT(Cprintf("Initialisation complete.\n"));
1785 succeed;
1786 }
1787