1 /* csl.c Copyright (C) 1989-2010 Codemist Ltd */
2
3 /*
4 * This is Lisp system for use when delivering Lisp applications
5 * (such as REDUCE) on pretty-well any computer that has an ANSI
6 * C compiler.
7 */
8
9 /**************************************************************************
10 * Copyright (C) 2010, Codemist Ltd. A C Norman *
11 * *
12 * Redistribution and use in source and binary forms, with or without *
13 * modification, are permitted provided that the following conditions are *
14 * met: *
15 * *
16 * * Redistributions of source code must retain the relevant *
17 * copyright notice, this list of conditions and the following *
18 * disclaimer. *
19 * * Redistributions in binary form must reproduce the above *
20 * copyright notice, this list of conditions and the following *
21 * disclaimer in the documentation and/or other materials provided *
22 * with the distribution. *
23 * *
24 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
25 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
26 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
27 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
28 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
29 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
30 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
31 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
32 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
33 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
34 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
35 * DAMAGE. *
36 *************************************************************************/
37
38
39
40 /* Signature: 1f6f408d 22-Aug-2010 */
41
42 #define INCLUDE_ERROR_STRING_TABLE 1
43 #include "headers.h"
44 #undef INCLUDE_ERROR_STRING_TABLE
45
46 #include "version.h"
47
48 #ifdef SOCKETS
49 #include "sockhdr.h"
50 #endif
51
52 #ifndef WIN32
53 #include <sys/wait.h>
54 #endif
55
56 #ifdef HAVE_UNISTD_H
57 #include <sys/unistd.h>
58 #endif
59
60 #ifndef HAVE_FWIN
61 /*
62 * During startup on a windowed system if I needed to report an error
63 * but the window was minimised I need to restore it...
64 */
65 #define fwin_restore()
66 #endif
67
68 #ifdef SOCKETS
69
70 static int port_number, remote_store, current_users, max_users;
71 SOCKET socket_server;
72 int sockets_ready;
73 clock_t cpu_timeout;
74 time_t elapsed_timeout;
75 static int char_to_socket(int c);
76
77 #endif
78
79 /*
80 * These flags are used to ensure that protected symbols don't get
81 * overwritten by default, and that the system keeps quiet about it.
82 */
83
84 CSLbool symbol_protect_flag = YES;
85 CSLbool warn_about_protected_symbols = NO;
86
87 #if defined WINDOW_SYSTEM && !defined EMBEDDED
88 CSLbool use_wimp;
89 #endif
90
91 #ifdef USE_MPI
92 int32_t mpi_rank,mpi_size;
93 #endif
94
95 /*****************************************************************************/
96 /* Error reporting and recovery */
97 /*****************************************************************************/
98
99 #ifdef CHECK_STACK
100 /*
101 * Some computers are notably unhelpful about their behaviour when the system
102 * stack overflows. As a debugging tool on such machines I can do limited
103 * software checking by inserting explicit calls to this function in places
104 * I think may be critical. I impose an arbitrary limit on the stack size,
105 * but that is better than no checking and random corruption - maybe. Please
106 * do not enable CHECK_STACK unless it is really necessary to hunt a bug,
107 * since it is miserably expensive and crude.
108 */
109
110 #define C_STACK_ALLOCATION 240000
111
112 static int spset = 0;
113 static int32_t spbase = 0, spmin;
114
115 static int stack_depth[C_STACK_ALLOCATION], stack_line[C_STACK_ALLOCATION];
116 static char *stack_file[C_STACK_ALLOCATION];
117 static int c_stack_ptr = 0;
118
check_stack(char * file,int line)119 int check_stack(char *file, int line)
120 {
121 int32_t temp = (int32_t)&temp;
122 if (!spset)
123 { spbase = spmin = temp;
124 spset = 1;
125 c_stack_ptr = 0;
126 stack_depth[0] = temp;
127 stack_line[0] = line;
128 stack_file[0] = file;
129 }
130 if (temp < stack_depth[c_stack_ptr] && c_stack_ptr<C_STACK_ALLOCATION-2)
131 c_stack_ptr++;
132 else while (temp > stack_depth[c_stack_ptr] && c_stack_ptr>0)
133 c_stack_ptr--;
134 stack_depth[c_stack_ptr] = temp;
135 stack_line[c_stack_ptr] = line;
136 stack_file[c_stack_ptr] = file;
137 if (temp < spmin-250) /* Only check at granularity of 250 bytes */
138 { int i;
139 term_printf("Stack depth %d at file %s line %d\n",
140 spbase-temp, file, line);
141 for (i=c_stack_ptr; i>=0 && i > c_stack_ptr-30; i--)
142 term_printf(" %s:%d", stack_file[i], stack_line[i]);
143 term_printf("\n");
144 spmin = temp;
145 if (temp < spbase-C_STACK_ALLOCATION) return 1;
146 }
147 return 0;
148 }
149 #endif
150
151 /*
152 * error_message_table was defined in cslerror.h since that way I can keep its
153 * contents textually close to the definitions of the message codes that it
154 * has to relate to.
155 */
156
157 #define errcode(n) error_message_table[n]
158
error(int nargs,int code,...)159 Lisp_Object MS_CDECL error(int nargs, int code, ...)
160 /*
161 * nargs indicates how many values have been provided AFTER the
162 * code. Thus nargs==0 will just display a simple message, nargs==1
163 * will be a message plus a value and so on. I will expect that the
164 * number of actual args here is well within any limits that I ought to
165 * impose.
166 */
167 {
168 va_list a;
169 int i;
170 Lisp_Object nil = C_nil, w1;
171 Lisp_Object *w = (Lisp_Object *)&work_1;
172 if (nargs > ARG_CUT_OFF) nargs = ARG_CUT_OFF;
173 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
174 { err_printf("\n+++ Error %s: ", errcode(code));
175 /*
176 * There is now some painful shuffling around to get all the args
177 * to error() moved over onto the Lisp stack so that is garbage collection
178 * is triggered during printing all will be well.
179 */
180 va_start(a, code);
181 for (i=0; i<nargs; i++) *w++ = va_arg(a, Lisp_Object);
182 va_end(a);
183 for (i=0; i<nargs; i++) push(*--w);
184 if (code != err_stack_overflow) /* Be cautious here! */
185 { stackcheck0(nargs);
186 }
187 for (i=0; i<nargs; i++)
188 { Lisp_Object p;
189 pop(p);
190 loop_print_error(p);
191 err_printf("\n");
192 }
193 }
194 if ((w1 = qvalue(break_function)) != nil &&
195 symbolp(w1) &&
196 qfn1(w1) != undefined1)
197 { (*qfn1(w1))(qenv(w1), nil);
198 ignore_exception();
199 }
200 /*
201 * After doing this is is necessary to be VERY careful, since nil is
202 * used as a base register for lots of things... Still this is the
203 * cheapest way I can see to mark the need for unwinding.
204 */
205 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
206 UNWIND_UNWIND;
207 exit_value = exit_tag = nil;
208 exit_count = 0;
209 flip_exception();
210 return nil;
211 }
212
cerror(int nargs,int code1,int code2,...)213 Lisp_Object MS_CDECL cerror(int nargs, int code1, int code2, ...)
214 /*
215 * nargs indicated the number of EXTRA args after code1 & code2.
216 */
217 {
218 Lisp_Object nil = C_nil, w1;
219 va_list a;
220 int i;
221 Lisp_Object *w = (Lisp_Object *)&work_1;
222 if (nargs > ARG_CUT_OFF) nargs = ARG_CUT_OFF;
223 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
224 { err_printf("\n+++ Error %s, %s: ", errcode(code1), errcode(code2));
225 va_start(a, code2);
226 for (i=0; i<nargs; i++) *w++ = va_arg(a, Lisp_Object);
227 va_end(a);
228 for (i=0; i<nargs; i++) push(*--w);
229 stackcheck0(nargs-2);
230 nil = C_nil;
231 for (i=0; i<nargs; i++)
232 { Lisp_Object p;
233 pop(p);
234 loop_print_error(p);
235 err_printf("\n");
236 }
237 }
238 if ((w1 = qvalue(break_function)) != nil &&
239 symbolp(w1) &&
240 qfn1(w1) != undefined1)
241 { (*qfn1(w1))(qenv(w1), nil);
242 ignore_exception();
243 }
244 /*
245 * After doing this is is necessary to be VERY careful, since nil is
246 * used as a base register for lots of things... Still this is the
247 * cheapest way I can see to mark the need for unwinding.
248 */
249 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
250 UNWIND_UNWIND;
251 exit_value = exit_tag = nil;
252 exit_count = 0;
253 flip_exception();
254 return nil;
255 }
256
257 /*
258 * This can be used when a resource expires...
259 */
resource_exceeded()260 Lisp_Object resource_exceeded()
261 {
262 Lisp_Object nil = C_nil;
263 exit_reason = UNWIND_RESOURCE;
264 exit_value = exit_tag = nil;
265 exit_count = 0;
266 flip_exception();
267 return nil;
268 }
269
interrupted(Lisp_Object p)270 Lisp_Object interrupted(Lisp_Object p)
271 /*
272 * Could return onevalue(p) to proceed from the interrupt event...
273 */
274 {
275 Lisp_Object nil = C_nil, w;
276 /*
277 * If I have a windowed system I expect that the mechanism for
278 * raising an exception will have had a menu that gave me a chance
279 * to decide whether to proceed or abort. Thus the following code
280 * is only needed if there is no window system active. On some systems
281 * this may be an active check.
282 */
283 #ifdef HAVE_FWIN
284 if ((fwin_windowmode() & FWIN_IN_WINDOW) == 0)
285 #else
286 #if defined WINDOW_SYSTEM && !defined EMBEDDED
287 if (!use_wimp)
288 #endif
289 #endif
290 {
291 if (clock_stack == &consolidated_time[0])
292 { clock_t t0 = read_clock();
293 /*
294 * On at least some (Unix) systems clock_t is a 32-bit signed value
295 * and CLOCKS_PER_SEC = 1000000. The effect is that integer overflow
296 * occurs after around 35 minutes of running. I must therefore check the
297 * clock and move information into a floating point variable at least
298 * every half-hour. With luck I will do it more like 20 times per second
299 * because I have code muck like this in a tick handler that is activated
300 * on a rather regular basis on at least some systems. On others this
301 * clock overfow issue is a bit of a pain and I really ought just to use
302 * a different low-level API for timing that can not so suffer. But
303 * as a bit of a fall-back I will see if the garbage collector can
304 * consolidate time for me and since I ignore time spent waiting for the
305 * keyboard overflows due to 35 minutes of activity there will not hurt so
306 * I am probably at worst at risk if I can compute for a solid half
307 * hour without triggering garbage collection.
308 */
309 double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
310 base_time = t0;
311 consolidated_time[0] += delta;
312 }
313 #ifndef NAG
314 #ifdef HAVE_FWIN
315 term_printf("\n");
316 #else
317 term_printf(
318 "\n+++ [%.2f+%.2f] Type C to continue, A to abort, X to exit\n",
319 consolidated_time[0], gc_time);
320 #endif
321 ensure_screen(); nil = C_nil;
322 if (exception_pending()) return nil;
323 push(prompt_thing);
324 prompt_thing = CHAR_EOF;
325 #ifdef HAVE_FWIN
326 fwin_set_prompt("+++ Type C to continue, A to abort, X to exit: ");
327 #endif
328
329 other_read_action(READ_FLUSH, lisp_terminal_io);
330 for (;;)
331 { int c = char_from_terminal(nil);
332 /*
333 * Note that I explicitly say "char_from_terminal()" here - this is because
334 * I do not expect to be interrupted unless there was a terminal available
335 * to send the interrupt! This is in fact a slightly marginal assumption.
336 */
337 switch (c)
338 {
339 case 'c': case 'C': /* proceed as if no interrupt */
340 pop(prompt_thing);
341 #ifdef HAVE_FWIN
342 fwin_set_prompt(prompt_string);
343 #endif
344 return onevalue(p);
345 case 'a': case 'A': /* raise an exception */
346 break;
347 case 'x': case 'X':
348 my_exit(EXIT_FAILURE); /* Rather abrupt */
349 case '\n':
350 #ifndef HAVE_FWIN
351 term_printf("C to continue, A to abort, X to exit: ");
352 #endif
353 ensure_screen(); nil = C_nil;
354 if (exception_pending()) return nil;
355 continue;
356 default: /* wait for A or C */
357 continue;
358 }
359 break;
360 }
361 pop(prompt_thing);
362 #ifdef HAVE_FWIN
363 fwin_set_prompt(prompt_string);
364 #endif
365 #endif
366 }
367 /*
368 * now for the common code to be used in all cases.
369 */
370 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
371 err_printf("+++ Interrupted\n");
372 if ((w = qvalue(break_function)) != nil &&
373 symbolp(w) &&
374 qfn1(w) != undefined1)
375 { (*qfn1(w))(qenv(w), nil);
376 ignore_exception();
377 }
378 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
379 UNWIND_UNWIND;
380 exit_value = exit_tag = nil;
381 exit_count = 0;
382 flip_exception();
383 return nil;
384 }
385
aerror(char * s)386 Lisp_Object aerror(char *s)
387 {
388 Lisp_Object nil = C_nil, w;
389 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
390 err_printf("+++ Error bad args for %s\n", s);
391 if ((w = qvalue(break_function)) != nil &&
392 symbolp(w) &&
393 qfn1(w) != undefined1)
394 { (*qfn1(w))(qenv(w), nil);
395 ignore_exception();
396 }
397 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
398 UNWIND_UNWIND;
399 exit_value = exit_tag = nil;
400 exit_count = 0;
401 flip_exception();
402 return nil;
403 }
404
aerror0(char * s)405 Lisp_Object aerror0(char *s)
406 {
407 Lisp_Object nil = C_nil, w;
408 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
409 err_printf("+++ Error: %s\n", s);
410 if ((w = qvalue(break_function)) != nil &&
411 symbolp(w) &&
412 qfn1(w) != undefined1)
413 { (*qfn1(w))(qenv(w), nil);
414 ignore_exception();
415 }
416 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
417 UNWIND_UNWIND;
418 exit_value = exit_tag = nil;
419 exit_count = 0;
420 flip_exception();
421 #ifdef COMMON
422 /*
423 * This is to help me debug in the face of low level system crashes
424 */
425 if (spool_file) fflush(spool_file);
426 #endif
427 return nil;
428 }
429
aerror1(char * s,Lisp_Object a)430 Lisp_Object aerror1(char *s, Lisp_Object a)
431 {
432 Lisp_Object nil = C_nil, w;
433 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
434 { err_printf("+++ Error: %s ", s);
435 loop_print_error(a);
436 err_printf("\n");
437 }
438 if ((w = qvalue(break_function)) != nil &&
439 symbolp(w) &&
440 qfn1(w) != undefined1)
441 { (*qfn1(w))(qenv(w), nil);
442 ignore_exception();
443 }
444 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
445 UNWIND_UNWIND;
446 exit_value = exit_tag = nil;
447 exit_count = 0;
448 flip_exception();
449 #ifdef COMMON
450 /*
451 * This is to help me debug in the face of low level system crashes
452 */
453 if (spool_file) fflush(spool_file);
454 #endif
455 return nil;
456 }
457
aerror2(char * s,Lisp_Object a,Lisp_Object b)458 Lisp_Object aerror2(char *s, Lisp_Object a, Lisp_Object b)
459 {
460 Lisp_Object nil = C_nil, w;
461 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
462 { err_printf("+++ Error: %s ", s);
463 loop_print_error(a);
464 err_printf(" ");
465 loop_print_error(b);
466 err_printf("\n");
467 }
468 if ((w = qvalue(break_function)) != nil &&
469 symbolp(w) &&
470 qfn1(w) != undefined1)
471 { (*qfn1(w))(qenv(w), nil);
472 ignore_exception();
473 }
474 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
475 UNWIND_UNWIND;
476 exit_value = exit_tag = nil;
477 exit_count = 0;
478 flip_exception();
479 #ifdef COMMON
480 /*
481 * This is to help me debug in the face of low level system crashes
482 */
483 if (spool_file) fflush(spool_file);
484 #endif
485 return nil;
486 }
487
wrong(int wanted,int given,Lisp_Object env)488 static Lisp_Object wrong(int wanted, int given, Lisp_Object env)
489 {
490 char msg[64];
491 Lisp_Object nil = C_nil;
492 CSL_IGNORE(nil);
493 sprintf(msg, "Function called with %d args where %d wanted", given, wanted);
494 if (is_cons(env)) env = qcdr(env);
495 if ((miscflags & (HEADLINE_FLAG|ALWAYS_NOISY)) && is_vector(env))
496 { Lisp_Object fname = elt(env, 0);
497 err_printf("\nCalling ");
498 loop_print_error(fname);
499 err_printf("\n");
500 }
501 return aerror(msg);
502 }
503
too_few_2(Lisp_Object env,Lisp_Object a1)504 Lisp_Object too_few_2(Lisp_Object env, Lisp_Object a1)
505 {
506 CSL_IGNORE(a1);
507 return wrong(2, 1, env);
508 }
509
too_many_1(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)510 Lisp_Object too_many_1(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
511 {
512 CSL_IGNORE(a1);
513 CSL_IGNORE(a2);
514 return wrong(1, 2, env);
515 }
516
wrong_no_0a(Lisp_Object env,Lisp_Object a1)517 Lisp_Object wrong_no_0a(Lisp_Object env, Lisp_Object a1)
518 {
519 CSL_IGNORE(a1);
520 return wrong(0, 1, env);
521 }
522
wrong_no_0b(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)523 Lisp_Object wrong_no_0b(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
524 {
525 CSL_IGNORE(a1);
526 CSL_IGNORE(a2);
527 return wrong(0, 2, env);
528 }
529
wrong_no_3a(Lisp_Object env,Lisp_Object a1)530 Lisp_Object wrong_no_3a(Lisp_Object env, Lisp_Object a1)
531 {
532 CSL_IGNORE(a1);
533 return wrong(3, 1, env);
534 }
535
wrong_no_3b(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)536 Lisp_Object wrong_no_3b(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
537 {
538 CSL_IGNORE(a1);
539 CSL_IGNORE(a2);
540 return wrong(3, 2, env);
541 }
542
wrong_no_na(Lisp_Object env,Lisp_Object a1)543 Lisp_Object wrong_no_na(Lisp_Object env, Lisp_Object a1)
544 {
545 CSL_IGNORE(a1);
546 if (is_cons(env) && is_bps(qcar(env)))
547 return wrong(((unsigned char *)data_of_bps(qcar(env)))[0], 1, env);
548 else return aerror("function called with 1 arg when 0 or >= 3 wanted");
549 }
550
wrong_no_nb(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)551 Lisp_Object wrong_no_nb(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
552 {
553 CSL_IGNORE(a1);
554 CSL_IGNORE(a2);
555 if (is_cons(env) && is_bps(qcar(env)))
556 return wrong(((unsigned char *)data_of_bps(qcar(env)))[0], 2, env);
557 else return aerror("function called with 2 args when 0 or >= 3 wanted");
558 }
559
wrong_no_1(Lisp_Object env,int nargs,...)560 Lisp_Object MS_CDECL wrong_no_1(Lisp_Object env, int nargs, ...)
561 {
562 CSL_IGNORE(env);
563 CSL_IGNORE(nargs);
564 return wrong(1, nargs, env);
565 }
566
wrong_no_2(Lisp_Object env,int nargs,...)567 Lisp_Object MS_CDECL wrong_no_2(Lisp_Object env, int nargs, ...)
568 {
569 CSL_IGNORE(env);
570 CSL_IGNORE(nargs);
571 return wrong(2, nargs, env);
572 }
573
bad_special2(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)574 Lisp_Object bad_special2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
575 {
576 CSL_IGNORE(env);
577 CSL_IGNORE(a1);
578 CSL_IGNORE(a2);
579 return aerror("call to special form");
580 }
581
bad_specialn(Lisp_Object env,int nargs,...)582 Lisp_Object MS_CDECL bad_specialn(Lisp_Object env, int nargs, ...)
583 {
584 CSL_IGNORE(env);
585 CSL_IGNORE(nargs);
586 return aerror("call to special form");
587 }
588
fatal_error(int code,...)589 void MS_CDECL fatal_error(int code, ...)
590 {
591 /*
592 * Note that FATAL error messages are sent to the terminal, not to the
593 * error output stream. This is because the error output stream may be
594 * corrupted in such dire circumstances.
595 */
596 term_printf("+++ Fatal error %s\n", errcode(code));
597 if (spool_file != NULL)
598 {
599 #ifdef COMMON
600 fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name);
601 #else
602 fprintf(spool_file, "\n+++ Transcript terminated after error +++\n");
603 #endif
604 fclose(spool_file);
605 spool_file = NULL;
606 }
607 my_exit(EXIT_FAILURE);
608 }
609
610 static char *dependency_file = NULL;
611
612 static char **dependency_map = NULL;
613 static int dependency_count = 0, dependency_capacity = 0;
614
report_file(const char * s)615 void report_file(const char *s)
616 {
617 char *c;
618 int i;
619 if (dependency_file == NULL) return;
620 if (dependency_count >= dependency_capacity)
621 { dependency_capacity = 2*dependency_capacity + 40;
622 dependency_map = (char **)realloc(dependency_map,
623 dependency_capacity*sizeof(char *));
624 if (dependency_map == NULL)
625 { dependency_capacity = dependency_count = 0;
626 return;
627 }
628 }
629 for (i=0; i<dependency_count; i++)
630 { if (strcmp(s, dependency_map[i]) == 0) return; /* already recorded */
631 }
632 c = (char *)malloc(strlen(s) + 1);
633 if (c == NULL) return;
634 strcpy(c, s);
635 dependency_map[dependency_count++] = c;
636 }
637
alphorder(const void * a,const void * b)638 static int alphorder(const void *a, const void *b)
639 {
640 char *aa = *(char **)a;
641 char *bb = *(char **)b;
642 return strcmp(aa, bb);
643 }
644
report_dependencies()645 static void report_dependencies()
646 {
647 FILE *f;
648 int i, c;
649 char *p;
650 if (dependency_file == NULL) return;
651 f = fopen(dependency_file, "w");
652 if (f == NULL) return;
653 p = strrchr(dependency_file, '.');
654 fprintf(f, "%.*sdep = \\\n", (int)(p==NULL ? strlen(dependency_file) :
655 (p - dependency_file)),
656 dependency_file);
657 qsort(dependency_map, dependency_count,
658 sizeof(char *), alphorder);
659 for (i=0; i<dependency_count; i++)
660 { p = dependency_map[i];
661 putc('\t', f);
662 /*
663 * If I am on Windows some files may at this stage be shown with names
664 * of the form "X:/..." where X denotes the drive. But the dependencies I
665 * am creating are for the benefit of the cygwin version of GNU make, and
666 * that will get seriously upset by the colon, thinking it is indicating that
667 * I have multiple targets. So I will map "X:/" onto "/cygdrive/x/".
668 */
669 if (p[0] != 0 &&
670 p[1] == ':' &&
671 (p[2] == '/' || p[2] == '\\'))
672 { fprintf(f, "/cygdrive/%c", p[0]);
673 p+=2;
674 }
675 while ((c = *p++) != 0) putc(c == '\\' ? '/' : c, f);
676 if (i < dependency_count-1)
677 { putc(' ', f);
678 putc('\\', f);
679 }
680 putc('\n', f);
681 }
682 putc('\n', f);
683 fclose(f);
684 dependency_file = NULL;
685 }
686
687 #ifndef __cplusplus
688 #ifdef USE_SIGALTSTACK
689 sigjmp_buf my_exit_buffer;
690 #else
691 jmp_buf my_exit_buffer;
692 #endif
693 volatile int my_return_code = 0;
694 #endif
695
my_exit(int n)696 void my_exit(int n)
697 {
698 /*
699 * This all seems a HORRID MESS. It is here because of a general need to
700 * tidy up at the end of a run, and the fact that I may be running as
701 * a sub-task of some other package so I can not let atexit() take the
702 * strain since although I am exiting CSL here I may not be (quite yet)
703 * leaving the whole of the current application.
704 */
705 report_dependencies();
706 #ifdef USE_MPI
707 MPI_Finalize();
708 #endif
709 ensure_screen();
710 #ifdef SOCKETS
711 if (sockets_ready) WSACleanup();
712 #endif
713 #ifdef WINDOW_SYSTEM
714 pause_for_user();
715 #endif
716 #ifdef HAVE_FWIN
717 #ifdef __cplusplus
718 throw n;
719 #else
720 /*
721 * When I am compiling in C I will be ultra-cautions and only ever use
722 * "1" as the second argument to longjmp. Here, which is the only place
723 * where I want to hand back a value I might (often!) want to hand back the
724 * value "0", so I put it in a static variable (and make that volatile to
725 * help it survive setjmp/longjmp). Doing things this was is also a valuable
726 * temporary expedient for the 64-bit variant on mingw at a stage where that
727 * is not fully settled!
728 */
729 my_return_code = n;
730 #ifdef USE_SIGALTSTACK
731 siglongjmp(my_exit_buffer, 1);
732 #else
733 longjmp(my_exit_buffer, 1);
734 #endif
735 #endif
736 #else
737 #if defined(WIN32) && defined(NAG)
738 { extern void sys_abort(int);
739 sys_abort(n);
740 }
741 #else
742 exit(n);
743 #endif
744 #endif
745 }
746
747 static int return_code = 0;
748 CSLbool segvtrap = YES;
749 CSLbool batch_flag = NO;
750 CSLbool ignore_restart_fn = NO;
751
752 #ifdef USE_SIGALTSTACK
753
754 static unsigned char signal_stack_block[SIGSTKSZ];
755
756 stack_t signal_stack;
757
758 #endif
759
lisp_main(void)760 static void lisp_main(void)
761 {
762 Lisp_Object nil;
763 int i;
764 #ifdef USE_SIGALTSTACK
765 /*
766 * If I get a SIGSEGV that is caused by a stack overflow then I am in
767 * a world of pain because the regular stack does not have space to run my
768 * exception handler. So where I can I will arrange that the exception
769 * handler runs in its own small stack. This may itself lead to pain,
770 * but perhaps less?
771 */
772 signal_stack.ss_sp = (void *)signal_stack_block;
773 signal_stack.ss_size = SIGSTKSZ;
774 signal_stack.ss_flags = 0;
775 sigaltstack(&signal_stack, (stack_t *)0);
776 #endif
777 #ifndef __cplusplus
778 /*
779 * The setjmp here is to provide a long-stop for untrapped
780 * floating point exceptions.
781 */
782 #ifdef USE_SIGALTSTACK
783 sigjmp_buf this_level, *save_level = errorset_buffer;
784 #else
785 jmp_buf this_level, *save_level = errorset_buffer;
786 #endif
787 #endif
788 tty_count = 0;
789 while (YES)
790 /*
791 * The sole purpose of the while loop here is to allow me to proceed
792 * for a second try if I get a (cold-start) call.
793 */
794 { Lisp_Object *save = stack;
795 nil = C_nil;
796 #ifndef __cplusplus
797 errorset_buffer = &this_level;
798 #endif
799 errorset_msg = NULL;
800 #ifdef __cplusplus
801 try
802 #else
803 #ifdef USE_SIGALTSTACK
804 if (!sigsetjmp(this_level, -1))
805 #else
806 if (!setjmp(this_level))
807 #endif
808 #endif
809 { nil = C_nil;
810 terminal_pushed = NOT_CHAR;
811 if (supervisor != nil && !ignore_restart_fn)
812 { miscflags |= HEADLINE_FLAG | MESSAGES_FLAG;
813 /*
814 * Here I reconstruct the argument that I passed in (restart_csl f a).
815 */
816 if (exit_charvec != NULL)
817 { Lisp_Object a = read_from_vector(exit_charvec);
818 nil = C_nil;
819 if (exception_pending())
820 { flip_exception();
821 a = nil;
822 }
823 free(exit_charvec);
824 exit_charvec = NULL;
825 push(a);
826 apply(supervisor, 1, nil, supervisor);
827 }
828 else apply(supervisor, 0, nil, supervisor);
829 }
830 /*
831 * Here the default read-eval-print loop used if the user has not provided
832 * a supervisor function.
833 */
834 else read_eval_print(lisp_true);
835 }
836 #ifdef __cplusplus
837 catch (char *)
838 #else
839 else
840 #endif
841 { nil = C_nil;
842 if (errorset_msg != NULL)
843 { term_printf("\n%s detected\n", errorset_msg);
844 errorset_msg = NULL;
845 }
846 unwind_stack(save, NO);
847 exit_reason = UNWIND_ERROR;
848 flip_exception();
849 #ifndef UNDER_CE
850 signal(SIGFPE, low_level_signal_handler);
851 #ifdef USE_SIGALTSTACK
852 /* SIGSEGV will be handled on the alternative stack */
853 { struct sigaction sa;
854 sa.sa_handler = low_level_signal_handler;
855 sigemptyset(&sa.sa_mask);
856 sa.sa_flags = SA_ONSTACK | SA_RESETHAND;
857 if (segvtrap) sigaction(SIGSEGV, &sa, NULL);
858 }
859 #else
860 if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
861 #endif
862 #ifdef SIGBUS
863 if (segvtrap) signal(SIGBUS, low_level_signal_handler);
864 #endif
865 #ifdef SIGILL
866 if (segvtrap) signal(SIGILL, low_level_signal_handler);
867 #endif
868 #endif
869 }
870 nil = C_nil;
871 if (exception_pending())
872 { flip_exception();
873 if (exit_reason == UNWIND_RESTART)
874 { if (exit_tag == fixnum_of_int(0)) /* "stop" */
875 return_code = (int)int_of_fixnum(exit_value);
876 else if (exit_tag == fixnum_of_int(1)) /* "preserve" */
877 { char *msg = "";
878 int len = 0;
879 return_code = EXIT_SUCCESS;
880 compression_worth_while = 128;
881 if (is_vector(exit_value) &&
882 type_of_header(vechdr(exit_value)) == TYPE_STRING)
883 { msg = &celt(exit_value, 0);
884 len = (int)(length_of_header(vechdr(exit_value)) - CELL);
885 }
886 preserve(msg, len);
887 nil = C_nil;
888 if (exception_pending())
889 { flip_exception();
890 return_code = EXIT_FAILURE;
891 }
892 }
893 else /* "restart" */
894 { int32_t fd = stream_pushed_char(lisp_terminal_io);
895
896 char new_module[64], new_fn[64]; /* Limited name length */
897 int cold_start;
898 cold_start = (exit_value == nil);
899 /*
900 * Of course a tick may very well have happened rather recently - so
901 * I will flush it out now just to clear the air.
902 */
903 if (stack >= stacklimit)
904 { reclaim(nil, "stack", GC_STACK, 0);
905 ignore_exception();
906 }
907 cold_start = (exit_value == nil);
908 Lrds(nil, nil);
909 Lwrs(nil, nil);
910 /*
911 * If either of the above two calls to rds/wrs were to fail I would
912 * be in a big mess.
913 */
914 if (!cold_start)
915 { new_module[0] = 0;
916 new_fn[0] = 0;
917 if (exit_value != lisp_true)
918 { Lisp_Object modname = nil;
919 if (is_cons(exit_value))
920 { modname = qcar(exit_value);
921 exit_value = qcdr(exit_value);
922 if (is_cons(exit_value))
923 exit_value = qcar(exit_value);
924 }
925 if (symbolp(modname) && modname != nil)
926 { modname = get_pname(modname);
927 if (exception_pending()) ignore_exception();
928 else
929 { Header h = vechdr(modname);
930 int32_t len = length_of_header(h) - CELL;
931 if (len > 63) len = 63;
932 memcpy(new_module,
933 (char *)modname + (CELL - TAG_VECTOR),
934 (size_t)len);
935 new_module[len] = 0;
936 }
937 }
938 if (symbolp(exit_value) && exit_value != nil)
939 { exit_value = get_pname(exit_value);
940 if (exception_pending()) ignore_exception();
941 else
942 { Header h = vechdr(exit_value);
943 int32_t len = length_of_header(h) - CELL;
944 if (len > 63) len = 63;
945 memcpy(new_fn,
946 (char *)exit_value + (CELL - TAG_VECTOR),
947 (size_t)len);
948 new_fn[len] = 0;
949 }
950 }
951 }
952 }
953 /*
954 * This puts all recorded heap pages back in the main pool, but there is
955 * as of March 2010 a concern in the case that an initial heap image came
956 * from a 32-bit machine and I am now running on a 64-bit one. That concerns
957 * both extra pages allocated at the first startup to give the effect of
958 * temporarily double-sized pages (there is a space leak there that may
959 * lose all those pages!) and the expectation there that pages in the map
960 * are neatly contiguous in memory (and when returned to the pool here that
961 * expectation usually fails). Oh dear!
962 * As a rather grungy recovery what I will do is to recycle all of the
963 * pages that are NOT in the contiguous chunk and then re-create a neat
964 * map of contiguous space from the bits that are. So first I must remove
965 * any contiguous pages from the list of ones marked as free...
966 */
967 for (i=0; i<pages_count; i++)
968 { char *w = (char *)pages[i];
969 if (!(w > big_chunk_start && w <= big_chunk_end))
970 continue;
971 /*
972 * Here the page shown as free is one in the contiguous block. Move in
973 * the final page to fill the gap here and try again.
974 */
975 pages[i] = pages[--pages_count];
976 i--;
977 }
978 /*
979 * Next recycle all the non-contiguous pages that have been in use.
980 */
981 while (vheap_pages_count != 0)
982 { char *w = (char *)vheap_pages[--vheap_pages_count];
983 if (!(w > big_chunk_start && w <= big_chunk_end))
984 pages[pages_count++] = w;
985 }
986 while (heap_pages_count != 0)
987 { char *w = (char *)heap_pages[--heap_pages_count];
988 if (!(w > big_chunk_start && w <= big_chunk_end))
989 pages[pages_count++] = w;
990 }
991 while (bps_pages_count != 0)
992 { char *w = (char *)bps_pages[--bps_pages_count];
993 if (!(w > big_chunk_start && w <= big_chunk_end))
994 pages[pages_count++] = w;
995 }
996 /*
997 * Finally rebuild a contiguous block of pages from the wholesale block.
998 */
999 { char *w = big_chunk_start + NIL_SEGMENT_SIZE;
1000 char *w1 = w + CSL_PAGE_SIZE + 16;
1001 while (w1 <= big_chunk_end)
1002 { if (w != (char *)stacksegment)
1003 pages[pages_count++] = w;
1004 w = w1;
1005 w1 = w + CSL_PAGE_SIZE + 16;
1006 }
1007 }
1008 /*
1009 * When I call restart-csl I will leave the random number generator where it
1010 * was. Anybody who wants to reset if either to a freshly randomised
1011 * configuration or to a defined condition must do so for themselves. For
1012 * people who do not care too much what I do here is probably acceptable!
1013 */
1014 CSL_MD5_Init();
1015 CSL_MD5_Update((unsigned char *)"Initial State", 13);
1016 IreInit();
1017 setup(cold_start ? 0 : 1, 0.0);
1018 exit_tag = exit_value = nil;
1019 exit_reason = UNWIND_NULL;
1020 stream_pushed_char(lisp_terminal_io) = fd;
1021 interrupt_pending = already_in_gc = NO;
1022 tick_pending = tick_on_gc_exit = NO;
1023 if (!cold_start && new_fn[0] != 0)
1024 { Lisp_Object w;
1025 if (new_module[0] != 0)
1026 { w = make_undefined_symbol(new_module);
1027 Lload_module(nil, w);
1028 ignore_exception();
1029 }
1030 w = make_undefined_symbol(new_fn);
1031 nil = C_nil;
1032 if (exception_pending()) ignore_exception();
1033 else supervisor = w;
1034 }
1035 continue;
1036 }
1037 }
1038 }
1039 /*
1040 * In all normal cases when read_eval_print exits (i.e. all cases except
1041 * if it terminates after (cold-start)) I exit here.
1042 */
1043 #ifndef __cplusplus
1044 errorset_buffer = save_level;
1045 #endif
1046 break;
1047 }
1048 }
1049
1050 #if !defined HAVE_FWIN || defined EMBEDDED
1051 #ifndef UNDER_CE
1052
1053 CSLbool sigint_must_longjmp = NO;
1054 #ifndef __cplusplus
1055 #ifdef USE_SIGALTSTACK
1056 sigjmp_buf sigint_buf;
1057 #else
1058 jmp_buf sigint_buf;
1059 #endif
1060 #endif
1061
sigint_handler(int code)1062 void sigint_handler(int code)
1063 {
1064 /*
1065 * Note that the only things that I am really allowed to do in a routine
1066 * like this involve setting variables of type sig_atomic_t, which can not
1067 * be viewed as much more than boolean. The code actually used here is
1068 * somewhat more ambitious (== non-portable!) so must be viewed as delicate.
1069 * ANSI guarantee that longjmp-ing out of a non-nested signal handler
1070 * is valid, but some earlier C libraries have not supported this. Note that
1071 * with C++ I will use throw rather than longjmp.
1072 */
1073 /*
1074 * tick_pending etc allow a steady stream of clock events to
1075 * be handed to Lisp.
1076 */
1077 interrupt_pending = 1;
1078 signal(SIGINT, sigint_handler);
1079 if (sigint_must_longjmp)
1080 {
1081 sigint_must_longjmp = NO;
1082 #ifdef __cplusplus
1083 throw((int *)0);
1084 #else
1085 #ifdef USE_SIGALTSTACK
1086 siglongjmp(sigint_buf, 1);
1087 #else
1088 longjmp(sigint_buf, 1);
1089 #endif
1090 #endif
1091 }
1092 /*
1093 * If there is not a separate regular stream of ticks I will simulate
1094 * the receipt of a tick here. Thus I need to be able to recognize "ticks"
1095 * even on systems where there are no "real" ones.
1096 */
1097 if (!tick_pending)
1098 {
1099 if (already_in_gc) tick_on_gc_exit = YES;
1100 else
1101 {
1102 #ifndef NILSEG_EXTERNS
1103 Lisp_Object nil = C_nil;
1104 CSLbool xxx = NO;
1105 if (exception_pending()) flip_exception(), xxx = YES;
1106 #endif
1107 tick_pending = YES;
1108 saveheaplimit = heaplimit;
1109 heaplimit = fringe;
1110 savevheaplimit = vheaplimit;
1111 vheaplimit = vfringe;
1112 savecodelimit = codelimit;
1113 codelimit = codefringe;
1114 savestacklimit = stacklimit;
1115 stacklimit = stackbase;
1116 #ifndef NILSEG_EXTERNS
1117 if (xxx) flip_exception();
1118 #endif
1119 }
1120 }
1121 return;
1122 }
1123
1124 #endif /* UNDER_CE */
1125 #endif /* HAVE_FWIN */
1126
1127 /*
1128 * OK, I need to write a short essay on "software ticks". A major issue
1129 * for me is synchronization between the worker and the GUI tasks. Lisp
1130 * code can not easily be unilaterally interrupted since it needs to
1131 * preserve GC safety. The easiest way of making progress that I have come up
1132 * with is to arrange that the worker thead (ie the Lisp engine) arranges
1133 * to poll the GUI on a fairly regular basis. I achieve this by making it
1134 * count down in a variable called "countdown" and when that reaches zero
1135 * it deems that a poll is due. I put instructions to decrement countdown in
1136 * a number of places that I expect to be used often enough, and would like
1137 * to have these within all possible loops and such that they are performed
1138 * uniformly over time. These are IDEALS not reality! The countdown overflow
1139 * may happen at somewhat irregular intervals and often at places in the
1140 * code where I am not GC safe. So what I do is to set heap fringes and
1141 * stack fringes so that the next time I try to allocate memory or check
1142 * the stack the situation is noticed and I enter the GC. Once there I
1143 * rapidly detect that this is not a genuine case of having run out of
1144 * memory so I do not do a full GC: I just reset the varios fringes and
1145 * proceed. But while there I know I am in a tidy situation and I can
1146 * exchange information with the GUI. Perhaps as clear-cut case of
1147 * consequence that can arise is that I may respond to a GUI request to
1148 * interrupt what I was doing.
1149 * I try to tune the value that I count down from to get a rate of polling
1150 * that I count as "reasonable" - ie a few per second.
1151 *
1152 * deal_with_tick() is called when the countdown overflows. It resets the
1153 * fringe variables to provoke a GC.
1154 *
1155 * handle_tick() is then a call back out from the GC and could do more
1156 * as required.
1157 */
1158
1159 int32_t software_ticks = 3000;
1160 int32_t number_of_ticks = 0;
1161 int32_t countdown = 3000;
1162
deal_with_tick(void)1163 int deal_with_tick(void)
1164 {
1165 #ifdef PENDING_TICK_SUPPORT
1166 printf("(!)"); fflush(stdout);
1167 number_of_ticks++;
1168 if (!tick_pending)
1169 {
1170 if (already_in_gc) tick_on_gc_exit = YES;
1171 else
1172 {
1173 #ifndef NILSEG_EXTERNS
1174 Lisp_Object nil = C_nil;
1175 CSLbool xxx = NO;
1176 if (exception_pending()) flip_exception(), xxx = YES;
1177 #endif
1178 tick_pending = YES;
1179 saveheaplimit = heaplimit;
1180 heaplimit = fringe;
1181 savevheaplimit = vheaplimit;
1182 vheaplimit = vfringe;
1183 savecodelimit = codelimit;
1184 codelimit = codefringe;
1185 savestacklimit = stacklimit;
1186 stacklimit = stackbase;
1187 #ifndef NILSEG_EXTERNS
1188 if (xxx) flip_exception();
1189 #endif
1190 }
1191 }
1192 #endif
1193 countdown = software_ticks;
1194 return 1;
1195 }
1196
1197 static long int initial_random_seed, seed2;
1198
1199 char *files_to_read[MAX_INPUT_FILES],
1200 *symbols_to_define[MAX_SYMBOLS_TO_DEFINE],
1201 *fasl_paths[MAX_FASL_PATHS];
1202 int output_directory;
1203 character_reader *procedural_input;
1204 character_writer *procedural_output;
1205
1206 CSLbool undefine_this_one[MAX_SYMBOLS_TO_DEFINE];
1207
1208 int number_of_input_files = 0,
1209 number_of_symbols_to_define = 0,
1210 number_of_fasl_paths = 0,
1211 init_flags = 0;
1212
1213 #ifdef WINDOW_SYSTEM
1214 FILE *alternative_stdout = NULL;
1215 #endif
1216
1217 /*
1218 * standard_directory holds the name of the default image file that CSL
1219 * would load.
1220 */
1221 char *standard_directory;
1222
1223 /*
1224 * If non-NULL the string module_enquiry is a name presenetd on the
1225 * command line in a "-T name" request, and this will cause the system
1226 * to behave in a totally odd manner - it does not run Lisp at all but
1227 * performs a directory enquiry within the image file.
1228 */
1229 static char *module_enquiry = NULL;
1230
1231 /*
1232 * The next lines mean that (if you can get in before cslstart is
1233 * called) you can get memory allocation done in a custom way.
1234 */
1235
CSL_malloc(size_t n)1236 static void *CSL_malloc(size_t n)
1237 {
1238 return malloc(n);
1239 }
1240
CSL_free(void * p)1241 static void CSL_free(void *p)
1242 {
1243 free(p);
1244 }
1245
CSL_realloc(void * p,size_t n)1246 static void *CSL_realloc(void *p, size_t n)
1247 {
1248 return realloc(p, n);
1249 }
1250
1251 malloc_function *malloc_hook = CSL_malloc;
1252 realloc_function *realloc_hook = CSL_realloc;
1253 free_function *free_hook = CSL_free;
1254
1255 CSLbool always_noisy = NO;
1256
1257 int load_count = 0, load_limit = 0x7fffffff;
1258
cslstart(int argc,char * argv[],character_writer * wout)1259 void cslstart(int argc, char *argv[], character_writer *wout)
1260 {
1261 int i;
1262 CSLbool restartp;
1263 double store_size = 0.0;
1264 #ifdef CONSERVATIVE
1265 volatile Lisp_Object sp;
1266 C_stackbase = (Lisp_Object *)&sp;
1267 #endif
1268 #ifdef EMBEDDED
1269 fwin_set_lookup(look_in_lisp_variable);
1270 #endif
1271 always_noisy = NO;
1272 stack_segsize = 1;
1273 module_enquiry = NULL;
1274 countdown = 0x7fffffff;
1275 /* put resource limiting info in a tidy or at least safe state */
1276 time_base = space_base = io_base = errors_base = 0;
1277 time_now = space_now = io_now = errors_now = 0;
1278 time_limit = space_limit = io_limit = errors_limit = -1;
1279 /*
1280 * Note that I will set up clock_stack AGAIN later on! The one further down
1281 * happens after command line options have been decoded and is where I really
1282 * want to consider Lisp to be starting. The setting here is because
1283 * if I call ensure_screen() it can push and pop the clock stack, and
1284 * especially if I have an error in my options I may print to the terminal
1285 * and then flush it. Thus I need SOMETHING set up early to prevent any
1286 * possible frivolous disasters in that area.
1287 */
1288 base_time = read_clock();
1289 consolidated_time[0] = gc_time = 0.0;
1290 clock_stack = &consolidated_time[0];
1291 #if defined WINDOW_SYSTEM && !defined EMBEDDED
1292 use_wimp = YES;
1293 #endif
1294 #ifdef HAVE_FWIN
1295 /*
1296 * On fwin the "-w" flag should disable all attempts at use of the wimp.
1297 */
1298 for (i=1; i<argc; i++)
1299 { char *opt = argv[i];
1300 if (opt == NULL) continue;
1301 #if defined WINDOW_SYSTEM && !defined EMBEDDED
1302 if (opt[0] == '-' && tolower(opt[1] == 'w'))
1303 { use_wimp = !use_wimp;
1304 break;
1305 }
1306 #endif
1307 }
1308 fwin_pause_at_end = 1;
1309 #endif
1310 #ifdef SOCKETS
1311 sockets_ready = 0;
1312 socket_server = 0;
1313 #endif
1314 /*
1315 * Now that the window manager is active I can send output through
1316 * xx_printf() and get it on the screen neatly.
1317 */
1318 procedural_input = NULL;
1319 procedural_output = wout;
1320 standard_directory = find_image_directory(argc, argv);
1321 restartp = YES;
1322 ignore_restart_fn = NO;
1323 spool_file = NULL;
1324 spool_file_name[0] = 0;
1325 output_directory = 0x80000000;
1326 number_of_input_files = 0;
1327 number_of_symbols_to_define = 0;
1328 number_of_fasl_paths = 0;
1329 fasl_output_file = NO;
1330 initial_random_seed = seed2 = 0;
1331 init_flags = INIT_EXPANDABLE;
1332 return_code = EXIT_SUCCESS;
1333 segvtrap = YES;
1334 batch_flag = NO;
1335 load_count = 0;
1336 load_limit = 0x7fffffff;
1337
1338 CSL_MD5_Init();
1339 CSL_MD5_Update((unsigned char *)"Initial State", 13);
1340 #ifdef MEMORY_TRACE
1341 car_counter = 0x7fffffff;
1342 car_low = 0;
1343 car_high = 0xffffffff;
1344 #endif
1345
1346 argc--;
1347 for (i=1; i<=argc; i++)
1348 { char *opt = argv[i];
1349 /*
1350 * The next line ought never to be activated, but I have sometimes seen
1351 * unwanted NULL args on the end of command lines so I filter them out
1352 * here as a matter of security.
1353 */
1354 if (opt == NULL || *opt == 0) continue;
1355 /*
1356 * Note that I do not treat an isolated "-" as introducing an "option".
1357 * Instead it is treated as a file-name and it indicates the "standard"
1358 * input. There may be amusing consequences for using this several times
1359 * in one call, but I hope it will make sense in several sane cases.
1360 */
1361 if (opt[0] == '-' && opt[1] != 0)
1362 { char *w;
1363 int c1 = opt[1], c2 = opt[2];
1364 if (isupper(c1)) c1 = tolower(c1);
1365 switch (c1)
1366 {
1367
1368 /*
1369 * -- <outfile> arranges that output is sent to the indicated file. It is
1370 * intended to behave a little like "> outfile" as command-line output
1371 * redirection, but is for use in windowed environments (in particular
1372 * Windows NT) where this would not work. I had intended to use "->" here,
1373 * but then the ">" tends to get spotted as a command-line request for
1374 * redirection, and I would not be using this if command-line redirection
1375 * worked properly! Actually use of "--" here was a BAD choice since it
1376 * clashes with the tradition now common elsewhere that fully spelt-out
1377 * options can be written as "--option". To start to mend that I will
1378 * now make
1379 * -- filename
1380 * redirect the standard output, but detect
1381 * --option
1382 * as an extended option. This is, I guesss, an incompatible change to CSL's
1383 * behaviour but I rather believe it will be a good one to make and I can
1384 * issue a message about unrecognised options that will help anybody caught
1385 * by it.
1386 */
1387 case '-':
1388 if (c2 != 0)
1389 { w = &opt[2];
1390 /*
1391 * The option "--texmacs" has been detected earlier in fwin.c, so I just
1392 * detect and ignore it here.
1393 */
1394 if (strcmp(w, "texmacs") == 0)
1395 { }
1396 /*
1397 * "--help" will now try to produce a summary of command-line options. I
1398 * bet that anything I write will not really be enough, but here is a first
1399 * attempt!
1400 */
1401 else if (strcmp(w, "help") == 0)
1402 {
1403 /*
1404 * A comments here as a horrible warning. For dubious reasons term_printf
1405 * can ONLY cope when the output it generates is at most 256 bytes long.
1406 * Beyond that there can be an internal buffer overflow. Hence each line
1407 * of text here is printed as a separate call. If I was certain that
1408 * a vsnprintf function was ALWAYS available the interbal behaviour could
1409 * at least be a bit safer...
1410 */
1411 term_printf(
1412 "Options:\n");
1413 term_printf(
1414 "-a do not use. Flips meaning of the Lisp \"batchp\" function.\n");
1415 term_printf(
1416 "-b do not colour prompts. -bOIP sets colours for output,\n");
1417 term_printf(
1418 " input and prompt, using rgbcmyk\n");
1419 term_printf(
1420 " for Red, Green, Blue, Cyan etc.\n");
1421 term_printf(
1422 "-c display something that is not a Copyright statement (because of LGPL).\n");
1423 term_printf(
1424 "-d VVV or -d VVV=VVV define a Lisp symbol as the system start\n");
1425 term_printf(
1426 "-e enable some feature that is at present an experiment. Not for users!\n");
1427 term_printf(
1428 "-f or -f nnn listen on socket 1206 or nnn to run a remote session.\n");
1429 term_printf(
1430 " This option is not for normal users.\n");
1431 term_printf(
1432 "-g enable some options that help when debugging. You get backtraces.\n");
1433 term_printf(
1434 "-h on X windows this may use x-terminal fonts rather than ones\n");
1435 term_printf(
1436 " used via Xft that live with the application. Not recommended.\n");
1437 term_printf(
1438 "-i <image file> specific the location of the initial image file explicitly\n");
1439 term_printf(
1440 " You may have multiple image files, seached for modules in\n");
1441 term_printf(
1442 " the order listed.\n");
1443 term_printf(
1444 "-j used for depencency tracking. '-j fileuse.dat' notes what files\n");
1445 term_printf(
1446 " are accessed during this run in the indicated place.\n");
1447 term_printf(
1448 "-k nnnK or -knnnM or -knnnG suggest heap-size to use. Often not needed\n");
1449 term_printf(
1450 "-l logfile keep transcript of session for you.\n");
1451 term_printf(
1452 "-m a memory trace option not for ordinary use.\n");
1453 term_printf(
1454 "-n ignore the restart function in an image file so that the system.\n");
1455 term_printf(
1456 " starts up in raw Lisp. Sometimes useful if image file is broken.\n");
1457 term_printf(
1458 "-o <image file> specified where newly created compiled modules and\n");
1459 term_printf(
1460 " saved heap images should go. Default is in the standard image.\n");
1461 term_printf(
1462 "-p reserved for a potential profile option.\n");
1463 term_printf(
1464 "-q tend to be Quiet. see also -v.\n");
1465 term_printf(
1466 "-r nnn or -r nnn,mmm sets initial random seed. Passing 0 means use\n");
1467 term_printf(
1468 " current time of day and similar nonrepeatable stuff. May be\n");
1469 term_printf(
1470 " used to force repeatability of code that uses randomness.\n");
1471 term_printf(
1472 "-s causes compiler to display \"assembly code\".\n");
1473 term_printf(
1474 "-t modulename prints the timestamp of the given module and exits.\n");
1475 term_printf(
1476 "-u VVV undefines the Lisp symbol VVV at the start of the run.\n");
1477 term_printf(
1478 "-v runs in a slighly more verbose mode.\n");
1479 term_printf(
1480 "-w controls if code runs in a window or in console. Also -w+ and -w-\n");
1481 term_printf(
1482 " can override cases where the system really wants to go one way.\n");
1483 term_printf(
1484 "-x avoid trapping exceptions so you can use a low-level debugger\n");
1485 term_printf(
1486 " to sort out errors in the kernel.\n");
1487 term_printf(
1488 "-y At one stage this enabled Japanese character support. Not now\n");
1489 term_printf(
1490 " maintained.\n");
1491 term_printf(
1492 "-z when the code starts up it is just a basic raw Lisp core without\n");
1493 term_printf(
1494 " even a compiler. Used to bootstrap the system.\n");
1495 term_printf(
1496 "-- filename redirect output to the given file so it does not appear\n");
1497 term_printf(
1498 " on the screen.\n");
1499 term_printf(
1500 "--texmacs run in texmacs mode. You must use the plugin from the\n");
1501 term_printf(
1502 " cslbase/texmacs-plugin directory.\n");
1503 term_printf(
1504 "--<other> reserved for additional extended options.\n");
1505 term_printf(
1506 "--help this output!\n");
1507 my_exit(0);
1508 }
1509 else
1510 {
1511 fwin_restore();
1512 term_printf("Unknown extended option \"--%s\"\n", w);
1513 term_printf("NB: use \"-- filename\" (with whitespace)\n");
1514 term_printf(" for output redirection now.\n");
1515 }
1516 continue;
1517 }
1518 else if (i != argc) w = argv[++i];
1519 else break; /* Illegal at end of command-line */
1520 { char filename[LONGEST_LEGAL_FILENAME];
1521 FILE *f;
1522 #ifdef WINDOW_SYSTEM
1523 f = open_file(filename, w, strlen(w), "w", NULL);
1524 if (f == NULL)
1525 {
1526 /*
1527 * Under FWIN if there is a "--" among the arguments I will start off
1528 * with the main window minimized. Thus if an error is detected at a
1529 * stage that the transcript file is not properly opened I need to
1530 * maximize the window so I can see the error! Note that I will need to
1531 * ensure that fwin only uses "-- file" not "--option" to do this...
1532 */
1533 fwin_restore();
1534 term_printf("Unable to write to \"%s\"\n", filename);
1535 continue;
1536 }
1537 else
1538 { term_printf("Output redirected to \"%s\"\n",
1539 filename);
1540 }
1541 if (alternative_stdout != NULL)
1542 fclose(alternative_stdout);
1543 alternative_stdout = f;
1544 #else
1545 /*
1546 * I use freopen() on stdout here to get my output sent elsewhere. Quite
1547 * what sort of mess I am in if the freopen fails is hard to understand!
1548 * Thus I write a message to stderr and exit promptly in case of trouble.
1549 * I print a message explaining what I am doing BEFORE actually performing
1550 * the redirection.
1551 */
1552 fprintf(stderr, "Output to be redirected to \"%s\"\n", w);
1553 f = open_file(filename, w, strlen(w), "w", stdout);
1554 if (f == NULL)
1555 { fprintf(stderr, "Unable to write to \"%s\"\n",
1556 filename);
1557 #ifdef HAVE_FWIN
1558 #ifdef __cplusplus
1559 throw EXIT_FAILURE;
1560 #else
1561 my_return_code = EXIT_FAILURE;
1562 #ifdef USE_SIGALTSTACK
1563 siglongjmp(my_exit_buffer, 1);
1564 #else
1565 longjmp(my_exit_buffer, 1);
1566 #endif
1567 #endif
1568 #else
1569 exit(EXIT_FAILURE);
1570 #endif
1571 }
1572 #endif
1573 }
1574 continue;
1575
1576 /*
1577 * -a is a curious option, not intended for general or casual use. If given
1578 * it causes the (batchp) function to return the opposite result from
1579 * normal! Without "-a" (batchp) returns T either if at least one file
1580 * was specified on the command line, or if the standard input is "not
1581 * a tty" (under some operating systems this makes sense - for instance
1582 * the standard input might not be a "tty" if it is provided via file
1583 * redirection). Otherwise (ie primary input is directly from a keyboard)
1584 * (batchp) returns nil. Sometimes this judgement about how "batch" the
1585 * current run is will be wrong or unhelpful, so "-a" allows the user to
1586 * coax the system into better behaviour. I hope that this is never used!
1587 * At one stage this option was called "-b" not "-a" (so I will now pretend
1588 * that "-a" is for "alternate" or some such nonsense.
1589 */
1590 case 'a':
1591 batch_flag = YES;
1592 continue;
1593 /*
1594 * -b tells the system to avoid any attempt to recolour prompts and
1595 * input text. It will mainly be needed on X terminals that have been set up
1596 * so that they use colours that make the defaults here unhelpful.
1597 * Specifically white-on-black and so on.
1598 * -b can be followed by colour specifications to make things yet
1599 * more specific.
1600 */
1601 case 'b':
1602 /*
1603 * Actually "-b" is detected and processed by fwin (if present) before
1604 * this bit of the code is invoked (much as "-w" is). Thus I do not have
1605 * to do anything here!
1606 */
1607 continue;
1608
1609 /*
1610 * The option "-C" just prints a dull and unimaginative copyright notice -
1611 * having this option in there will tend to ensure that a copyright
1612 * message is embedded in the object code somehow, while with luck nobody
1613 * will be bothered too much by the fact that there is a stray option to get
1614 * it displayed. Note that on some systems there is a proper character
1615 * for the Copyright symbol... but there is little agreement about what
1616 * that code is! Furthermore to avoid needing to include Copyright statements
1617 * on behalf of any and all LGPL components I will make this an authorship
1618 * statement rather than a copyright claim!
1619 */
1620 case 'c':
1621 fwin_restore();
1622 term_printf("\nCSL was coded by Codemist Ltd, 1988-2010\n");
1623 term_printf("Distributed under the Modified BSD License\n");
1624 term_printf("See also --help\n");
1625 continue;
1626
1627 /*
1628 * -D name=val defines a symbol at the start of a run
1629 * I permit either
1630 * -Dname=val
1631 * or -D name=val
1632 */
1633 case 'd':
1634 if (c2 != 0) w = &opt[2];
1635 else if (i != argc) w = argv[++i];
1636 else break; /* Illegal at end of command-line */
1637 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
1638 symbols_to_define[number_of_symbols_to_define] = w,
1639 undefine_this_one[number_of_symbols_to_define++] = NO;
1640 else
1641 {
1642 fwin_restore();
1643 term_printf("Too many \"-D\" requests: ignored\n");
1644 }
1645 continue;
1646
1647 /*
1648 * -E
1649 * This option is for an EXPERIMENT. It may do different things in different
1650 * releases of CSL. In most cases it will not do anything! And certainly
1651 * I may change what it does without notice or upwards compatibility. Right
1652 * now it controls a way that can limit the loading of dynamically loadable
1653 * native code, and I need that for performance measurement and debugging.
1654 */
1655 case 'e':
1656 if (c2 != 0) w = &opt[2];
1657 else if (i != argc) w = argv[++i];
1658 else break;
1659 if (sscanf(w, "%d", &load_limit) != 1)
1660 load_limit = 0x7fffffff;
1661 continue;
1662
1663 #ifdef SOCKETS
1664 case 'f':
1665 /*
1666 * -F
1667 * This is used with syntax -Fnnn or -F nnn (with nnn a number above
1668 * 1000 but less than 65536) to cause the system to run not as a normal
1669 * interactive application but as a server listening on the indicated port.
1670 * The case -F- (which could of course be "-F -") indicates use of the
1671 * default port for CSL, which I hereby declare to be 1206. This number may
1672 * need to be changed later if I find it conflicts with some other common
1673 * package or usage, but was selected in memory of the project number
1674 * at one time allocated to the Archimedeans Computing Group.
1675 * On some systems if I want to set up a server that can serve multiple
1676 * clients I may need to re-invoke CSL afresh for each new client, and in
1677 * such cases the internally generated tasks can be passed information
1678 * from their parent task using -F followed by non-numeric information.
1679 * Any user who attempts such usage will get "what they deserve".
1680 */
1681 if (c2 != 0) w = &opt[2];
1682 else if (i != argc) w = argv[++i];
1683 else break; /* Illegal at end of command-line */
1684 port_number = default_csl_server_port;
1685 remote_store = REMOTE_STORE;
1686 max_users = MAX_USERS;
1687 if (strcmp(w, "-") == 0)
1688 port_number = default_csl_server_port;
1689 else if (sscanf(w, "%d:%d:%d",
1690 &port_number, &max_users, &remote_store) < 1 ||
1691 port_number <= 1000 ||
1692 port_number >= 65536 ||
1693 max_users < 2 || max_users > 50 ||
1694 remote_store < 4000 || remote_store > 20000)
1695 {
1696 fwin_restore();
1697 term_printf("\"%s\" is valid (want port:users:store\n", w);
1698 continue;
1699 }
1700 store_size = (double)remote_store;
1701 init_flags &= ~INIT_EXPANDABLE;
1702 current_users = 0;
1703 /*
1704 * The code here is probably a bit painfully system-specific, and so one
1705 * could argue that it should go in a separate file. However a LOT of the
1706 * socket interface is the same regardless of the host, or a few simple
1707 * macros can have made it so. So if SOCKETS has been defined I will
1708 * suppose I can continue here on that basis. I do quite want to put the
1709 * basic socket code in csl.c since it is concerned with system startup and
1710 * the selection of sources and sinks for IO.
1711 */
1712 if (ensure_sockets_ready() == 0)
1713 { SOCKET sock1, sock2;
1714 struct sockaddr_in server_address, client_address;
1715 #ifdef HAVE_SOCKLEN_T
1716 socklen_t sin_size;
1717 #else
1718 int sin_size;
1719 #endif
1720 sock1 = socket(AF_INET, SOCK_STREAM, 0);
1721 if (sock1 == SOCKET_ERROR)
1722 {
1723 fwin_restore();
1724 term_printf("Unable to create a socket\n");
1725 continue;
1726 }
1727 server_address.sin_family = AF_INET;
1728 server_address.sin_port = htons(port_number);
1729 server_address.sin_addr.s_addr = INADDR_ANY;
1730 memset((char *)&(server_address.sin_zero), 0, 8);
1731 if (bind(sock1, (struct sockaddr *)&server_address,
1732 sizeof(struct sockaddr)) == SOCKET_ERROR)
1733 {
1734 fwin_restore();
1735 term_printf("Unable to bind socket to port %d\n",
1736 port_number);
1737 closesocket(sock1);
1738 continue;
1739 }
1740 if (listen(sock1, PERMITTED_BACKLOG) == SOCKET_ERROR)
1741 {
1742 fwin_restore();
1743 term_printf("Failure in listen() on port %d\n",
1744 port_number);
1745 closesocket(sock1);
1746 continue;
1747 }
1748 for (;;)
1749 { struct hostent *h;
1750 time_t t0;
1751 sin_size = sizeof(struct sockaddr_in);
1752 sock2 = accept(sock1,
1753 (struct sockaddr *)&client_address,
1754 &sin_size);
1755 if (sock2 == SOCKET_ERROR)
1756 {
1757 fwin_restore();
1758 term_printf("Trouble with accept()\n");
1759 continue; /* NB local continue here */
1760 }
1761 t0 = time(NULL);
1762 term_printf("%.24s from %s",
1763 ctime(&t0),
1764 inet_ntoa(client_address.sin_addr));
1765 h = gethostbyaddr((char *)&client_address.sin_addr,
1766 sizeof(client_address.sin_addr), AF_INET);
1767 if (h != NULL)
1768 term_printf(" = %s", h->h_name);
1769 else term_printf(" [unknown host]");
1770 /*
1771 * Here I have a bit of a mess. Under Unix I can do a fork() so that the
1772 * requests that are coming in are handled by a separate process. The
1773 * code is pretty easy. However with Windows I can only create a fresh process
1774 * by re-launching CSL from the file it was originally fetched from. I
1775 * will try to do that in a while, but for now I will leave the
1776 * Windows version of this code only able to handle a single client
1777 * session.
1778 */
1779 #ifdef WIN32
1780 closesocket(sock1);
1781 socket_server = sock2;
1782 cpu_timeout = clock() + CLOCKS_PER_SEC*MAX_CPU_TIME;
1783 elapsed_timeout = time(NULL) + 60*MAX_ELAPSED_TIME;
1784 procedural_output = char_to_socket;
1785 term_printf("Welcome to the Codemist server\n");
1786 ensure_screen();
1787 break;
1788 #else /* WIN32 */
1789 while (waitpid(-1, NULL, WNOHANG) > 0) current_users--;
1790 if (current_users >= max_users)
1791 { term_printf(" refused\n");
1792 socket_server = sock2;
1793 ensure_screen();
1794 procedural_output = char_to_socket;
1795 term_printf(
1796 "\nSorry, there are already %d people using this service\n",
1797 current_users);
1798 term_printf("Please try again later.\n");
1799 ensure_screen();
1800 procedural_output = NULL;
1801 closesocket(socket_server);
1802 socket_server = 0;
1803 continue;
1804 }
1805 else term_printf(" %d of %d\n",
1806 ++current_users, max_users);
1807 ensure_screen();
1808 if (!fork())
1809 { /* Child process here */
1810 closesocket(sock1);
1811 fcntl(sock2, F_SETFL, O_NONBLOCK);
1812 socket_server = sock2;
1813 cpu_timeout = clock() + CLOCKS_PER_SEC*MAX_CPU_TIME;
1814 elapsed_timeout = time(NULL) + 60*MAX_ELAPSED_TIME;
1815 ensure_screen();
1816 procedural_output = char_to_socket;
1817 term_printf("Welcome, you are user %d of %d\n",
1818 current_users, max_users);
1819 term_printf(
1820 "You have been allocated %d seconds CPU time"
1821 " and %d minutes elapsed time\n",
1822 MAX_CPU_TIME, MAX_ELAPSED_TIME);
1823 break;
1824 }
1825 else
1826 { closesocket(sock2);
1827 if (current_users < 0) current_users = 0;
1828 continue;
1829 /*
1830 * This loops serving as many clients as happen to come along. Having said
1831 * "csl -fnnn" it will be necessary (in due course) to kill the daemon
1832 * by interrupting it with a ^C or some such. When the master process is
1833 * terminated in that way any clients that remain active may continue to
1834 * hang around until they have finished in the usual way.
1835 */
1836 }
1837 #endif /* WIN32 */
1838 }
1839 }
1840 /*
1841 * The "continue" here gets executed when I have been contacted by some
1842 * client and have an active socket open. It parses the rest of the
1843 * command line and then completes the process of getting CSL running.
1844 */
1845 continue;
1846 #endif
1847
1848 /*
1849 * -G
1850 * is a debugging option - it sets !*backtrace to true, which applications
1851 * may inspect when they want to do errorsets etc. These days I will
1852 * make it FORCE all errors to be noisy whatever the user tries to do! The
1853 * rationale for that is that some user code may have said
1854 * (errorset X nil nil)
1855 * and then errors within X become very hard to track. The "-g" option
1856 * overrides the "nil nil" bit!
1857 */
1858 case 'g':
1859 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
1860 symbols_to_define[number_of_symbols_to_define] =
1861 "*backtrace",
1862 undefine_this_one[number_of_symbols_to_define++] = NO;
1863 else
1864 {
1865 fwin_restore();
1866 term_printf("Too many requests: \"-G\" ignored\n");
1867 }
1868 always_noisy = YES;
1869 continue;
1870 /*
1871 * -H
1872 * render fonts on X host rather than X client (ie disable use of Xft and
1873 * and Xrender if they might otherwise have been in use). This should have
1874 * no effect on Windows and no effect if the system that the code was built
1875 * on did not support Xft.
1876 */
1877 case 'h':
1878 fwin_use_xft = 0;
1879 /*
1880 * Actually, like the "-w" option, it is TOO LATE to do this here because
1881 * lower-level parts of fwin may already have adjusted font paths using
1882 * mechanisms based on whether Xft is to be activated or not. So fwin
1883 * checks for "-h" and "-H" and interprets what it finds. So what I do here
1884 * is just a redundant reminder. Ugh.
1885 */
1886 continue;
1887
1888 /*
1889 * -I is used to specify an image file to be used when CSL starts up.
1890 * The case -I- indicated the "standard" file associated with this
1891 * executable binary. Several images can be given.
1892 */
1893 case 'i':
1894 if (c2 != 0) w = &opt[2];
1895 else if (i != argc) w = argv[++i];
1896 else break; /* Illegal at end of command-line */
1897 if (w[0] == '-' && w[1] == 0) w = standard_directory;
1898 if (number_of_fasl_paths < MAX_FASL_PATHS-1)
1899 fasl_paths[number_of_fasl_paths++] = w;
1900 else
1901 {
1902 fwin_restore();
1903 term_printf("Too many \"-I/-O\" requests: ignored\n");
1904 }
1905 continue;
1906
1907 /*
1908 * -J enabled the "track dependencies" hack that I have. Every time
1909 * that a file is opened for reading it records the file-name concerned
1910 * and at the end of everything it dumps a record of all the distinct
1911 * files to the named place, as in "-J fileuse.dat"
1912 */
1913 case 'j':
1914 if (c2 != 0) w = &opt[2];
1915 else if (i != argc) w = argv[++i];
1916 else break; /* Illegal at end of command-line */
1917 dependency_file = w;
1918 continue;
1919
1920 /*
1921 * -K nnn sets the size of heap to be used. If it is given then that much
1922 * memory will be allocated and the heap will never expand. Without this
1923 * option a default amount is used, and (on many machines) it will grow
1924 * if space seems tight.
1925 * The extended version of this option is "-K nnn/ss" and then ss is the
1926 * number of "CSL pages" to be allocated to the Lisp stack. The default
1927 * value (which is 1) should suffice for almost all users, and it should
1928 * be noted that the C stack is separate from and independent of this one and
1929 * it too could overflow.
1930 * A form like -K6000K indicates that many kilobytes
1931 * -K200M or just -K200 indicates that many megabytes
1932 * -K1.6G indicates that many gigabytes
1933 */
1934 case 'k':
1935 if (c2 != 0) w = &opt[2];
1936 else if (i != argc) w = argv[++i];
1937 else break; /* Illegal at end of command-line */
1938 { char buffer[16];
1939 int i = 0;
1940 while ((*w != '/') &&
1941 (*w != 'k') && (*w != 'K') &&
1942 (*w != 'm') && (*w != 'M') &&
1943 (*w != 'g') && (*w != 'G') &&
1944 (*w != 0) &&
1945 (i<sizeof(buffer)-1))
1946 buffer[i++] = *w++;
1947 buffer[i] = 0;
1948 /*
1949 * store size gets set here: 0.0 is left if either that is specified
1950 * explictly or if no -K option is given. That will be treated as
1951 * indicating "use default, and expand memory as you go"
1952 */
1953 store_size = atof(buffer);
1954 if (store_size == 0.0) init_flags |= INIT_EXPANDABLE;
1955 else
1956 { init_flags &= ~INIT_EXPANDABLE;
1957 /*
1958 * If an explicit store size has been indicated I will see if it had one
1959 * of the letters K, M or G after it (note that I allow it to be a floating
1960 * point value.
1961 */
1962 switch (*w)
1963 {
1964 case 'k': case 'K':
1965 break;
1966 case 'g': case 'G':
1967 store_size *= 1024.0*1024.0;
1968 break;
1969 default: /* megabytes by default */
1970 store_size *= 1024.0;
1971 break;
1972 }
1973 /*
1974 * Now the measure is adjusted so it is in units of kilobytes. I will
1975 * set a lower limit to how much can be asked for to try to prevent
1976 * utter congestion. I will also set an upper limit to provide some minor
1977 * protection.
1978 */
1979 #if PAGE_BITS==18
1980 if (store_size < 10000.0) store_size = 10000.0;
1981 #else
1982 if (store_size < 32000.0) store_size = 32000.0;
1983 #endif
1984 /*
1985 * At present I limit even 64-bit systems to 50 Gbytes.
1986 * ... and 32-bit systems to 1.9 Gbytes.
1987 */
1988 if ((!SIXTY_FOUR_BIT &&
1989 (store_size > 1.9*1024.0*1024.0)) ||
1990 (store_size > 50*1024.0*1024.0))
1991 {
1992 fwin_restore();
1993 term_printf(
1994 "Memory specifier \"-K%s%s\" is too large (= %.4g)\n",
1995 buffer, w, store_size/1024.0);
1996 term_printf("Please specify as -KnnnK, -KnnnM or -KnnnG\n");
1997 term_printf("for Kilobytes, Megabytes or Gigabytes\n");
1998 }
1999 }
2000 while (*w!=0 && *w!='/') w++;
2001 if (*w == '/')
2002 { stack_segsize = atoi(w+1);
2003 if (stack_segsize < 1 || stack_segsize > 10)
2004 stack_segsize = 1;
2005 }
2006 }
2007 continue;
2008
2009 /*
2010 * -L <logfile> arranges that a transcript of the standard output is
2011 * sent to the given file, just as if (spool '<logfile>) had been executed
2012 * at the start of the run.
2013 */
2014 case 'l':
2015 if (c2 != 0) w = &opt[2];
2016 else if (i != argc) w = argv[++i];
2017 else break; /* Illegal at end of command-line */
2018 { char filename[LONGEST_LEGAL_FILENAME];
2019 spool_file = open_file(filename, w,
2020 strlen(w), "w", NULL);
2021 if (spool_file == NULL)
2022 {
2023 fwin_restore();
2024 term_printf("Unable to write to \"%s\"\n", filename);
2025 }
2026 else
2027 { time_t t0 = time(NULL);
2028 strncpy(spool_file_name, filename, 32);
2029 spool_file_name[31] = 0;
2030 #ifdef COMMON
2031 fprintf(spool_file,
2032 "Starts dribbling to %s (%.24s).\n",
2033 spool_file_name, ctime(&t0));
2034 #else
2035 fprintf(spool_file,
2036 "+++ Transcript to %s started at %.24s +++\n",
2037 spool_file_name, ctime(&t0));
2038 #endif
2039 }
2040 }
2041 continue;
2042
2043 #ifdef MEMORY_TRACE
2044 /*
2045 * If MEMORY_TRACE is set up then I can cause an exception by providing
2046 * an option -M n:l:h
2047 * This interrupts after n memory records when a reference in the (inclusive)
2048 * range l..h is next made.
2049 */
2050 case 'm':
2051 if (c2 != 0) w = &opt[2];
2052 else if (i != argc) w = argv[++i];
2053 else break; /* Illegal at end of command-line */
2054 switch(sscanf(w, "%ld:%lu:%lu",
2055 &car_counter, &car_low, &car_high))
2056 {
2057 case 0: car_counter = 0x7fffffff;
2058 case 1: car_low = 0;
2059 case 2: car_high = 0xffffffff;
2060 default:break;
2061 }
2062 continue;
2063 #endif
2064
2065 /*
2066 * -N tells CSL that even if the image being loaded contains a restart-
2067 * function this should be ignored, and Lisp should run the default
2068 * read-eval-print loop. The only expected use for this is when an image
2069 * has been created but it is seriously broken, so the way it would
2070 * usually restart would crash - then "-N" may allow a suitable expert to
2071 * test and diagnose the trouble at the Lisp level. Ordinary users are
2072 * NOT expected to want to know about this!
2073 */
2074 case 'n': /* Ignore restart function (-N) */
2075 ignore_restart_fn = YES;
2076 continue;
2077
2078 /*
2079 * -O <file> specifies an image file for output (via FASLOUT or PRESERVE).
2080 */
2081 case 'o':
2082 if (c2 != 0) w = &opt[2];
2083 else if (i != argc) w = argv[++i];
2084 else break; /* Illegal at end of command-line */
2085 if (w[0] == '-' && w[1] == 0) w = standard_directory;
2086 if (number_of_fasl_paths < MAX_FASL_PATHS-1)
2087 { output_directory = number_of_fasl_paths;
2088 fasl_paths[number_of_fasl_paths++] = w;
2089 }
2090 else
2091 {
2092 fwin_restore();
2093 term_printf("Too many \"-I/-O\" requests: ignored\n");
2094 }
2095 continue;
2096
2097 /*
2098 * -P is reserved for profile options.
2099 */
2100 case 'p':
2101 /*
2102 * Please implement something for your favourite system here... what I would
2103 * like would be a call to monitor() or some such...
2104 */
2105 fwin_restore();
2106 term_printf("Unimplemented option \"-%c\"\n", c1);
2107 continue;
2108
2109 /*
2110 * -Q selects "quiet" mode. See -V for the converse.
2111 */
2112 case 'q':
2113 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
2114 /*
2115 * symbols_to_define[number_of_symbols_to_define] =
2116 * "*echo=nil",
2117 * undefine_this_one[number_of_symbols_to_define++] = NO,
2118 */
2119 init_flags &= ~INIT_VERBOSE,
2120 init_flags |= INIT_QUIET;
2121 else
2122 {
2123 fwin_restore();
2124 term_printf("Too many requests: \"-Q\" ignored\n");
2125 }
2126 continue;
2127
2128 /*
2129 * -R nnn sets the initial random seed, for reproducible runs. -R 0
2130 * (the default) sets the initial seed based on the time of day etc.
2131 * The version -R nnn,mmm makes it possible to pass 64-bits of seed info.
2132 */
2133 case 'r':
2134 if (c2 != 0) w = &opt[2];
2135 else if (i != argc) w = argv[++i];
2136 else break; /* Illegal at end of command-line */
2137 if (sscanf(w, "%ld,%ld", &initial_random_seed, &seed2) != 2)
2138 { initial_random_seed = seed2 = 0;
2139 sscanf(w, "%ld", &initial_random_seed);
2140 }
2141 continue;
2142
2143 /*
2144 * -S sets the variable !*plap, which causes the compiler to list the
2145 * bytecodes that it generates. This is probably frivolous but is
2146 * provided inspired by the typical C compilers "cc -S" option.
2147 */
2148 case 's':
2149 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
2150 symbols_to_define[number_of_symbols_to_define] =
2151 "*plap",
2152 undefine_this_one[number_of_symbols_to_define++] = NO;
2153 else
2154 {
2155 fwin_restore();
2156 term_printf("Too many requests: \"-S\" ignored\n");
2157 }
2158 continue;
2159 /*
2160 * -T name reports the time-stamp on the named module, and then
2161 * exits. This is for use in perl scripts and the like, and is
2162 * needed because the stamps on modules within an image or
2163 * library file are not otherwise instantly available.
2164 *
2165 * Note that especially on windowed systems it may be
2166 * necessary to use this with "-- filename" since the information
2167 * generated here goes to the default output unit, which in
2168 * some cases is just the screen.
2169 */
2170 case 't':
2171 if (c2 != 0) w = &opt[2];
2172 else if (i != argc) w = argv[++i];
2173 else break; /* Illegal at end of command-line */
2174 module_enquiry = w;
2175 continue;
2176
2177 /*
2178 * -U name undefines the symbol <name> at the start of the run
2179 */
2180 case 'u':
2181 if (c2 != 0) w = &opt[2];
2182 else if (i != argc) w = argv[++i];
2183 else break; /* Illegal at end of command-line */
2184 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
2185 symbols_to_define[number_of_symbols_to_define] = w,
2186 undefine_this_one[number_of_symbols_to_define++] = YES;
2187 else
2188 {
2189 fwin_restore();
2190 term_printf("Too many \"-U\" requests: ignored\n");
2191 }
2192 continue;
2193 /*
2194 * -V selects "verbose" options at the start of the run
2195 */
2196 case 'v':
2197 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
2198 /*
2199 * symbols_to_define[number_of_symbols_to_define] =
2200 * "*echo",
2201 * undefine_this_one[number_of_symbols_to_define++] = NO,
2202 */
2203 init_flags &= ~INIT_QUIET,
2204 init_flags |= INIT_VERBOSE;
2205 else
2206 {
2207 fwin_restore();
2208 term_printf("Too many requests: \"-V\" ignored\n");
2209 }
2210 continue;
2211
2212 #ifdef WINDOW_SYSTEM
2213 /*
2214 * On systems where I can run in either windowed or command-line mode this
2215 * flag controls that aspect of behaviour.
2216 */
2217 case 'w':
2218 /*
2219 * I need to detect and process this flag especially early, and so by the time
2220 * I get to regular command decoding there is nothing to be done.
2221 * Within fwin the option "-w" says "do NOT try to use a window, ie
2222 * run as a console style application", while "-w+" says "Even if
2223 * all the rest of the schemes that I have indicate that you should
2224 * run in console mode (eg if standard input is from a pipe, which it
2225 * will be when running under some debuggers) try to create and use a
2226 * window.
2227 */
2228 continue;
2229 #endif
2230
2231 /*
2232 * -x is an "undocumented" option intended for use only by system
2233 * support experts - it disables trapping if segment violations by
2234 * errorset and so makes it easier to track down low level disasters -
2235 * maybe! Only those who have access to the source code can make
2236 * good use of the -X option, so it is only described here!
2237 */
2238 case 'x':
2239 segvtrap = NO;
2240 continue;
2241 /*
2242 * -Y sets the variable !*hankaku , which causes the lisp reader convert
2243 * a Zenkaku code to Hankaku one when read. I leave this option decoded
2244 * on the command line even if the Kanji support code is not otherwise
2245 * compiled into CSL just so I can reduce conditional compilation.
2246 * This was part of the Internationalisation effort for CSL but I repeat
2247 * that it is no longer supported.
2248 */
2249 case 'y':
2250 if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
2251 symbols_to_define[number_of_symbols_to_define] =
2252 "*hankaku",
2253 undefine_this_one[number_of_symbols_to_define++] = NO;
2254 else
2255 term_printf("Too many requests: \"-Y\" ignored\n");
2256 continue;
2257
2258 /*
2259 * -Z tells CSL that it should not load an initial heap image, but should
2260 * run in "cold start" mode. This is only intended to be useful for
2261 * system builders.
2262 */
2263 case 'z': /* Cold start option -z */
2264 restartp = NO;
2265 continue;
2266
2267 default:
2268 fwin_restore();
2269 term_printf("Unrecognized option \"-%c\"\n", c1);
2270 continue;
2271 }
2272 /*
2273 * I do a "break" out of the switch() block if a key occurs at the end
2274 * of the command line in an invalid manner.
2275 */
2276 fwin_restore();
2277 term_printf("Option \"-%c\" needs an argument: ignored\n", c1);
2278 break;
2279 }
2280 else files_to_read[number_of_input_files++] = opt;
2281 }
2282
2283 if (number_of_fasl_paths == 0)
2284 { char *p = standard_directory, *p1;
2285 char cur[LONGEST_LEGAL_FILENAME];
2286 /*
2287 * If the user does not specify any image files then the behaviour
2288 * defaults as follows:
2289 * Suppose that the current executable is xxx/yyy/zzz then the
2290 * system behaves as if the user had written
2291 * zzz -o zzz.img -i xxx/yyy/zzz.img
2292 * however if the executable seemed to be in the current directory
2293 * already this is reduced to just
2294 * zzz -o zzz.img
2295 * so that I do not have two different handles on the same image file
2296 * (with the potential muddle that that could result in).
2297 *
2298 * NOTE: this used very generally mean that you ended up with an empty image
2299 * file (eg csl.img or reduce.img) in whatever directory you run this
2300 * code from. This could be avoided by running it as
2301 * xxx -i-
2302 * that explicitly sets up the normal image file as the one to use with
2303 * no extras. However these days I try to arrange that an output image file
2304 * only ever gets created if somebody calls FASLOUT or PRESERVE, so what
2305 * I describe here will usually not cause confusion....
2306 *
2307 * The "image" here can now be in onw of two forms. The one that I historically
2308 * used with CSL was that an image "xxx.img" was a single file that was set
2309 * up with internal directories so that it acted as a composite unit holding
2310 * many sub-files within it. That has the potential convenience that it is
2311 * a single file to distribute and it is hard for there to be confuson about
2312 * corruption or loss of the various sub-files within it. This scheme will
2313 * still be used if xxx.img is a single file. But if on start-up xxx.img is a
2314 * directory, or if it does not exist to start with and is named in the form
2315 * "xxx.img/" with a trailing directory separator then the various sub-items
2316 * will merely be stored within that directory. That moves the strain of
2317 * managing them onto the operating system, but means that the operating system
2318 * will maintain date-stamps on each sub-file and this may be useful if you
2319 * wish to use "make" to maintain a project. It will be possible to have both
2320 * a single-file and a directory based image open at the same time and copy
2321 * at least some modules from one to another under program control.
2322 *
2323 * At present I still view the one-file solution as neater and so it is the
2324 * default. The names used for files witin a directory are discussed in the
2325 * places where I manage them.
2326 */
2327 if (standard_directory[0] == '.' &&
2328 (standard_directory[1] == '/' ||
2329 standard_directory[1] == '\\')) strcpy(cur, standard_directory);
2330 else get_current_directory(cur, sizeof(cur));
2331 p += strlen(p);
2332 while (p != standard_directory &&
2333 *--p != '/' &&
2334 *p != '\\') /* nothing */;
2335 if (strncmp(standard_directory, cur, p-standard_directory) != 0)
2336 p1 = (char *)(*malloc_hook)(strlen(p));
2337 else p1 = NULL;
2338 if (p == standard_directory || p1 == NULL)
2339 { fasl_paths[0] = standard_directory;
2340 /*
2341 * If output_directory has the 0x40000000 bit set then the directory
2342 * involved is one that should be opened now if it exists, but if
2343 * it does not its creation should be deferred for as long as possible.
2344 */
2345 output_directory = 0x40000000 + 0;
2346 number_of_fasl_paths = 1;
2347 if (p1 != NULL) (*free_hook)(p1);
2348 }
2349 else
2350 { strcpy(p1, p+1);
2351 fasl_paths[0] = p1;
2352 fasl_paths[1] = standard_directory;
2353 output_directory = 0x40000000 + 0;
2354 number_of_fasl_paths = 2;
2355 }
2356 }
2357
2358 Iinit(); /* Initialise "file system" for image files */
2359
2360 if (module_enquiry != NULL)
2361 { char datestamp[32], fullname[LONGEST_LEGAL_FILENAME];
2362 int32_t size;
2363 int i;
2364 Lisp_Object nil;
2365 /*
2366 * Imodulep expects input_libraries to be set up. So I will fudge the
2367 * creation of something that looks sufficiently like a list to pass muster
2368 * here despite the full system not being loaded. I use references to the
2369 * nil-segment and cons().
2370 */
2371
2372 nilsegment = (Lisp_Object *)my_malloc(NIL_SEGMENT_SIZE);
2373 #ifdef COMMON
2374 nil = doubleword_align_up(nilsegment) + TAG_CONS + 8;
2375 #else
2376 nil = doubleword_align_up(nilsegment) + TAG_SYMBOL;
2377 #endif
2378 C_nil = nil;
2379 pages_count = heap_pages_count = vheap_pages_count =
2380 bps_pages_count = native_pages_count = 0;
2381 stacksegment = (Lisp_Object *)my_malloc(CSL_PAGE_SIZE);
2382 /*
2383 * I am lazy about protection against malloc failure here.
2384 */
2385 heaplimit = doubleword_align_up(stacksegment);
2386 fringe = heaplimit + CSL_PAGE_SIZE - 16;
2387 input_libraries = heaplimit + 16 + TAG_SYMBOL;
2388 heaplimit += 64;
2389 /*
2390 * I have now fudged up enough simulation of a Lisp heap that maybe I can
2391 * build the library search-list.
2392 */
2393 qheader(input_libraries) |= SYM_SPECIAL_FORM;
2394 qvalue(input_libraries) = nil;
2395 for (i=number_of_fasl_paths-1; i>=0; i--)
2396 qvalue(input_libraries) = cons(SPID_LIBRARY + (((int32_t)i)<<20),
2397 qvalue(input_libraries));
2398
2399 if (Imodulep(module_enquiry, strlen(module_enquiry),
2400 datestamp, &size, fullname))
2401 { strcpy(datestamp, "unknown");
2402 size = 0;
2403 strcpy(fullname, module_enquiry);
2404 }
2405 term_printf("%.24s size=%ld file=%s\n",
2406 datestamp, (long)size, fullname);
2407 init_flags &= ~INIT_VERBOSE;
2408 #ifdef HAVE_FWIN
2409 fwin_pause_at_end = 0;
2410 #endif
2411 }
2412 else
2413 { base_time = read_clock();
2414 consolidated_time[0] = gc_time = 0.0;
2415 clock_stack = &consolidated_time[0];
2416 push_clock();
2417
2418 if (init_flags & INIT_VERBOSE)
2419 {
2420 #ifndef WINDOW_SYSTEM
2421 /*
2422 * If I do NOT have a window system I will print a newline here so that I
2423 * can be very certain that my banner appears at the start of a line.
2424 * With a window system I should have a brand-new frash window for output
2425 * and the newline would intrude as an initial blank line.
2426 */
2427 term_printf("\n");
2428 #endif
2429
2430 #ifndef COMMON
2431 term_printf("Codemist Standard Lisp %s for %s: %s\n",
2432 VERSION, IMPNAME, __DATE__);
2433 #else
2434 term_printf("Codemist Common Lisp %s for %s: %s\n",
2435 VERSION, IMPNAME, __DATE__);
2436 #endif
2437 }
2438 #ifdef MEMORY_TRACE
2439 if (car_counter != 0x7fffffff)
2440 term_printf("Stop after %ld %lu..%lu\n",
2441 car_counter, car_low, car_high);
2442 #endif
2443 #ifdef WINDOW_SYSTEM
2444 ensure_screen();
2445 /* If the user hits the close button here I may be in trouble */
2446 #endif
2447
2448 /*
2449 * Now dynamic code detects the floating point representation that is in use.
2450 * I thought/hoped that doing it this way would be safer than relying on having
2451 * pre-defined symbols that tracked the machine architecture.
2452 */
2453 { union fpch { double d; unsigned char c[8]; } d;
2454 /*
2455 * The following looks at the floating point representation of the
2456 * number 1/7 (in double precision) and picks out two bytes from
2457 * the middle of the first word - where I hope that rounding issues
2458 * will be remote. Investigation shows that these two bytes can be
2459 * used to discriminate among at least a worthwhile range of
2460 * representations, and I will exploit this to help me re-load
2461 * heap-images in a way that allows images to be portable across
2462 * different architectures.
2463 */
2464 d.d = 1.0/7.0;
2465 switch ((d.c[1] << 8) | d.c[2])
2466 {
2467 /*
2468 * At one stage I detected (on of the) VAX representations and the one used
2469 * by the IBM s60/s370. These days I am only going to recognise cases that
2470 * use IEEE layout. Even with that the example machines noted here reveal
2471 * that evenb though IEEE explains what bits should be in the floating point
2472 * value different manufacturers pack the words and bytes in a variety of
2473 * ways! Well the mere shuffling of bytes is something I can deal with. If I
2474 * really needed to make image files portable to old-style IBM mainframes
2475 * or on a xArch machine set up to use hexadecimal floating point mode then
2476 * what I have gere would moan. But if I just override the moan I will
2477 * be able to build images and reload them on that particular machine.
2478 */
2479 case 0x2449: current_fp_rep = 0;
2480 break; /* Intel, MIPS */
2481 case 0x49c2: current_fp_rep = FP_WORD_ORDER;
2482 break; /* ARM */
2483 case 0x4924: current_fp_rep = FP_BYTE_ORDER;
2484 break; /* may never happen? */
2485 case 0xc249: current_fp_rep = FP_WORD_ORDER|FP_BYTE_ORDER;
2486 break; /* SPARC */
2487 /*
2488 * The next line is probably not very good under a window manager, but
2489 * it is a case that ought never to arise, so I will not bother.
2490 */
2491 default: term_printf("Unknown floating point format\n");
2492 my_exit(EXIT_FAILURE);
2493 }
2494 }
2495
2496 /*
2497 * Up until the time I call setup() I may only use term_printf for
2498 * output, because the other relevant streams will not have been set up.
2499 */
2500 setup(restartp ? 3 : 2, store_size);
2501 /*
2502 * I need to set the NOISY flag after doing setup to avoid it getting
2503 * reloaded from a heap image
2504 */
2505 { nil_as_base
2506 if (always_noisy) miscflags |= (ALWAYS_NOISY | 3);
2507 else miscflags &= ~ALWAYS_NOISY;
2508 }
2509
2510 #ifndef COMMON
2511 #ifdef HAVE_FWIN
2512 fwin_menus(loadable_packages, switches, review_switch_settings);
2513 #endif
2514 #endif
2515
2516 /*
2517 * Now that setup is complete (and I have done any authorisation I want to)
2518 * I will seed the random number generator as requested by the user. The
2519 * default will be to put it in an unpredictable (well hard to predict!)
2520 * state
2521 */
2522 Csrand((uint32_t)initial_random_seed, (uint32_t)seed2);
2523
2524 gc_time += pop_clock();
2525
2526 countdown = software_ticks;
2527 interrupt_pending = already_in_gc = NO;
2528 tick_pending = tick_on_gc_exit = NO;
2529
2530 #ifndef HAVE_FWIN
2531 /*
2532 * "^C" trapping and handling happens within fwin if that is available.
2533 */
2534 #ifndef UNDER_CE
2535 sigint_must_longjmp = NO;
2536 signal(SIGINT, sigint_handler);
2537 #endif
2538 #endif
2539 ensure_screen();
2540 procedural_output = NULL;
2541 #ifdef HAVE_FWIN
2542 /*
2543 * OK, if I get this far I will suppose that any messages that report utter
2544 * disasters will have reached the user, so I can allow FWIN to terminate
2545 * rather more promptly.
2546 */
2547 fwin_pause_at_end = 0;
2548 #endif
2549 }
2550 #ifdef HAVE_FWIN
2551 #ifdef HAVE_LIBFOX
2552 /*
2553 * Activate the BREAK and BACKTRACE menu items. Note not needed unless
2554 * FOX is used and so there is a prospect of theer actually being menus!
2555 */
2556 /*
2557 * The next line causes a MOAN using Sun's compiler, ending up with
2558 * an undefined reference to fwin_callback_to_interrupt!
2559 */
2560 fwin_callback_to_interrupt(async_interrupt);
2561 #endif /* HAVE_LIBFOX */
2562 #endif /* HAVE_FWIN */
2563 }
2564
2565 #ifdef SOCKETS
2566
2567 #define SOCKET_BUFFER_SIZE 1024
2568 /*
2569 * The following two "character codes" are used when CSL is run as
2570 * a socket server and wrap around prompt text. This could be in
2571 * conflict with any code that tries to use these codes for other
2572 * purposes or that handles prompts itself...
2573 */
2574 #define CH_PROMPT 0x9a
2575 #define CH_ENDPROMPT 0x9c
2576
2577 static char socket_in[SOCKET_BUFFER_SIZE], socket_out[SOCKET_BUFFER_SIZE];
2578 static int socket_in_p = 0, socket_in_n = 0,
2579 socket_out_p = 0, socket_prev = '\n';
2580
char_from_socket(void)2581 static int char_from_socket(void)
2582 {
2583 int c;
2584 clock_t c0;
2585 time_t t0;
2586 if (socket_server == 0)
2587 { socket_prev = ' ';
2588 return EOF;
2589 }
2590 /*
2591 * I generate a prompt whenever I am about to read the character that
2592 * follows a newline. The prompt is issued surrounded by control
2593 * characters 0x9a and 0x9c. That curious arrangement is inherited from
2594 * internal behaviour in my Windows interface code and could be altered
2595 * if something truly better could be invented.
2596 */
2597 if (socket_prev == '\n')
2598 { term_printf("%c%s%c", CH_PROMPT, prompt_string, CH_ENDPROMPT);
2599 ensure_screen();
2600 }
2601 if (socket_in_n == 0)
2602 { for (;;)
2603 { socket_in_n = recv(socket_server, socket_in, SOCKET_BUFFER_SIZE, 0);
2604 c0 = clock();
2605 t0 = time(NULL);
2606 if (c0 > cpu_timeout || t0 > elapsed_timeout)
2607 { cpu_timeout = c0 + 20;
2608 elapsed_timeout = t0 + 20;
2609 term_printf(
2610 "\nSorry: timeout on this session. Closing down.\n");
2611 socket_prev = ' ';
2612 return EOF;
2613 }
2614 if (socket_in_n <= 0)
2615 #ifndef EWOULDBLOCK
2616 # define EWOULDBLOCK WSAEWOULDBLOCK
2617 #endif
2618 { if (errno == EWOULDBLOCK)
2619 {
2620 #ifdef WIN32
2621 Sleep(1000); /* Arg in milliseconds here */
2622 #else
2623 sleep(1); /* Delay 1 second before re-polling */
2624 #endif
2625 continue;
2626 }
2627 closesocket(socket_server);
2628 socket_server = 0;
2629 socket_prev = ' ';
2630 return EOF;
2631 }
2632 else break;
2633 }
2634 socket_in_p = 0;
2635 }
2636 c = socket_in[socket_in_p++];
2637 if (c == 0x0a || c == 0x0d) c = '\n';
2638 socket_in_n--;
2639 socket_prev = c;
2640 return c & 0xff;
2641 }
2642
char_to_socket(int c)2643 static int char_to_socket(int c)
2644 {
2645 if (socket_server == 0) return 1;
2646 socket_out[socket_out_p++] = (char)c;
2647 if (c == '\n' || socket_out_p == SOCKET_BUFFER_SIZE)
2648 { if (send(socket_server, socket_out, socket_out_p, 0) < 0)
2649 { closesocket(socket_server);
2650 socket_server = 0;
2651 return 1;
2652 }
2653 socket_out_p = 0;
2654 }
2655 return 0;
2656 }
2657
flush_socket(void)2658 void flush_socket(void)
2659 {
2660 if (socket_server == 0) return;
2661 if (send(socket_server, socket_out, socket_out_p, 0) < 0)
2662 { closesocket(socket_server);
2663 socket_server = 0;
2664 }
2665 socket_out_p = 0;
2666 }
2667
2668 #endif
2669
cslaction(void)2670 static void cslaction(void)
2671 /*
2672 * This is the "standard" route into CSL activity - it uses file-names
2673 * from the decoded command-line as files to be read and processed
2674 * unless the system was launched with the flag that says it ought to try
2675 * to provide a network service on some socket.
2676 */
2677 {
2678 #ifdef CONSERVATIVE
2679 volatile Lisp_Object sp;
2680 C_stackbase = (Lisp_Object *)&sp;
2681 #endif
2682 #ifdef __cplusplus
2683 errorset_msg = NULL;
2684 try
2685 #else
2686 #ifdef USE_SIGALTSTACK
2687 sigjmp_buf this_level;
2688 #else
2689 jmp_buf this_level;
2690 #endif
2691 errorset_buffer = &this_level;
2692 errorset_msg = NULL;
2693 #ifdef USE_SIGALTSTACK
2694 if (!sigsetjmp(this_level, -1))
2695 #else
2696 if (!setjmp(this_level))
2697 #endif
2698 #endif
2699 {
2700 #ifndef UNDER_CE
2701 signal(SIGFPE, low_level_signal_handler);
2702 if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
2703 #ifdef SIGBUS
2704 if (segvtrap) signal(SIGBUS, low_level_signal_handler);
2705 #endif
2706 #ifdef SIGILL
2707 if (segvtrap) signal(SIGILL, low_level_signal_handler);
2708 #endif
2709 #endif
2710 non_terminal_input = NULL;
2711 #ifdef SOCKETS
2712 if (socket_server)
2713 { ensure_screen();
2714 procedural_input = char_from_socket;
2715 procedural_output = char_to_socket;
2716 lisp_main();
2717 ensure_screen();
2718 procedural_input = NULL;
2719 procedural_output = NULL;
2720 }
2721 else
2722 #endif
2723 #ifdef WINDOW_SYSTEM
2724 terminal_eof_seen = 0;
2725 #endif
2726 if (number_of_input_files == 0) lisp_main();
2727 else
2728 { int i;
2729 for (i=0; i<number_of_input_files; i++)
2730 { if (strcmp(files_to_read[i], "-") == 0)
2731 { non_terminal_input = NULL;
2732 #ifdef WINDOW_SYSTEM
2733 terminal_eof_seen = 0;
2734 #endif
2735 lisp_main();
2736 }
2737 else
2738 { char filename[LONGEST_LEGAL_FILENAME];
2739 FILE *f = open_file(filename, files_to_read[i],
2740 strlen(files_to_read[i]), "r", NULL);
2741 if (f == NULL)
2742 err_printf("\n+++ Could not read file \"%s\"\n",
2743 files_to_read[i]);
2744 else
2745 { if (init_flags & INIT_VERBOSE)
2746 term_printf("\n+++ About to read file \"%s\"\n",
2747 files_to_read[i]);
2748 report_file(filename);
2749 non_terminal_input = f;
2750 lisp_main();
2751 fclose(f);
2752 }
2753 }
2754 }
2755 }
2756 }
2757 #ifdef __cplusplus
2758 catch (char *)
2759 #else
2760 else
2761 #endif
2762 { if (errorset_msg != NULL)
2763 { term_printf("\n%s detected\n", errorset_msg);
2764 errorset_msg = NULL;
2765 }
2766 return;
2767 }
2768 }
2769
cslfinish(character_writer * w)2770 int cslfinish(character_writer *w)
2771 {
2772 #ifdef CONSERVATIVE
2773 volatile Lisp_Object sp;
2774 C_stackbase = (Lisp_Object *)&sp;
2775 #endif
2776 procedural_output = w;
2777 if (Ifinished())
2778 term_printf("\n+++ Errors on checkpoint-image file\n");
2779 #ifdef TRACED_EQUAL
2780 dump_equals();
2781 #endif
2782 /*
2783 * clock_t is an arithmetic type but I do not know what sort - so I
2784 * widen to double to do arithmetic on it. Actually what I MUST do is
2785 * to compute a time difference in the type clock_t and hope I never
2786 * get a difference that that overflows. The worst case I know of overflows
2787 * after 35 minutes.
2788 */
2789 if (init_flags & INIT_VERBOSE)
2790 { long int t = (long int)(100.0 * (consolidated_time[0] +
2791 (double)(read_clock() - base_time)/
2792 (double)CLOCKS_PER_SEC));
2793 long int gct = (long int)(100.0 * gc_time);
2794 term_printf("\n\nEnd of Lisp run after %ld.%.2ld+%ld.%.2ld seconds\n",
2795 t/100, t%100, gct/100, gct%100);
2796 }
2797 #ifdef DEBUG_SOFTWARE_TICKS
2798 term_printf("%d ticks processed (%d)\n",
2799 number_of_ticks, SOFTWARE_TICKS);
2800 #endif
2801 drop_heap_segments();
2802 if (spool_file != NULL)
2803 {
2804 #ifdef COMMON
2805 fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name);
2806 #else
2807 fprintf(spool_file, "\n+++ Transcript closed at end of run +++\n");
2808 #endif
2809 #ifndef DEBUG
2810 fclose(spool_file);
2811 spool_file = NULL;
2812 #endif
2813 }
2814 ensure_screen();
2815 procedural_output = NULL;
2816 return return_code;
2817 }
2818
execute_lisp_function(char * fname,character_reader * r,character_writer * w)2819 int execute_lisp_function(char *fname,
2820 character_reader *r,
2821 character_writer *w)
2822 {
2823 Lisp_Object nil;
2824 Lisp_Object ff;
2825 #ifdef CONSERVATIVE
2826 volatile Lisp_Object sp;
2827 C_stackbase = (Lisp_Object *)&sp;
2828 #endif
2829 ff = make_undefined_symbol(fname);
2830 nil = C_nil;
2831 if (exception_pending())
2832 { flip_exception();
2833 return 1; /* Failed to make the symbol */
2834 }
2835 procedural_input = r;
2836 procedural_output = w;
2837 Lapply0(nil, ff);
2838 ensure_screen();
2839 procedural_input = NULL;
2840 procedural_output = NULL;
2841 nil = C_nil;
2842 if (exception_pending())
2843 { flip_exception();
2844 return 2; /* Failure during evaluation */
2845 }
2846 return 0;
2847 }
2848
2849 /*
2850 * People who want to use this in an embedded context can predefine
2851 * NO_STARTUP_CODE and provide their own entrypoint...
2852 */
2853
2854 #ifndef NO_STARTUP_CODE
2855
2856 /*
2857 * The next fragment of code is to help with the use of CSL (and hence
2858 * packages written in Lisp and supported under CSL) as OEM products
2859 * embedded within larger C-coded packages. There is (of course) a
2860 * significant issue about clashes between the names of external symbols
2861 * if CSL is to be linked with anything else, but I will not worry about that
2862 * just yet.
2863 * The protocol for calling Lisp code from C is as follows:
2864 *
2865 * cslstart(argc, argv, writer);allocate memory and Lisp heap etc. Args
2866 * should be "as if" CSL was being called
2867 * directly and this was the main entrypoint.
2868 * The extra arg accepts output from this
2869 * stage. Use NULL to get standard I/O.
2870 * execute_lisp_function(fname, reader, writer);
2871 * fname is a (C) string that names a Lisp
2872 * function of 0 args. This is called with
2873 * stdin/stdout access redirected to use the
2874 * two character-at-a-time functions passed
2875 * down. [Value returned indicates if
2876 * the evaluation succeeded?]
2877 * cslfinish(writer); Tidies up ready to stop.
2878 */
2879
2880 #ifdef SAMPLE_OF_PROCEDURAL_INTERFACE
2881
2882 static char ibuff[100], obuff[100];
2883 static int ibufp = 0, obufp = 0;
iget()2884 static int iget()
2885 {
2886 int c = ibuff[ibufp++];
2887 if (c == 0) return EOF;
2888 else return c;
2889 }
2890
iput(int c)2891 static void iput(int c)
2892 {
2893 if (obufp < sizeof(obuff)-1)
2894 { obuff[obufp++] = c;
2895 obuff[obufp] = 0;
2896 }
2897 }
2898
2899 #endif
2900
submain(int argc,char * argv[])2901 static int submain(int argc, char *argv[])
2902 {
2903 cslstart(argc, argv, NULL);
2904 #ifdef SAMPLE_OF_PROCEDURAL_INTERFACE
2905 strcpy(ibuff, "(print '(a b c d))");
2906 execute_lisp_function("oem-supervisor", iget, iput);
2907 printf("Buffered output is <%s>\n", obuff);
2908 #else
2909 if (module_enquiry == NULL) cslaction();
2910 #endif
2911 my_exit(cslfinish(NULL));
2912 /*
2913 * The "return 0" here is unreachable but it still quietens down as many
2914 * C compilers as it causes to moan noisily!
2915 */
2916 return 0;
2917 }
2918
2919 #if defined HAVE_FWIN && !defined EMBEDDED
2920 #define ENTRYPOINT fwin_main
2921
2922 extern int ENTRYPOINT(int argc, char *argv[]);
2923
main(int argc,char * argv[])2924 int main(int argc, char *argv[])
2925 {
2926 fwin_set_lookup(look_in_lisp_variable);
2927 return fwin_startup(argc, argv, ENTRYPOINT);
2928 }
2929
2930 #else
2931 #define ENTRYPOINT main
2932 #endif
2933
2934
ENTRYPOINT(int argc,char * argv[])2935 int ENTRYPOINT(int argc, char *argv[])
2936 {
2937 int res;
2938 #ifdef EMBEDDED
2939 if (find_program_directory(argv[0]))
2940 { fprintf(stderr, "Unable to identify program name and directory\n");
2941 return 1;
2942 }
2943 #endif
2944 #ifdef USE_MPI
2945 MPI_Init(&argc,&argv);
2946 MPI_Comm_rank(MPI_COMM_WORLD,&mpi_rank);
2947 MPI_Comm_size(MPI_COMM_WORLD,&mpi_size);
2948 printf("I am mpi instance %d of %d.\n", mpi_rank+1, mpi_size);
2949 #endif
2950
2951 #ifdef HAVE_FWIN
2952 strcpy(about_box_title, "About CSL");
2953 strcpy(about_box_description, "Codemist Standard Lisp");
2954 #endif
2955 #ifdef __cplusplus
2956 try { res = submain(argc, argv); }
2957 catch(int r) { res = r; }
2958 #else
2959 #ifdef USE_SIGALTSTACK
2960 if (!sigsetjmp(my_exit_buffer, -1)) res = submain(argc, argv);
2961 #else
2962 if (!setjmp(my_exit_buffer)) res = submain(argc, argv);
2963 #endif
2964 else res = my_return_code;
2965 #endif
2966 #ifdef USE_MPI
2967 MPI_Finalize();
2968 #endif
2969 return res;
2970 }
2971
2972 #endif /* NO_STARTUP_CODE */
2973
2974 /*
2975 * And here are some functions that may help use Reduce, as an alternative
2976 * to the very general escape that execute_lisp_function provides... If
2977 * these return an integer it will genarlly be zero for success and non-
2978 * zero for failure.
2979 */
2980
2981 /*
2982 * After having called cslstart() you can set the I/O callback functions
2983 * using this. If you set one or both to NULL this indicates use of
2984 * stdin/stdout as per usual rather than an callback, otherwise whenever
2985 * anybody wants to read or write they use these procedures. It is then
2986 * your responsibility to cope with whatever text gets exchanged!
2987 */
2988
PROC_set_callbacks(character_reader * r,character_writer * w)2989 int PROC_set_callbacks(character_reader *r,
2990 character_writer *w)
2991 {
2992 Lisp_Object nil;
2993 procedural_input = r;
2994 procedural_output = w;
2995 return 0; /* can never report failure */
2996 }
2997
PROC_load_package(char * name)2998 int PROC_load_package(char *name)
2999 {
3000 Lisp_Object nil = C_nil;
3001 Lisp_Object w = nil, w1 = nil;
3002 #ifdef CONSERVATIVE
3003 volatile Lisp_Object sp;
3004 C_stackbase = (Lisp_Object *)&sp;
3005 #endif
3006 w1 = make_undefined_symbol("load-package");
3007 nil = C_nil;
3008 if (exception_pending())
3009 { flip_exception();
3010 return 1; /* Failed to make the load-package */
3011 }
3012 push(w1);
3013 w = make_undefined_symbol(name);
3014 nil = C_nil;
3015 if (exception_pending())
3016 { flip_exception();
3017 return 2; /* Failed to make name */
3018 }
3019 pop(w1);
3020 Lapply1(nil, w1, w);
3021 nil = C_nil;
3022 if (exception_pending())
3023 { flip_exception();
3024 return 3; /* Failed to load the package */
3025 }
3026 return 0;
3027 }
3028
PROC_set_switch(char * name,int val)3029 int PROC_set_switch(char *name, int val)
3030 {
3031 Lisp_Object nil = C_nil;
3032 Lisp_Object w = nil, w1 = nil;
3033 #ifdef CONSERVATIVE
3034 volatile Lisp_Object sp;
3035 C_stackbase = (Lisp_Object *)&sp;
3036 #endif
3037 w1 = make_undefined_symbol("onoff");
3038 nil = C_nil;
3039 if (exception_pending())
3040 { flip_exception();
3041 return 1; /* Failed to make the onoff */
3042 }
3043 push(w1);
3044 w = make_undefined_symbol(name);
3045 pop(w1);
3046 nil = C_nil;
3047 if (exception_pending())
3048 { flip_exception();
3049 return 2; /* Failed to make name */
3050 }
3051 Lapply2(nil, 3, w1, w, val == 0 ? nil : lisp_true);
3052 nil = C_nil;
3053 if (exception_pending())
3054 { flip_exception();
3055 return 3; /* Failed to set the switch */
3056 }
3057 return 0;
3058 }
3059
PROC_gc_messages(int n)3060 int PROC_gc_messages(int n)
3061 {
3062 Lisp_Object nil = C_nil;
3063 Lverbos(nil, fixnum_of_int(n)); /* can not fail */
3064 return 0;
3065 }
3066
3067 /*
3068 * Expressions are entered in Reverse Polish Notation, This call clears
3069 * the stack. It is probably only wanted if there has been an error
3070 * of some sort.
3071 */
3072
PROC_clear_stack()3073 int PROC_clear_stack()
3074 {
3075 Lisp_Object nil = C_nil;
3076 procstack = nil;
3077 return 0; /* can never fail! */
3078 }
3079
3080 /*
3081 * The RPN stack is used to build a prefix-form expression for
3082 * evaluation. This code creates a Lisp symbol and pushes it.
3083 */
3084
PROC_push_symbol(const char * name)3085 int PROC_push_symbol(const char *name)
3086 {
3087 Lisp_Object nil = C_nil;
3088 Lisp_Object w = nil;
3089 #ifdef CONSERVATIVE
3090 volatile Lisp_Object sp;
3091 C_stackbase = (Lisp_Object *)&sp;
3092 #endif
3093 w = make_undefined_symbol(name);
3094 nil = C_nil;
3095 if (exception_pending())
3096 { flip_exception();
3097 return 1; /* Failed to make the symbol */
3098 }
3099 w = cons(w, procstack);
3100 nil = C_nil;
3101 if (exception_pending())
3102 { flip_exception();
3103 return 2; /* Failed to push onto stack */
3104 }
3105 procstack = w;
3106 return 0;
3107 }
3108
3109
3110 /*
3111 * stack = the-string . stack;
3112 */
3113
PROC_push_string(const char * data)3114 int PROC_push_string(const char *data)
3115 {
3116 Lisp_Object nil = C_nil;
3117 Lisp_Object w = nil;
3118 #ifdef CONSERVATIVE
3119 volatile Lisp_Object sp;
3120 C_stackbase = (Lisp_Object *)&sp;
3121 #endif
3122 w = make_string(data);
3123 nil = C_nil;
3124 if (exception_pending())
3125 { flip_exception();
3126 return 1; /* Failed to make the string */
3127 }
3128 w = cons(w, procstack);
3129 nil = C_nil;
3130 if (exception_pending())
3131 { flip_exception();
3132 return 2; /* Failed to push onto stack */
3133 }
3134 procstack = w;
3135 return 0;
3136 }
3137
3138 /*
3139 * Return a handle to the top item on the stack, and pop the stack.
3140 * The value here will be a RAW LISP structure and NOT at all necessarily
3141 * anything neat.
3142 */
3143
3144 /*
3145 * Push an integer, which should fit within the constraints of a
3146 * 28-bit fixnum.
3147 */
3148
PROC_push_small_integer(int32_t n)3149 int PROC_push_small_integer(int32_t n)
3150 {
3151 Lisp_Object nil = C_nil;
3152 Lisp_Object w = nil;
3153 #ifdef CONSERVATIVE
3154 volatile Lisp_Object sp;
3155 C_stackbase = (Lisp_Object *)&sp;
3156 #endif
3157 if (n > 0x07ffffff || n < -0x08000000)
3158 { w = make_one_word_bignum(n);
3159 nil = C_nil;
3160 if (exception_pending())
3161 { flip_exception();
3162 return 1; /* Failed to create number */
3163 }
3164 }
3165 else w = fixnum_of_int((Lisp_Object)n);
3166 w = cons(w, procstack);
3167 nil = C_nil;
3168 if (exception_pending())
3169 { flip_exception();
3170 return 2; /* Failed to push onto stack */
3171 }
3172 procstack = w;
3173 return 0;
3174 }
3175
PROC_push_big_integer(const char * n)3176 int PROC_push_big_integer(const char *n)
3177 {
3178 Lisp_Object nil = C_nil;
3179 Lisp_Object w = nil;
3180 int len = 0;
3181 #ifdef CONSERVATIVE
3182 volatile Lisp_Object sp;
3183 C_stackbase = (Lisp_Object *)&sp;
3184 #endif
3185 /* Here I need to parse a C string to obtain a Lisp number. */
3186 boffop = 0;
3187 while (*n != 0)
3188 { packbyte(*n++);
3189 len++;
3190 nil = C_nil;
3191 if (exception_pending())
3192 { flip_exception();
3193 return 1; /* boffo trouble */
3194 }
3195 }
3196 w = intern(len, 0);
3197 nil = C_nil;
3198 if (exception_pending())
3199 { flip_exception();
3200 return 2; /* conversion to number */
3201 }
3202 w = cons(w, procstack);
3203 nil = C_nil;
3204 if (exception_pending())
3205 { flip_exception();
3206 return 3; /* Failed to push onto stack */
3207 }
3208 procstack = w;
3209 return 0;
3210 }
3211
PROC_push_floating(double n)3212 int PROC_push_floating(double n)
3213 {
3214 Lisp_Object nil = C_nil;
3215 Lisp_Object w = nil;
3216 #ifdef CONSERVATIVE
3217 volatile Lisp_Object sp;
3218 C_stackbase = (Lisp_Object *)&sp;
3219 #endif
3220 /* Here I have to construct a Lisp (boxed) float */
3221 w = make_boxfloat(n, TYPE_DOUBLE_FLOAT);
3222 nil = C_nil;
3223 if (exception_pending())
3224 { flip_exception();
3225 return 1; /* Failed to create the float */
3226 }
3227 w = cons(w, procstack);
3228 nil = C_nil;
3229 if (exception_pending())
3230 { flip_exception();
3231 return 2; /* Failed to push onto stack */
3232 }
3233 procstack = w;
3234 return 0;
3235 }
3236
3237 /*
3238 * To make an expression
3239 * (f a1 a2 a3)
3240 * you go
3241 * push(a1)
3242 * push(a2)
3243 * push(a3)
3244 * make_function_call("f", 3)
3245 */
3246
PROC_make_function_call(const char * name,int n)3247 int PROC_make_function_call(const char *name, int n)
3248 {
3249 Lisp_Object nil = C_nil;
3250 Lisp_Object w = nil, w1 = nil;
3251 #ifdef CONSERVATIVE
3252 volatile Lisp_Object sp;
3253 C_stackbase = (Lisp_Object *)&sp;
3254 #endif
3255 while (n > 0)
3256 { if (procstack == nil) return 1; /* Not enough args available */
3257 w = cons(qcar(procstack), w);
3258 nil = C_nil;
3259 if (exception_pending())
3260 { flip_exception();
3261 return 2; /* Failed to push onto stack */
3262 }
3263 procstack = qcdr(procstack);
3264 n--;
3265 }
3266 push(w);
3267 w1 = make_undefined_symbol(name);
3268 pop(w);
3269 nil = C_nil;
3270 if (exception_pending())
3271 { flip_exception();
3272 return 3; /* Failed to create function name */
3273 }
3274 w = cons(w1, w);
3275 nil = C_nil;
3276 if (exception_pending())
3277 { flip_exception();
3278 return 4; /* Failed to cons on function name */
3279 }
3280 w = cons(w, procstack);
3281 nil = C_nil;
3282 if (exception_pending())
3283 { flip_exception();
3284 return 5; /* Failed to push onto stack */
3285 }
3286 procstack = w;
3287 return 0;
3288 }
3289
3290 /*
3291 * Take the top item on the stack and save it in location n (0 <= n <= 99).
3292 */
3293
PROC_save(int n)3294 int PROC_save(int n)
3295 {
3296 Lisp_Object nil = C_nil;
3297 if (n < 0 || n > 99) return 1; /* index out of range */
3298 if (procstack == nil) return 2; /* Nothing available to save */
3299 elt(procmem, n) = qcar(procstack);
3300 procstack = qcdr(procstack);
3301 return 0;
3302 }
3303
3304 /*
3305 * Push onto the stack the value saved at location n. See PROC_save.
3306 */
3307
PROC_load(int n)3308 int PROC_load(int n)
3309 {
3310 Lisp_Object nil = C_nil;
3311 Lisp_Object w = nil;
3312 #ifdef CONSERVATIVE
3313 volatile Lisp_Object sp;
3314 C_stackbase = (Lisp_Object *)&sp;
3315 #endif
3316 if (n < 0 || n > 99) return 1; /* index out of range */
3317 w = elt(procmem, n);
3318 w = cons(w, procstack);
3319 nil = C_nil;
3320 if (exception_pending())
3321 { flip_exception();
3322 return 2; /* Failed to push onto stack */
3323 }
3324 procstack = w;
3325 return 0;
3326 }
3327
3328 /*
3329 * Duplicate the top item on the stack.
3330 */
3331
PROC_dup()3332 int PROC_dup()
3333 {
3334 Lisp_Object nil = C_nil;
3335 Lisp_Object w = nil;
3336 #ifdef CONSERVATIVE
3337 volatile Lisp_Object sp;
3338 C_stackbase = (Lisp_Object *)&sp;
3339 #endif
3340 if (procstack == nil) return 1; /* no item to duplicate */
3341 w = qcar(procstack);
3342 w = cons(w, procstack);
3343 nil = C_nil;
3344 if (exception_pending())
3345 { flip_exception();
3346 return 2; /* Failed to push onto stack */
3347 }
3348 procstack = w;
3349 return 0;
3350 }
3351
PROC_pop()3352 int PROC_pop()
3353 {
3354 Lisp_Object nil = C_nil;
3355 if (procstack == nil) return 1; /* stack is empty */
3356 procstack = qcdr(procstack);
3357 return 0;
3358 }
3359
3360 /*
3361 * Replaces the top item on the stack with a simplified version of
3362 * itself. For experts on Reduce internals I note that this wraps
3363 * the simplified form up in a prefix-like "!*sq" wrapper so it can
3364 * still be used in a prefix context.
3365 */
3366
PROC_simplify()3367 int PROC_simplify()
3368 {
3369 Lisp_Object nil = C_nil;
3370 Lisp_Object w = nil, w1 = nil;
3371 #ifdef CONSERVATIVE
3372 volatile Lisp_Object sp;
3373 C_stackbase = (Lisp_Object *)&sp;
3374 #endif
3375 if (procstack == nil) return 1; /* stack is empty */
3376 w = make_undefined_symbol("simp");
3377 nil = C_nil;
3378 if (exception_pending())
3379 { flip_exception();
3380 return 2; /* Failed find "simp" */
3381 }
3382 w = Lapply1(nil, w, qcar(procstack));
3383 nil = C_nil;
3384 if (exception_pending())
3385 { flip_exception();
3386 return 3; /* Call to simp failed */
3387 }
3388 push(w);
3389 w1 = make_undefined_symbol("mk*sq");
3390 pop(w);
3391 nil = C_nil;
3392 if (exception_pending())
3393 { flip_exception();
3394 return 4; /* Failed to find "mk!*sq" */
3395 }
3396 w = Lapply1(nil, w1, w);
3397 nil = C_nil;
3398 if (exception_pending())
3399 { flip_exception();
3400 return 5; /* Call to mk!*sq failed */
3401 }
3402 qcar(procstack) = w;
3403 return 0;
3404 }
3405
3406 /*
3407 * Replace the top item on the stack with whatever is obtained by using
3408 * the Lisp EVAL operatio on it. Note that this is not intended for
3409 * casual use - if there is any functionality that you need PLEASE ask
3410 * me to put in a cleaner abstraction to support it.
3411 */
3412
PROC_standardise_gensyms(Lisp_Object w)3413 static void PROC_standardise_gensyms(Lisp_Object w)
3414 {
3415 Lisp_Object nil = C_nil;
3416 if (consp(w))
3417 { push(qcdr(w));
3418 PROC_standardise_gensyms(qcar(w));
3419 pop(w);
3420 errexitv();
3421 PROC_standardise_gensyms(w);
3422 return;
3423 }
3424 /*
3425 * Now w is atomic. The only case that concerns me is if it is a gensym.
3426 */
3427 if (symbolp(w)) get_pname(w); /* allocates gensym name if needed. */
3428 }
3429
PROC_lisp_eval()3430 int PROC_lisp_eval()
3431 {
3432 Lisp_Object nil = C_nil;
3433 Lisp_Object w = nil, w1 = nil;
3434 #ifdef CONSERVATIVE
3435 volatile Lisp_Object sp;
3436 C_stackbase = (Lisp_Object *)&sp;
3437 #endif
3438 if (procstack == nil) return 1; /* stack is empty */
3439 w = Ceval(qcar(procstack), nil);
3440 nil = C_nil;
3441 if (exception_pending())
3442 { flip_exception();
3443 return 2; /* Evaluation failed */
3444 }
3445 push(w);
3446 PROC_standardise_gensyms(w);
3447 pop(w);
3448 nil = C_nil;
3449 if (exception_pending())
3450 { flip_exception();
3451 return 3; /* gensym patchup failed */
3452 }
3453 qcar(procstack) = w;
3454 return 0;
3455 }
3456
PROC_standardise_printed_form(Lisp_Object w)3457 static Lisp_Object PROC_standardise_printed_form(Lisp_Object w)
3458 {
3459 Lisp_Object nil = C_nil, w1;
3460 if (consp(w))
3461 { push(qcdr(w));
3462 w1 = PROC_standardise_printed_form(qcar(w));
3463 pop(w);
3464 errexit();
3465 push(w1);
3466 w = PROC_standardise_printed_form(w);
3467 pop(w1);
3468 errexit();
3469 return cons(w1, w);
3470 }
3471 /*
3472 * Now w is atomic. There are two interesting cases - an unprinted gensym
3473 * and a bignum.
3474 */
3475 if (symbolp(w))
3476 { push(w);
3477 get_pname(w); /* allocates gensym name if needed. Otherwise cheap! */
3478 pop(w);
3479 errexit();
3480 return w;
3481 }
3482 else if (is_numbers(w) && is_bignum(w))
3483 { w = Lexplode(nil, w); /* Bignum to list of digits */
3484 errexit();
3485 w = Llist_to_string(nil, w); /* list to string */
3486 errexit();
3487 return w;
3488 }
3489 else return w;
3490 }
3491
3492 /*
3493 * Replaces the top item on the stack with version that is in
3494 * a simple prefix form. This prefix form should be viewed as
3495 * unsuitable for inclusion in any further expression.
3496 */
3497
PROC_make_printable()3498 int PROC_make_printable()
3499 {
3500 Lisp_Object nil = C_nil;
3501 Lisp_Object w = nil, w1 = nil;
3502 #ifdef CONSERVATIVE
3503 volatile Lisp_Object sp;
3504 C_stackbase = (Lisp_Object *)&sp;
3505 #endif
3506 if (procstack == nil) return 1; /* stack is empty */
3507 /*
3508 * I want to use "simp" again so that I can then use prepsq!
3509 */
3510 w = make_undefined_symbol("simp");
3511 nil = C_nil;
3512 if (exception_pending())
3513 { flip_exception();
3514 return 2; /* Failed find "simp" */
3515 }
3516 w = Lapply1(nil, w, qcar(procstack));
3517 nil = C_nil;
3518 if (exception_pending())
3519 { flip_exception();
3520 return 3; /* Call to simp failed */
3521 }
3522 push(w);
3523 w1 = make_undefined_symbol("prepsq");
3524 pop(w);
3525 nil = C_nil;
3526 if (exception_pending())
3527 { flip_exception();
3528 return 4; /* Failed to find "prepsq" */
3529 }
3530 w = Lapply1(nil, w1, w);
3531 nil = C_nil;
3532 if (exception_pending())
3533 { flip_exception();
3534 return 5; /* Call to prepsq failed */
3535 }
3536 /*
3537 * There are going to be two things I do next. One is to ensure that
3538 * all gensyms have print-names, the other is to convert bignums into
3539 * strings. Both of these could be viewed as mildly obscure!
3540 */
3541 w = PROC_standardise_printed_form(w);
3542 nil = C_nil;
3543 if (exception_pending())
3544 { flip_exception();
3545 return 6; /* standardise_printed_form failed */
3546 }
3547 qcar(procstack) = w;
3548 return 0;
3549 }
3550
PROC_get_value()3551 PROC_handle PROC_get_value()
3552 {
3553 Lisp_Object nil = C_nil;
3554 Lisp_Object w;
3555 if (procstack == C_nil) w = fixnum_of_int(0);
3556 else
3557 { w = qcar(procstack);
3558 procstack = qcdr(procstack);
3559 }
3560 return (PROC_handle)w;
3561 }
3562
PROC_get_raw_value()3563 PROC_handle PROC_get_raw_value()
3564 {
3565 Lisp_Object nil = C_nil;
3566 Lisp_Object w;
3567 if (procstack == C_nil) w = nil;
3568 else
3569 { w = qcar(procstack);
3570 procstack = qcdr(procstack);
3571 }
3572 return (PROC_handle)w;
3573 }
3574
3575 /*
3576 * return true if the expression is atomic.
3577 */
3578
PROC_atom(PROC_handle p)3579 int PROC_atom(PROC_handle p)
3580 {
3581 return !consp((Lisp_Object)p);
3582 }
3583
3584 /*
3585 * return true if the expression is NIL.
3586 */
3587
PROC_null(PROC_handle p)3588 int PROC_null(PROC_handle p)
3589 {
3590 return ((Lisp_Object)p) == C_nil;
3591 }
3592
3593 /*
3594 * Return true if it is a small integer.
3595 */
3596
PROC_fixnum(PROC_handle p)3597 int PROC_fixnum(PROC_handle p)
3598 {
3599 return is_fixnum((Lisp_Object)p);
3600 }
3601
PROC_string(PROC_handle p)3602 int PROC_string(PROC_handle p)
3603 {
3604 return is_vector((Lisp_Object)p) &&
3605 type_of_header(vechdr((Lisp_Object)p)) == TYPE_STRING;
3606 }
3607
PROC_floatnum(PROC_handle p)3608 int PROC_floatnum(PROC_handle p)
3609 {
3610 /*
3611 * I ignore the "sfloat" representation that would be relevant in Common
3612 * Lisp mode. It is not used with Reduce.
3613 */
3614 return is_bfloat((Lisp_Object)p);
3615 }
3616
3617 /*
3618 * Return true if it is a symbol.
3619 */
3620
PROC_symbol(PROC_handle p)3621 int PROC_symbol(PROC_handle p)
3622 {
3623 return symbolp((Lisp_Object)p);
3624 }
3625
3626 /*
3627 * Given that it is a small integer return the integer value
3628 */
3629
PROC_integer_value(PROC_handle p)3630 int32_t PROC_integer_value(PROC_handle p)
3631 {
3632 return (int32_t)int_of_fixnum((Lisp_Object)p);
3633 }
3634
PROC_floating_value(PROC_handle p)3635 double PROC_floating_value(PROC_handle p)
3636 {
3637 return double_float_val((Lisp_Object)p);
3638 }
3639
3640 /*
3641 * Given that it is a symbol, return a string that is its name. Note
3642 * that this must not be too long, and that the value returned is in
3643 * a static buffer. Note that this would crash if the item was a
3644 * "gensym" that had not been printed before, and so I take care to
3645 * sort that out in PROC_make_printable.
3646 * Hmmm the name-length restriction here is ugly _ will wait and see how
3647 * long it is before somebody falls foul of it!
3648 */
3649
3650 static char PROC_name[256];
3651
PROC_symbol_name(PROC_handle p)3652 const char *PROC_symbol_name(PROC_handle p)
3653 {
3654 Lisp_Object w = (Lisp_Object)p;
3655 int n;
3656 w = qpname(w);
3657 n = length_of_header(vechdr(w)) - CELL;
3658 if (n > sizeof(PROC_name)-1) n = sizeof(PROC_name)-1;
3659 strncpy(PROC_name, &celt(w, 0), n);
3660 PROC_name[n] = 0;
3661 return &PROC_name[0];
3662 }
3663
PROC_string_data(PROC_handle p)3664 const char *PROC_string_data(PROC_handle p)
3665 {
3666 Lisp_Object w = (Lisp_Object)p;
3667 int n;
3668 n = length_of_header(vechdr(w)) - CELL;
3669 /*
3670 * NOTE that I truncate long strings here. Boo Hiss! This may make a mess
3671 * of dealing with big numbers, so in due course I will need to fix it!
3672 */
3673 if (n > sizeof(PROC_name)-1) n = sizeof(PROC_name)-1;
3674 strncpy(PROC_name, &celt(w, 0), n);
3675 PROC_name[n] = 0;
3676 return &PROC_name[0];
3677 }
3678
3679 /*
3680 * First and rest allow list traversal.
3681 */
3682
PROC_first(PROC_handle p)3683 PROC_handle PROC_first(PROC_handle p)
3684 {
3685 return (PROC_handle)qcar((Lisp_Object)p);
3686 }
3687
PROC_rest(PROC_handle p)3688 PROC_handle PROC_rest(PROC_handle p)
3689 {
3690 return (PROC_handle)qcdr((Lisp_Object)p);
3691 }
3692
3693
3694 /* End of csl.c */
3695
3696