1 // restart.cpp Copyright (C) 1989-2021 Codemist
2
3 //
4 // Code needed to start off Lisp when no initial heap image is available,
5 // or to re-instate links between heap and C-coded core if there IS a
6 // heap loaded. This code is run in a state that is in effect (in-package
7 // "lisp").
8 //
9
10 /**************************************************************************
11 * Copyright (C) 2021, Codemist. A C Norman *
12 * *
13 * Redistribution and use in source and binary forms, with or without *
14 * modification, are permitted provided that the following conditions are *
15 * met: *
16 * *
17 * * Redistributions of source code must retain the relevant *
18 * copyright notice, this list of conditions and the following *
19 * disclaimer. *
20 * * Redistributions in binary form must reproduce the above *
21 * copyright notice, this list of conditions and the following *
22 * disclaimer in the documentation and/or other materials provided *
23 * with the distribution. *
24 * *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
26 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
27 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
28 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
29 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
30 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
31 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
32 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
33 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
34 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
35 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
36 * DAMAGE. *
37 *************************************************************************/
38
39 // $Id: restart.cpp 5745 2021-03-20 17:35:28Z arthurcnorman $
40
41 #include "headers.h"
42
43 #ifdef WIN32
44 #include <windows.h>
45 #else
46 #ifndef EMBEDDED
47 #include <dlfcn.h>
48 #endif
49 #endif
50
51 #ifdef HAVE_UNISTD_H
52 #include <unistd.h>
53 #endif
54
55 #include <sys/stat.h>
56 #include <sys/types.h>
57
58 #include "md5.h"
59
60 extern int showmathInitialised;
61
62 #ifndef S_IRUSR
63 #ifdef __S_IRUSR
64 #define S_IRUSR __S_IRUSR
65 #endif
66 #endif
67
68 #ifndef S_IWUSR
69 #ifdef __S_IWUSR
70 #define S_IWUSR __S_IWUSR
71 #endif
72 #endif
73
74 #ifndef S_IXUSR
75 #ifdef __S_IXUSR
76 #define S_IXUSR __S_IXUSR
77 #endif
78 #endif
79
80 LispObject nil;
81 LispObject *stackBase;
82 LispObject *stackLimit;
83
84 LispObject *nilsegment;
85 LispObject *stacksegment;
86 int32_t stack_segsize = 1;
87
88 char *exit_charvec = nullptr;
89 intptr_t exit_reason;
90
91 intptr_t nwork;
92 unsigned int exit_count;
93 uint64_t gensym_ser;
94 intptr_t print_precision, miscflags;
95 intptr_t current_modulus, fastget_size, package_bits,
96 modulus_is_large;
97 LispObject lisp_true, lambda, funarg, unset_var, opt_key, rest_key;
98 LispObject quote_symbol, function_symbol, comma_symbol,
99 comma_at_symbol;
100 LispObject cons_symbol, eval_symbol, apply_symbol, work_symbol,
101 evalhook;
102 LispObject list_symbol, liststar_symbol, eq_symbol, eql_symbol;
103 LispObject cl_equal_symbol, equal_symbol, equalp_symbol;
104 LispObject go_symbol, cond_symbol;
105 LispObject applyhook, macroexpand_hook, append_symbol, exit_tag;
106 LispObject exit_value, catch_tags, keyword_package, current_package;
107 LispObject startfn, all_packages, package_symbol, internal_symbol;
108 LispObject gcknt_symbol, external_symbol, inherited_symbol;
109 LispObject gensym_base, string_char_sym, boffo;
110 LispObject key_key, allow_other_keys, aux_key;
111 LispObject err_table, format_symbol, progn_symbol, expand_def_symbol;
112 LispObject allow_key_key, declare_symbol, special_symbol,
113 large_modulus;
114 LispObject lisp_work_stream, charvec, raise_symbol, lower_symbol,
115 echo_symbol;
116 LispObject codevec, litvec, supervisor, B_reg, savedef, comp_symbol;
117 LispObject compiler_symbol, faslvec, tracedfn, lisp_terminal_io;
118 LispObject lisp_standard_output, lisp_standard_input,
119 lisp_error_output;
120 LispObject lisp_trace_output, lisp_debug_io, lisp_query_io;
121 LispObject prompt_thing, faslgensyms, prinl_symbol, emsg_star,
122 redef_msg;
123 LispObject current_function, expr_symbol, fexpr_symbol, macro_symbol;
124 LispObject big_divisor, big_dividend, big_quotient, big_fake1,
125 big_fake2;
126 LispObject active_stream, current_module;
127 LispObject autoload_symbol, features_symbol, lisp_package;
128 LispObject sys_hash_table, sxhash_hash_table;
129 LispObject help_index, cfunarg, lex_words, get_counts, fastget_names;
130 LispObject input_libraries, output_library, current_file,
131 break_function;
132 LispObject standard_output, standard_input, debug_io;
133 LispObject error_output, query_io, terminal_io, trace_output,
134 fasl_stream;
135 LispObject startup_symbol, mv_call_symbol, traceprint_symbol,
136 load_source_symbol;
137 LispObject load_selected_source_symbol, bytecoded_symbol,
138 funcall_symbol;
139 LispObject gchook, resources, callstack, procstack, procmem,
140 trap_time;
141 LispObject used_space, avail_space, eof_symbol, call_stack;
142 LispObject nicknames_symbol, use_symbol, and_symbol, or_symbol,
143 not_symbol;
144 LispObject reader_workspace, named_character, read_float_format,
145 short_float;
146 LispObject single_float, double_float, long_float, bit_symbol,
147 pathname_symbol;
148 LispObject print_array_sym, read_base, initial_element;
149 LispObject builtin0_symbol, builtin1_symbol, builtin2_symbol;
150 LispObject builtin3_symbol, builtin4_symbol;
151
152 LispObject workbase[51];
153
154 LispObject user_base_0, user_base_1, user_base_2, user_base_3,
155 user_base_4;
156 LispObject user_base_5, user_base_6, user_base_7, user_base_8,
157 user_base_9;
158
159 LispObject eq_hash_tables;
160
161 char program_name[64] = {0};
162
163 //
164 // The tables here are slightly oddly formatted. Every other entry is
165 // nullptr (reserved for other uses...) and each string has a single character
166 // stuck on its front that is also used as a marker elsewhere...
167 //
168
169 char **loadable_packages = nullptr, **switches = nullptr;
170
171 bool trap_floating_overflow = false;
172
173 int procstackp;
174
175 entry_point0 entries_table0[] =
176 { {0, "illegal"},
177 {undefined_0, "undefined_0"},
178 {autoload_0, "autoload_0"},
179 {interpreted_0, "interpreted_0"},
180 {funarged_0, "funarged_0"},
181 {bytecoded_0, "bytecoded_0"},
182 {byteopt_0, "byteopt_0"},
183 {hardopt_0, "hardopt_0"},
184 {byteoptrest_0, "byteoptrest_0"},
185 {hardoptrest_0, "hardoptrest_0"},
186 {G0W1, "G0W1"},
187 {G0W2, "G0W2"},
188 {G0W3, "G0W3"},
189 {G0W4up, "G0W4up"},
190 {G0Wother, "G0Wother"},
191 {f0_as_0, "0->0"},
192 {nullptr, "dummy"}
193 };
194
195 #define entry_table_size0 ((int)(sizeof(entries_table0)/sizeof(entries_table0[0])))
196
197 entry_point1 entries_table1[] =
198 {
199 //
200 // All values that can go in the function cells of symbols to stand for
201 // special interpreter activity are kept here. In most cases where there
202 // is an entrypoint there is a corresponding one that behaves just the
203 // same except that it has tracing enabled.
204 //
205 {0, "illegal"},
206 // A few special forms that are set up manually so slip through the normal
207 // scheme...
208 {quote_fn, "quote"},
209 {progn_fn, "progn"},
210 {declare_fn, "declare"},
211 {function_fn, "function"},
212 {undefined_1, "undefined_1"},
213 {autoload_1, "autoload_1"},
214 {interpreted_1, "interpreted_1"},
215 {funarged_1, "funarged_1"},
216 {bytecoded_1, "bytecoded_1"},
217 {byteopt_1, "byteopt_1"},
218 {hardopt_1, "hardopt_1"},
219 {byteoptrest_1, "byteoptrest_1"},
220 {hardoptrest_1, "hardoptrest_1"},
221 {G1W0, "G1W0"},
222 {G1W2, "G1W2"},
223 {G1W3, "G1W3"},
224 {G1W4up, "G1W4up"},
225 {G1Wother, "G1Wother"},
226 // The batch here relate to function re-work that discards unwanted
227 // extra arguments.
228 {f1_as_0, "1->0"},
229 {f1_as_1, "1->1"},
230 {nullptr, "dummy"}
231 };
232
233 #define entry_table_size1 ((int)(sizeof(entries_table1)/sizeof(entries_table1[0])))
234
235 entry_point2 entries_table2[] =
236 { {0, "illegal"},
237 // A few special forms that are set up manually so slip through the normal
238 // scheme...
239 {(two_args *)quote_fn, "quote"},
240 {(two_args *)progn_fn, "progn"},
241 {(two_args *)declare_fn, "declare"},
242 {(two_args *)function_fn, "function"},
243 {undefined_2, "undefined_2"},
244 {G2W0, "G2W0"},
245 {G2W1, "G2W1"},
246 {G2W3, "G2W3"},
247 {G2W4up, "G2W4up"},
248 {G2Wother, "G2Wother"},
249 {autoload_2, "autoload_2"},
250 {interpreted_2, "interpreted_2"},
251 {funarged_2, "funarged_2"},
252 {bytecoded_2, "bytecoded_2"},
253 {byteopt_2, "byteopt_2"},
254 {hardopt_2, "hardopt_2"},
255 {byteoptrest_2, "byteoptrest_2"},
256 {hardoptrest_2, "hardoptrest_2"},
257 //
258 // The batch here relate to function re-work that discards unwanted
259 // extra arguments.
260 //
261 {f2_as_0, "2->0"},
262 {f2_as_1, "2->1"},
263 {f2_as_2, "2->2"},
264 {nullptr, "dummy"}
265 };
266
267 #define entry_table_size2 ((int)(sizeof(entries_table2)/sizeof(entries_table2[0])))
268
269 entry_point3 entries_table3[] =
270 { {0, "illegal"},
271 {undefined_3, "undefined_3"},
272 {autoload_3, "autoload_3"},
273 {interpreted_3, "interpreted_3"},
274 {funarged_3, "funarged_3"},
275 {bytecoded_3, "bytecoded_3"},
276 {byteopt_3, "byteopt_3"},
277 {hardopt_3, "hardopt_3"},
278 {byteoptrest_3, "byteoptrest_3"},
279 {hardoptrest_3, "hardoptrest_3"},
280 {G3W0, "G3W0"},
281 {G3W1, "G3W1"},
282 {G3W2, "G3W2"},
283 {G3W4up, "G3W4up"},
284 {G3Wother, "G3Wother"},
285 {f3_as_0, "3->0"},
286 {f3_as_1, "3->1"},
287 {f3_as_2, "3->2"},
288 {f3_as_3, "3->3"},
289 {nullptr, "dummy"}
290 };
291
292 #define entry_table_size3 ((int)(sizeof(entries_table3)/sizeof(entries_table3[0])))
293
294 entry_point4up entries_table4up[] =
295 { {0, "illegal"},
296 {undefined_4up, "undefined_4up"},
297 {autoload_4up, "autoload_4up"},
298 {interpreted_4up, "interpreted_4up"},
299 {funarged_4up, "funarged_4up"},
300 {bytecoded_4up, "bytecoded_4up"},
301 {byteopt_4up, "byteopt_4up"},
302 {hardopt_4up, "hardopt_4up"},
303 {byteoptrest_4up, "byteoptrest_4up"},
304 {hardoptrest_4up, "hardoptrest_4up"},
305 {G4W0, "G4W0"},
306 {G4W1, "G4W1"},
307 {G4W2, "G4W2"},
308 {G4W3, "G4W3"},
309 {G4Wother, "G4Wother"},
310 {nullptr, "dummy"}
311 };
312
313 #define entry_table_size4up ((int)(sizeof(entries_table4up)/sizeof(entries_table4up[0])))
314
315 entry_point1 entries_tableio[] =
316 { {0, "illegal"},
317 {(one_arg *)char_from_illegal, "char_from_illegal"},
318 {(one_arg *)char_to_illegal, "char_to_illegal"},
319 {(one_arg *)read_action_illegal, "read_action_illegal"},
320 {(one_arg *)write_action_illegal, "write_action_illegal"},
321 {(one_arg *)char_from_terminal, "char_from_terminal"},
322 {(one_arg *)char_to_terminal, "char_to_terminal"},
323 {(one_arg *)read_action_terminal, "read_action_terminal"},
324 {(one_arg *)write_action_terminal, "write_action_terminal"},
325 {(one_arg *)char_from_file, "char_from_file"},
326 {(one_arg *)char_to_file, "char_to_file"},
327 {(one_arg *)read_action_file, "read_action_file"},
328 {(one_arg *)read_action_output_file,"read_action_output_file"},
329 {(one_arg *)write_action_file, "write_action_file"},
330 {(one_arg *)binary_outchar, "binary_outchar"},
331 {(one_arg *)char_from_list, "char_from_list"},
332 {(one_arg *)char_to_list, "char_to_list"},
333 {(one_arg *)code_to_list, "code_to_list"},
334 {(one_arg *)read_action_list, "read_action_list"},
335 {(one_arg *)write_action_list, "write_action_list"},
336 {(one_arg *)count_character, "count_character"},
337 {(one_arg *)char_to_pipeout, "char_to_pipeout"},
338 {(one_arg *)write_action_pipe, "write_action_pipe"},
339 {(one_arg *)char_from_synonym, "char_from_synonym"},
340 {(one_arg *)char_to_synonym, "char_to_synonym"},
341 {(one_arg *)read_action_synonym, "read_action_synonym"},
342 {(one_arg *)write_action_synonym, "write_action_synonym"},
343 {(one_arg *)char_from_concatenated, "char_from_concatenated"},
344 {(one_arg *)char_to_broadcast, "char_to_broadcast"},
345 {(one_arg *)read_action_concatenated,"read_action_concatenated"},
346 {(one_arg *)write_action_broadcast, "write_action_broadcast"},
347 {(one_arg *)char_from_echo, "char_from_echo"},
348 {nullptr, "dummy"}
349 };
350
351 #define entry_table_sizeio ((int)(sizeof(entries_tableio)/sizeof(entries_tableio[0])))
352
Lreclaim_trap(LispObject env,LispObject a)353 static LispObject Lreclaim_trap(LispObject env, LispObject a)
354 { int64_t previous = reclaim_trap_count;
355 if (!is_fixnum(a)) return aerror1("reclaim-trap", a);
356 reclaim_trap_count = int_of_fixnum(a);
357 term_printf("+++ Reclaim trap set at %d, previous = %d\n",
358 reclaim_trap_count, previous);
359 return onevalue(fixnum_of_int(previous));
360 }
361
Lreclaim_stack_limit(LispObject env,LispObject a)362 static LispObject Lreclaim_stack_limit(LispObject env, LispObject a)
363 { intptr_t previous = reclaim_stack_limit;
364 if (!is_fixnum(a)) return aerror1("reclaim-stack-limit", a);
365 reclaim_stack_limit = int_of_fixnum(a);
366 term_printf("+++ Reclaim stack limit set at %d, previous = %d\n",
367 reclaim_stack_limit, previous);
368 return onevalue(fixnum_of_int(previous));
369 }
370
find_checksum(const char * name,size_t len,const setup_type * p)371 static const char *find_checksum(const char *name, size_t len,
372 const setup_type *p)
373 { const char *n;
374 while (p->name != nullptr) p++;
375 n = reinterpret_cast<const char *>(p->zero);
376 if (std::strlen(n) == len && std::memcmp(name, n, len) == 0)
377 return reinterpret_cast<const char *>(p->one);
378 else return nullptr;
379 }
380
381 setup_type const *setup_tables[] =
382 { u01_setup, u02_setup, u03_setup, u04_setup,
383 u05_setup, u06_setup, u07_setup, u08_setup, u09_setup,
384 u10_setup, u11_setup, u12_setup, u13_setup, u14_setup,
385 u15_setup, u16_setup, u17_setup, u18_setup, u19_setup,
386 u20_setup, u21_setup, u22_setup, u23_setup, u24_setup,
387 u25_setup, u26_setup, u27_setup, u28_setup, u29_setup,
388 u30_setup, u31_setup, u32_setup, u33_setup, u34_setup,
389 u35_setup, u36_setup, u37_setup, u38_setup, u39_setup,
390 u40_setup, u41_setup, u42_setup, u43_setup, u44_setup,
391 u45_setup, u46_setup, u47_setup, u48_setup, u49_setup,
392 u50_setup, u51_setup, u52_setup, u53_setup, u54_setup,
393 u55_setup, u56_setup, u57_setup, u58_setup, u59_setup,
394 u60_setup,
395 //
396 // I also include the kernel setup tables, but I put a nullptr in this
397 // table so it is easy to see where they start.
398 //
399 nullptr,
400 arith06_setup, arith08_setup, arith10_setup, arith12_setup,
401 arith13_setup, char_setup, eval1_setup, eval2_setup, eval3_setup,
402 funcs1_setup, funcs2_setup, funcs3_setup, lisphash_setup,
403 print_setup, read_setup, restart_setup, mpi_setup,
404 #ifdef ARITHLIB
405 arith_setup,
406 #endif
407 nullptr
408 };
409
410 //
411 // If C code is to be instated (via c!:install calls in u01.lsp etc) there
412 // needs to be a verification that the file u01.c and the file u01.lsp (etc)
413 // are in step. So once for each such file this does the check. It should
414 // only happen when the system is being built and ought not to be a big
415 // performance issue.
416 //
417
Lcheck_c_code(LispObject env,LispObject name,LispObject lc1,LispObject lc2,LispObject a4up)418 static LispObject Lcheck_c_code(LispObject env, LispObject name,
419 LispObject lc1, LispObject lc2, LispObject a4up)
420 { int32_t c1=-1, c2=-1, c3=-1;
421 long int x1=-2, x2=-2, x3=-2;
422 int32_t len;
423 const char *p;
424 const char *sname;
425 size_t i;
426 LispObject lc3 = arg4("check-c-code", a4up);
427 // This is called as when the system is about to install some linke between
428 // Lisp and code that has been compiled into C++. It is given 4 arguments:
429 // (check-c-code name-of-module-of-C++-code
430 // c1 c2 c3) % 3 parts of a checksum
431 // It looks at the setup table sfo rall the modules it is aware of. For
432 // each such the final entry will be of the form
433 // {nullptr, "module-name", "checksum info", ...}
434 // and it sees if the information from there matches what it is looking for.
435 if (!is_vector(name) ||
436 !is_string_header(vechdr(name)) ||
437 !is_fixnum(lc1) ||
438 !is_fixnum(lc2) ||
439 !is_fixnum(lc3)) return aerror1("check-c-code", name);
440 c1 = int_of_fixnum(lc1);
441 c2 = int_of_fixnum(lc2);
442 c3 = int_of_fixnum(lc3);
443 sname = reinterpret_cast<const char *>(&celt(name, 0));
444 len = length_of_byteheader(vechdr(name)) - CELL;
445
446 p = nullptr;
447 for (i=0; setup_tables[i]!=nullptr; i++)
448 { if ((p = find_checksum(sname, len,
449 setup_tables[i])) != nullptr) break;
450 }
451 if (p == nullptr) return aerror1("check-c-code", name);
452
453 if (std::sscanf(p, "%ld %ld %ld", &x1, &x2, &x3) != 3)
454 return aerror1("check-c-code", name);
455 if (c1 == x1 && c2 == x2 && c3 == x3) return onevalue(nil);
456 err_printf("\n+++++ C code and environment files not compatible\n");
457 err_printf("please check, re-compile and try again\n");
458 err_printf("versions from %.*s.c %lx %lx %lx\n", len, sname, x1, x2,
459 x3);
460 err_printf("version passed here %lx %lx %lx\n", c1, c2, c3);
461 return aerror1("check-c-code", name);
462 }
463
464 setup_type const restart_setup[] =
465 //
466 // things that are in modules that do not define enough Lisp entrypoints
467 // to be worth giving separate entry-tables.
468 //
469 { DEF_0("~load-spid", Lload_spid),
470 DEF_1("~is-spid", Lis_spid),
471 DEF_1("~spid-to-nil", Lspid_to_nil),
472 DEF_1("~mv-list", Lmv_list),
473 DEF_4up("check-c-code", Lcheck_c_code),
474 DEF_1("modulep", Lmodule_exists),
475 DEF_1("start-module", Lstart_module),
476 DEF_2("write-module", Lwrite_module),
477 DEF_1("copy-module", Lcopy_module),
478 DEF_1("delete-module", Ldelete_module),
479 DEF_1("load-module", Lload_module),
480 {"load-source", Lload_source0, Lload_source, G2Wother, G3Wother, G4Wother},
481 {"load-selected-source", Lload_selected_source0, Lload_selected_source, G2Wother, G3Wother, G4Wother},
482 DEF_0("list-modules", Llist_modules),
483 DEF_1("writable-libraryp", Lwritable_libraryp),
484 {"library-members", Llibrary_members0, Llibrary_members, G2Wother, G3Wother, G4Wother},
485 DEF_1("startup-banner", Lbanner),
486 DEF_2("set-help-file", Lset_help_file),
487 {"mapstore", Lmapstore0, Lmapstore, G2Wother, G3Wother, G4Wother},
488 DEF_1("verbos", Lverbos),
489 {"gc", Lgc0, Lgc, G2Wother, G3Wother, G4Wother},
490 {"reclaim", Lgc0, Lgc, G2Wother, G3Wother, G4Wother},
491 DEF_1("reclaim-trap", Lreclaim_trap),
492 DEF_1("reclaim-stack-limit",Lreclaim_stack_limit),
493 {"resource-limit", G0Wother, G1Wother, Lresource_limit_2, Lresource_limit_3, Lresource_limit_4up},
494 {"errorset", G0Wother, Lerrorset_1, Lerrorset_2, Lerrorset_3, G4Wother},
495 #ifdef CONSERVATIVE
496 {"gctest", Lgctest_0, Lgctest_1, Lgctest_2, G3Wother, G4Wother},
497 #endif
498 {nullptr, nullptr, nullptr, nullptr, nullptr, nullptr}
499 };
500
501
create_symbols(setup_type const s[],int restart_flag)502 static void create_symbols(setup_type const s[], int restart_flag)
503 { size_t i;
504 for (i=0; s[i].name != nullptr; i++)
505 make_symbol(s[i].name, restart_flag,
506 s[i].zero, s[i].one, s[i].two, s[i].three, s[i].fourup);
507 }
508
509 static int32_t defined_symbols;
510
count_symbols(setup_type const s[])511 static void count_symbols(setup_type const s[])
512 { size_t i;
513 for (i=0; s[i].name != nullptr; i++) defined_symbols++;
514 }
515
make_undefined_fluid(const char * name)516 static LispObject make_undefined_fluid(const char *name)
517 { LispObject v = make_undefined_symbol(name);
518 setheader(v, qheader(v) | SYM_SPECIAL_VAR);
519 return v;
520 }
521
make_undefined_global(const char * name)522 static LispObject make_undefined_global(const char *name)
523 { LispObject v = make_undefined_symbol(name);
524 setheader(v, qheader(v) | SYM_GLOBAL_VAR);
525 return v;
526 }
527
make_constant(const char * name,LispObject value)528 LispObject make_constant(const char *name, LispObject value)
529 { LispObject w = make_undefined_global(name);
530 setvalue(w, value);
531 return w;
532 }
533
make_variable(const char * name,LispObject value)534 LispObject make_variable(const char *name, LispObject value)
535 { LispObject w = make_undefined_fluid(name);
536 setvalue(w, value);
537 return w;
538 }
539
cold_setup()540 static void cold_setup()
541 { miscflags = 3;
542 setplist(nil, nil);
543 setfastgets(nil, nil);
544 setenv(nil, nil); // points to self in undefined case
545 qfn0(nil) = undefined_0;
546 qfn1(nil) = undefined_1;
547 qfn2(nil) = undefined_2;
548 qfn3(nil) = undefined_3;
549 qfn4up(nil) = undefined_4up;
550 setheader(nil, TAG_HDR_IMMED+TYPE_SYMBOL+SYM_GLOBAL_VAR);
551 setvalue(nil, nil);
552 qcountLow(nil) = 0;
553 qcountHigh(nil) = 0;
554 // When I am debugging CSL I can validate the heap, for instance whenever
555 // I allocate vector. I am about to need to call make_string to create a
556 // record of the name "nil", and during that call the pname field of nil
557 // had better be valid - so I fill it in with a nil.
558 setpname(nil, nil);
559 // Similarly the package field for nil needs a (temporary) safe value.
560 setpackage(nil, nil);
561 exit_reason = UNWIND_NULL;
562 // eq_hash_tables is not an ordinary list-base, si I need to clear it
563 // individually.
564 eq_hash_tables = nil;
565 for (LispObject **p=list_bases; *p!=nullptr; p++) **p = nil;
566 eq_hash_tables = nil;
567 #ifdef COMMON
568 setpname(nil, make_string("NIL"));
569 #else
570 setpname(nil, make_string("nil"));
571 #endif
572
573 // The package I am using at present will always be a package object
574 // stored in the value cell of "current-package". But that symbol does not
575 // quite exist yet - so as a temporary provision I use the value cell of NIL.
576 // This has in fact been done as part of the general initialization of
577 // list-bases, but I repeat it here for extra clarity.
578 current_package = nil;
579 //
580 // The code here is generally coded on the supposition that there will NEVER
581 // be a garbage collection here, so all issues of error recovery related
582 // tests can be omitted. That makes this code much cleaner! It means that
583 // during a cold start that there is enough space (well for a COLD start that
584 // hardly likely to be an issue!) and in a warm start that none of the
585 // calls that make strings or symbols etc here trigger a genuine garbage
586 // collection - that can probably be assured by ensuring that on restart there
587 // is at least a little bit of space in hand.
588 //
589 // Well garbage collection even at this early stage should now be valid when
590 // the conservative GC is active.
591 //
592 #ifdef CONSERVATIVE
593 if (gcTest) // if "--gc-test" was on command line.
594 { std::printf("\n: Conservative code - run a simple test of the GC\n\n");
595 simple_print(nil);
596 std::printf("\r\n");
597 Lgc0(nil);
598 simple_print(nil);
599 std::printf("\r\n");
600 std::printf("Now abort()...\n");
601 my_abort();
602 }
603 #endif // CONSERVATIVE
604 setvalue(nil, get_basic_vector_init(sizeof(Package), nil));
605 #ifdef COMMON
606 setpackage(nil, qvalue(nil)); // For sake of restart code
607 all_packages = ncons(qvalue(nil));
608 #else
609 setpackage(nil, static_cast<LispObject>(qvalue(nil)));
610 #endif
611
612 packhdr_(static_cast<LispObject>(CP)) = TYPE_STRUCTURE + (packhdr_
613 (static_cast<LispObject>(CP)) & ~header_mask);
614 #ifdef COMMON
615 packname_(static_cast<LispObject>(CP)) = make_string("LISP");
616 #endif
617 //
618 // The size chosen here is only an initial size - the hash table in a package
619 // can grow later on if needbe - but I ought to ensure that the initial
620 // size is big enough for the built-in symbols that Lisp creates in
621 // this restart code. The size must be a power of 2. I want the object
622 // table to have the same number of entries regardless of whether I am on
623 // a 32 or 64-bit machine to make cross-loading of images possible.
624 //
625 packint_(static_cast<LispObject>(CP)) = get_basic_vector_init(CELL*
626 (1+INIT_OBVECI_SIZE), fixnum_of_int(0));
627 packflags_(static_cast<LispObject>(CP)) = fixnum_of_int(
628 ++package_bits);
629 #ifdef COMMON
630 //
631 // Common Lisp also has "external" symbols to allow for...
632 //
633 packnint_(static_cast<LispObject>(CP)) = fixnum_of_int(0);
634 packext_(static_cast<LispObject>(CP)) = get_basic_vector_init(CELL*
635 (1+INIT_OBVECX_SIZE), fixnum_of_int(0));
636 packnext_(static_cast<LispObject>(CP)) = fixnum_of_int(
637 1); // Allow for nil
638 { size_t i = (size_t)(hash_lisp_string(qpname(nil)) &
639 (INIT_OBVECX_SIZE - 1));
640 elt(packext_(static_cast<LispObject>(CP)), i) = nil;
641 }
642 #else
643 packnint_(static_cast<LispObject>(CP)) = fixnum_of_int(
644 1); // Allow for nil
645 // Place NIL into the table.
646 { size_t i = (size_t)(hash_lisp_string(qpname(nil)) &
647 (INIT_OBVECI_SIZE - 1));
648 elt(packint_(static_cast<LispObject>(CP)), i) = nil;
649 }
650 #endif
651 gensym_ser = 1;
652 print_precision = 6; // I maybe prefer 15 but use 6 to agree with PSL
653 current_modulus = 1;
654 // a fastget entry of 0 means no fastget stuff present, and so in the 6-bit
655 // field I have the values 1-63 are available.
656 //
657 fastget_size = 63;
658 package_bits = 0;
659 modulus_is_large = 0;
660 unset_var = nil;
661 //
662 // there had better not be a need for garbage collection here...
663 // ... or elsewhere in setup, since the world is not yet put together.
664 // Ditto interrupts.
665 //
666 #define boffo_size 256
667 boffo = get_basic_vector(TAG_VECTOR, TYPE_STRING_4, CELL+boffo_size);
668 std::memset(reinterpret_cast<void *>(reinterpret_cast<char *>
669 (boffo) + (CELL - TAG_VECTOR)), '@', boffo_size);
670 //
671 // The next line has hidden depths. When it is obeyed during cold start
672 // the C variable *package* has the value nil, hence make_symbol
673 // looks in the value cell of nil to find the package to intern wrt. Once
674 // this has been done I can put nil back how it ought to have been!
675 //
676 current_package = make_undefined_fluid("*package*");
677 lisp_package = qpackage(nil);
678 setvalue(current_package, lisp_package);
679 setvalue(nil, nil); // Whew!
680 setpackage(nil, lisp_package);
681 setpackage(current_package,lisp_package);
682
683 B_reg = nil; // safe for GC
684 unset_var =
685 make_undefined_global("~indefinite-value~");
686 setvalue(unset_var, unset_var);
687 //@@@@@@@@@@@@@@@@@@@ Lunintern(nil, unset_var);
688 //
689 // Now in some minor sense the world is in a self-consistent state
690 //
691 lisp_true = make_undefined_global("t");
692 setvalue(lisp_true, lisp_true);
693 savedef = make_undefined_symbol("*savedef");
694 comma_symbol = make_undefined_symbol("~comma");
695 comma_at_symbol = make_undefined_symbol("~comma-at");
696 lambda = make_undefined_symbol("lambda");
697 funarg = make_undefined_symbol("funarg");
698 cfunarg = make_undefined_symbol("cfunarg");
699 opt_key = make_undefined_symbol("&optional");
700 rest_key = make_undefined_symbol("&rest");
701 key_key = make_undefined_symbol("&key");
702 allow_other_keys = make_undefined_symbol("&allow-other-keys");
703 aux_key = make_undefined_symbol("&aux");
704 work_symbol =
705 make_undefined_symbol("~magic-internal-symbol~");
706 Lunintern(nil, work_symbol);
707 package_symbol = make_undefined_symbol("package");
708 packid_(static_cast<LispObject>(CP)) = package_symbol;
709
710 macroexpand_hook = make_undefined_fluid("*macroexpand-hook*");
711 evalhook = make_undefined_fluid("*evalhook*");
712 setvalue(evalhook, nil);
713 applyhook = make_undefined_fluid("*applyhook*");
714 setvalue(applyhook, nil);
715 #ifdef COMMON
716 keyword_package = make_undefined_fluid("*keyword-package*");
717 setvalue(keyword_package, make_package(make_string("KEYWORD")));
718 err_table = make_undefined_global("*ERROR-MESSAGE*");
719 #else
720 err_table = make_undefined_global("*error-messages*");
721 #endif
722 setvalue(err_table, nil);
723 #ifdef COMMON
724 #define make_keyword(name) \
725 Lintern_2(nil, make_string(name), qvalue(keyword_package))
726 internal_symbol = make_keyword("INTERNAL");
727 external_symbol = make_keyword("EXTERNAL");
728 inherited_symbol = make_keyword("INHERITED");
729 allow_key_key = make_keyword("ALLOW-OTHER-KEYS");
730 #else
731 #define make_keyword(name) make_undefined_symbol(name)
732 #endif
733 gensym_base = make_string("G");
734 expand_def_symbol = make_undefined_symbol("expand-definer");
735 format_symbol = make_undefined_symbol("format");
736 string_char_sym = make_undefined_symbol("string-char");
737 // The following bunch of symbols relate to Common Lisp features and are
738 // not necessarily fully used.
739 nicknames_symbol = make_undefined_symbol(":nicknames");
740 use_symbol = make_undefined_symbol(":use");
741 and_symbol = make_undefined_symbol("and");
742 or_symbol = make_undefined_symbol("or");
743 not_symbol = make_undefined_symbol("not");
744 reader_workspace = make_undefined_symbol("#:x");
745 named_character = make_undefined_symbol(":named-character");
746 read_float_format =
747 make_undefined_symbol("*read-default-float-format*");
748 short_float = make_undefined_symbol("short-float");
749 single_float = make_undefined_symbol("single-float");
750 double_float = make_undefined_symbol("double-float");
751 long_float = make_undefined_symbol("long-float");
752 bit_symbol = make_undefined_symbol("bit");
753 pathname_symbol = make_undefined_symbol("pathname");
754 print_array_sym = make_undefined_symbol("*print-array*");
755 read_base = make_undefined_symbol("*read-base*");
756 initial_element = make_undefined_symbol(":initial-element");
757 make_constant("most-positive-fixnum", MOST_POSITIVE_FIXNUM);
758 make_constant("most-negative-fixnum", MOST_NEGATIVE_FIXNUM);
759 make_constant("pi",
760 make_boxfloat(3.141592653589793238, TYPE_DOUBLE_FLOAT));
761 append_symbol = make_undefined_symbol("append");
762 raise_symbol = make_undefined_fluid("*raise");
763 lower_symbol = make_undefined_fluid("*lower");
764 echo_symbol = make_undefined_fluid("*echo");
765 comp_symbol = make_undefined_fluid("*comp");
766 compiler_symbol = make_undefined_symbol("compile");
767 current_function = // system-startup
768 startup_symbol = make_undefined_symbol("system-startup");
769 mv_call_symbol = make_symbol("multiple-value-call", 0,
770 bad_specialfn_0, mv_call_fn, bad_specialfn_2, bad_specialfn_3,
771 bad_specialfn_4up);
772 autoload_symbol = make_undefined_symbol("autoload");
773 bytecoded_symbol = make_undefined_symbol("bytecoded-definition");
774 traceprint_symbol = make_undefined_symbol("trace-print");
775 load_source_symbol = make_symbol("load-source", 0, Lload_source0,
776 Lload_source, G2Wother, G3Wother, G4Wother);
777 load_selected_source_symbol =
778 make_symbol("load-selected-source", 0, Lload_selected_source0,
779 Lload_selected_source, G2Wother, G3Wother, G4Wother);
780 prinl_symbol = make_symbol("prinl", 0, G0W1, Lprin, G2W1, G3W1,
781 G4W1);
782 emsg_star = make_undefined_global("emsg*");
783 redef_msg = make_undefined_fluid("*redefmsg");
784 expr_symbol = make_undefined_symbol("expr");
785 fexpr_symbol = make_undefined_symbol("fexpr");
786 macro_symbol = make_undefined_symbol("macro");
787 break_function = make_undefined_fluid("*break-loop*");
788 gchook = make_undefined_fluid("*gc-hook*");
789 resources = make_undefined_fluid("*resources*");
790 used_space = make_undefined_fluid("*used-space*");
791 avail_space = make_undefined_fluid("*avail-space*");
792 gcknt_symbol = make_variable("gcknt*", fixnum_of_int(0));
793 // Note that end-of-file is represented by an odd Unicode value (in UTF-8)
794 eof_symbol = make_undefined_symbol("\xf4\x8f\xbf\xbf");
795 call_stack = nil;
796 trap_time = make_undefined_symbol("trap-time*");
797 // count_high = make_undefined_symbol("count-high*");
798 setvalue(break_function, nil);
799 setvalue(gchook, nil);
800 setvalue(trap_time, nil);
801 setvalue(resources, nil);
802 setvalue(used_space, fixnum_of_int(0));
803 setvalue(avail_space, fixnum_of_int(0));
804 { LispObject common = make_undefined_fluid("common-lisp-mode");
805 #ifdef COMMON
806 setvalue(common, lisp_true);
807 setvalue(raise_symbol, lisp_true);
808 setvalue(lower_symbol, nil);
809 #else
810 setvalue(common, nil);
811 setvalue(raise_symbol, nil);
812 setvalue(lower_symbol, lisp_true);
813 #endif
814 }
815 setvalue(echo_symbol, nil);
816 setvalue(comp_symbol, nil);
817 setvalue(emsg_star, nil);
818 setvalue(redef_msg, lisp_true);
819
820 sys_hash_table = Lmkhash_1(nil, fixnum_of_int(2)); // EQUAL
821 sxhash_hash_table = Lmkhash_1(nil, fixnum_of_int(0)); // EQ
822 get_counts = Lmkhash_1(nil, fixnum_of_int(0)); // EQ
823 //
824 // I make the vector that can hold the names used for "fast" get tags big
825 // enough for the largest possible number.
826 //
827 fastget_names = get_basic_vector_init((MAX_FASTGET_SIZE+2)*CELL,
828 SPID_NOPROP);
829 //
830 // The next bit is a horrid fudge, used in read.c (function orderp) to
831 // support REDUCE. It ensures that the flag 'noncom is subject to an
832 // optimisation for flag/flagp that allows it to be tested for using a
833 // simple bit-test. This MUST use entry zero (coded as 1 here!).
834 // Also I insist that 'lose be the second fastget thing!
835 //
836 { LispObject nc = make_undefined_symbol("noncom");
837 setheader(nc, qheader(nc) | (1L << SYM_FASTGET_SHIFT));
838 elt(fastget_names, 0) = nc;
839 nc = make_undefined_symbol("lose");
840 setheader(nc, qheader(nc) | (2L << SYM_FASTGET_SHIFT));
841 elt(fastget_names, 1) = nc;
842 }
843 //
844 // I create the stream objects just once at cold-start time, but every time I
845 // restart I will fill in their components in the standard way again.
846 //
847 lisp_work_stream = make_stream_handle();
848 lisp_terminal_io = make_stream_handle();
849 lisp_standard_output = make_stream_handle();
850 lisp_standard_input = make_stream_handle();
851 lisp_error_output = make_stream_handle();
852 lisp_trace_output = make_stream_handle();
853 lisp_debug_io = make_stream_handle();
854 lisp_query_io = make_stream_handle();
855 set_up_functions(0);
856 set_up_variables(0);
857 procstack = nil;
858 procmem = get_basic_vector_init(CELL*100, nil); // 0 to 99
859 procstackp = 0;
860 }
861
set_up_functions(int restart_flag)862 LispObject set_up_functions(int restart_flag)
863 {
864 //
865 // All symbols that have a pointer to C code in their function cell must
866 // be set up whether we are in a warm OR a cold start state, because the
867 // actual addresses associated with C entrypoints will vary from version
868 // to version of the binary of the system.
869 //
870 size_t i;
871 #ifdef COMMON
872 //
873 // In Common Lisp mode it could be that the user had something other than the
874 // LISP package active when the image was saved. But I want all the symbols
875 // that I create or restore here to be in the LISP (or sometimes keyword)
876 // package. So I temporarily reset the package here...
877 //
878 LispObject saved_package = CP;
879 CP = find_package("LISP", 4);
880 #endif
881 function_symbol = make_symbol("function", restart_flag,
882 bad_specialfn_0, function_fn, bad_specialfn_2, bad_specialfn_3,
883 bad_specialfn_4up);
884 setheader(function_symbol,
885 qheader(function_symbol) | SYM_SPECIAL_FORM);
886 quote_symbol = make_symbol("quote", restart_flag,
887 bad_specialfn_0, quote_fn, bad_specialfn_2, bad_specialfn_3,
888 bad_specialfn_4up);
889 setheader(quote_symbol, qheader(quote_symbol) | SYM_SPECIAL_FORM);
890 go_symbol = make_symbol("go", restart_flag,
891 bad_specialfn_0, go_fn, bad_specialfn_2, bad_specialfn_3,
892 bad_specialfn_4up);
893 setheader(go_symbol, qheader(go_symbol) | SYM_SPECIAL_FORM);
894 cond_symbol = make_symbol("cond", restart_flag,
895 bad_specialfn_0, cond_fn, bad_specialfn_2, bad_specialfn_3,
896 bad_specialfn_4up);
897 setheader(cond_symbol, qheader(cond_symbol) | SYM_SPECIAL_FORM);
898 progn_symbol = make_symbol("progn", restart_flag,
899 bad_specialfn_0, progn_fn, bad_specialfn_2, bad_specialfn_3,
900 bad_specialfn_4up);
901 setheader(progn_symbol, qheader(progn_symbol) | SYM_SPECIAL_FORM);
902 declare_symbol = make_symbol("declare", restart_flag,
903 bad_specialfn_0, declare_fn, bad_specialfn_2, bad_specialfn_3,
904 bad_specialfn_4up);
905 setheader(declare_symbol, qheader(declare_symbol) | SYM_SPECIAL_FORM);
906 special_symbol = make_undefined_symbol("special");
907 large_modulus = fixnum_of_int(1);
908 cons_symbol = make_symbol("cons", restart_flag, G0W1,
909 G1W2, Lcons, G3W2, G4W2);
910 list_symbol = make_symbol("list", restart_flag, Lnilfn,
911 Lncons, Llist_2, Llist_3, Llist_4up);
912 liststar_symbol = make_symbol("list*", restart_flag,
913 G0Wother, Lidentity, Lcons, Llist_2star, Lliststar_4up);
914 eq_symbol = make_undefined_symbol("eq");
915 eql_symbol = make_undefined_symbol("eql");
916 cl_equal_symbol = make_undefined_symbol("cl-equal");
917 equal_symbol = make_undefined_symbol("equal");
918 equalp_symbol = make_undefined_symbol("equalp");
919 eval_symbol = make_symbol("eval", restart_flag, G0W1,
920 Leval, G2W1, G3W1, G4W1);
921 apply_symbol = make_symbol("apply", restart_flag,
922 G0Wother, Lapply_1, Lapply_2, Lapply_3, Lapply_4up);
923 load_source_symbol = make_symbol("load-source", restart_flag,
924 Lload_source0, Lload_source, G2Wother, G3Wother, G4Wother);
925 builtin0_symbol = make_undefined_symbol("s:builtin0");
926 builtin1_symbol = make_undefined_symbol("s:builtin1");
927 builtin2_symbol = make_undefined_symbol("s:builtin2");
928 builtin3_symbol = make_undefined_symbol("s:builtin3");
929 builtin4_symbol = make_undefined_symbol("s:builtin4");
930 load_selected_source_symbol =
931 make_symbol("load-selected-source",
932 restart_flag, Lload_selected_source0,
933 Lload_selected_source, G2Wother, G3Wother,
934 G4Wother);
935 //
936 // The main bunch of symbols can be handed using a table that
937 // gives names and values.
938 //
939 for (i=0; eval2_setup[i].name != nullptr; i++)
940 { LispObject v = make_symbol(eval2_setup[i].name,
941 restart_flag,
942 eval2_setup[i].zero,
943 eval2_setup[i].one,
944 eval2_setup[i].two,
945 eval2_setup[i].three,
946 eval2_setup[i].fourup);
947 setheader(v, qheader(v) | SYM_SPECIAL_FORM);
948 }
949 for (i=0; eval3_setup[i].name != nullptr; i++)
950 { LispObject v = make_symbol(eval3_setup[i].name,
951 restart_flag,
952 eval3_setup[i].zero,
953 eval3_setup[i].one,
954 eval3_setup[i].two,
955 eval3_setup[1].three,
956 eval3_setup[i].fourup);
957 setheader(v, qheader(v) | SYM_SPECIAL_FORM);
958 }
959 create_symbols(arith06_setup, restart_flag);
960 create_symbols(arith08_setup, restart_flag);
961 create_symbols(arith10_setup, restart_flag);
962 create_symbols(arith12_setup, restart_flag);
963 create_symbols(arith13_setup, restart_flag);
964 create_symbols(char_setup, restart_flag);
965 create_symbols(eval1_setup, restart_flag);
966 create_symbols(funcs1_setup, restart_flag);
967 create_symbols(funcs2_setup, restart_flag);
968 create_symbols(funcs3_setup, restart_flag);
969 create_symbols(lisphash_setup, restart_flag);
970 create_symbols(print_setup, restart_flag);
971 create_symbols(read_setup, restart_flag);
972 create_symbols(restart_setup, restart_flag);
973 create_symbols(mpi_setup, restart_flag);
974 #ifdef ARITHLIB
975 create_symbols(arith_setup, restart_flag);
976 #endif
977 //
978 // Although almost everything is mapped into upper case in a Common Lisp
979 // world, I will preserve the case of symbols defined in u01 to u60.
980 //
981 for (i=0; setup_tables[i]!=nullptr; i++)
982 create_symbols(setup_tables[i], restart_flag | 2);
983
984 #ifdef NAG
985 create_symbols(asp_setup, restart_flag);
986 create_symbols(nag_setup, restart_flag);
987 create_symbols(socket_setup, restart_flag);
988 create_symbols(xdr_setup, restart_flag);
989 create_symbols(grep_setup, restart_flag);
990 create_symbols(axfns_setup, restart_flag);
991 create_symbols(gr_setup, restart_flag);
992 #endif
993
994 #ifdef OPENMATH
995 create_symbols(om_setup, restart_flag);
996 create_symbols(om_parse_setup, restart_flag);
997 #endif
998
999 #ifdef COMMON
1000 CP = saved_package;
1001 #endif
1002 return nil;
1003 }
1004
alpha1(const void * a,const void * b)1005 static int alpha1(const void *a, const void *b)
1006 { return std::strcmp(1+*(const char **)a, 1+*(const char **)b);
1007 }
1008
1009 // This sets up:
1010 // lispsystem!*
1011 // The standard input and output streams
1012 // information about the command line arguments in lispargs!*
1013 // floating point limit constants (which ought in fact to be the
1014 // same on all platforms if I am using IEEE arithmetic...)
1015 // input!-libraries and output!-library
1016
set_up_variables(int restart_flag)1017 LispObject set_up_variables(int restart_flag)
1018 { LispObject w, w1;
1019 size_t i;
1020 // There are a number of system variables that are not saved in
1021 // image files and so that have to be set up manually in every case.
1022 #ifdef COMMON
1023 LispObject saved_package = CP;
1024 CP = find_package("LISP", 4);
1025 #endif
1026 charvec = get_basic_vector_init(257*CELL, nil);
1027 faslvec = nil;
1028 faslgensyms = nil;
1029 multiplication_buffer = nil;
1030 // big_fake1 and big_fake2 represent a witty issue - when a bignum is
1031 // serilized and it uses only one or two words its value gets written
1032 // as a 64-bit numeric value. When it is re-loaded that value is packed
1033 // as a number - either a fixnum or a bignum as relevant. So the FAKE
1034 // nature of big_fake1 and big_fake2 will lead to the ser8ialization process
1035 // reloading fixnums if one is on a 64-bit machine. Thus defeating the whole
1036 // point of them!
1037 big_fake1 = make_one_word_bignum(0);
1038 big_fake2 = make_two_word_bignum(0, 0);
1039 // It makes sense to reset big_divisor and big_dividend on reloading a heap
1040 // image so that any very large allocation from the previous run is discarded.
1041 big_divisor = make_four_word_bignum(0, 0, 0, 0);
1042 big_dividend = make_four_word_bignum(0, 0, 0, 0);
1043 big_quotient = make_four_word_bignum(0, 0, 0, 0);
1044 setvalue(macroexpand_hook, funcall_symbol =
1045 make_symbol("funcall", restart_flag, G0Wother, Lfuncall_1, Lfuncall_2,
1046 Lfuncall_3, Lfuncall_4up));
1047 input_libraries = make_undefined_symbol("input-libraries");
1048 setheader(input_libraries,
1049 qheader(input_libraries) | SYM_SPECIAL_VAR);
1050 setvalue(input_libraries, nil);
1051 for (i=fasl_files.size(); i!=0; i--)
1052 if (fasl_files[i-1].inUse)
1053 setvalue(input_libraries,
1054 cons(SPID_LIBRARY + (((int32_t)(i-1))<<20),
1055 qvalue(input_libraries)));
1056 output_library = make_undefined_symbol("output-library");
1057 setvalue(output_library, (output_directory & 0x80000000u) != 0 ? nil :
1058 SPID_LIBRARY + (((int32_t)(output_directory&0x3ff))<<20));
1059 //
1060 // The Lisp variable lispsystem* gets set here. (in Common mode it is
1061 // the variable *features*)
1062 // Its value is a list.
1063 // csl says I am a CSL Lisp
1064 // (executable . "string") name of current executable (if available)
1065 // (shortname . "string") executable wuithout path or extension
1066 // pipes do I support open-pipe?
1067 // parallel "parallel" function supported
1068 // (revision . number) eg 4020. The most recent subversion checkin.
1069 // (name . "string") eg "MSDOS/386"
1070 // (opsys . id) unix/msdos/riscos/win32/finder/riscos/...
1071 // id unix/msdos etc again...
1072 // help help mechanism provided within Lisp
1073 // debug Lisp built with debug options
1074 // embedded if built using the EMBEDDED option
1075 // (c-code . number) u01.c through u60.c define n functions
1076 // sixty-four 64-bit address version
1077 // texmacs "--texmacs" option on command line
1078 // parallel the "parallel" experimental function exists
1079 //
1080 // In Common mode the tags on the *features* list are generally in the
1081 // keyword package. Otherwise they are just regular symbols. This makes it
1082 // slightly hard to use code that tests this list in a generic environment!
1083 //
1084
1085 /*!!! csl
1086 */
1087
1088 /*!! lispsys [03] \section{Items that can appear in {\ttfamily lispsystem!*}} \label{lispsys}
1089 *
1090 * There is a global variable called {\ttfamily lispsystem!*} whose value is
1091 * reset in the process of CSL starting up. An effect of this is that if the
1092 * user changes its value those changes do not survice a preserving and
1093 * re-loading a heap image: this is deliberate since the heap image may be
1094 * re-loaded on a different instance of CSL possibly on a quite different
1095 * computer of with a different configuration. The value of {\ttfamily
1096 * lispsystem!*} is a list of items, where each item is either an atomic tag
1097 * of a pair whose first component is a key. In general it would be unwise
1098 * to rely on exactly what information is present without review of the code
1099 * that sets it up. The information may be of interest to anybody but some tags
1100 * and keys are reflections of experiments rather than fully stable facilities.
1101 * \begin{description}
1102 */
1103
1104 /*! lispsys [~~~~~~~~] \end{description} % end of lispsystem* section [restart.c]
1105 */
1106
1107 {
1108 #ifdef COMMON
1109 LispObject n = features_symbol;
1110 char opsys[32];
1111 char *p1 = opsys, *p2 = OPSYS;
1112 int ii;
1113 while ((*p1++ = std::toupper(*p2++)) != 0);
1114 *p1 = 0;
1115 /*! lispsys [opsys] \item [{\itshape operating system identity}] \index{{\ttfamily operating system identity}}
1116 * The name of the current operating system is put on the list. Exactly what
1117 * form is not explicitly defined!
1118 */
1119 w = cons(make_keyword(opsys), nil);
1120 #if defined WIN64 || defined __WIN64__ || defined WIN32
1121 w = cons(make_keyword("WIN32"), w);
1122 #endif
1123 #if defined WIN64 || defined __WIN64__
1124 w = cons(make_keyword("WIN64"), w);
1125 #endif
1126 #if defined MACINTOSH
1127 w = cons(make_keyword("MAC"), w);
1128 w = cons(make_keyword("UNIX"), w);
1129 #else
1130 #if defined UNIX
1131 if (std::strcmp(opsys, "UNIX") != 0 &&
1132 std::strcmp(opsys, "unix") != 0)
1133 w = cons(make_keyword("UNIX"), w);
1134 #endif
1135 #endif
1136 /*! lispsys [win32] \item[{\ttfamily win32}, {\ttfamily win64}] \index{{\ttfamily win32}, {\ttfamily win64}}
1137 * Any windows system puts {\ttfamily win32} in {\ttfamily lispsystem!*}.
1138 * If 64-bit windows is is use then {\ttfamily win64} is also included
1139 */
1140 #else
1141 LispObject n = make_undefined_symbol("lispsystem*");
1142 /*! lispsys [c-code] \item[{\ttfamily (c!-code . count)}] \index{{\ttfamily (c"!-code . count)}}
1143 * This will be present if code has been optimised into C through the source
1144 * files u01.c to u60.c, and in that case the value tells you how many functions
1145 * have been optimised in this manner.
1146 *
1147 */
1148
1149 /*! lispsys [common-lisp] \item[{\ttfamily common!-lisp}] \index{{\ttfamily common"!-lisp}}
1150 * For a project some while ago a limited Common Lisp compatibility mode was
1151 * being developed, and this tag indicated that it was active. In that case all
1152 * entries are in upper case and the variable is called {\ttfamily *FEATURES*}
1153 * rather than {\ttfamily lispsystem!*}. But note that this Lisp has never even
1154 * aspired to be a full Common Lisp, since its author considers Common Lisp to
1155 * have been a sad mistake that must bear significant responsibility for the
1156 * fact that interest in Lisp has faded dramatically since its introduction.
1157 *
1158 */
1159 /*! lispsys [csl] \item[{\ttfamily csl}] \index{{\ttfamily csl}}
1160 * A simple tag intended to indicate that this Lisp system is CSL and not any
1161 * other. This can of course only work properly if all other Lisp systems
1162 * agree not to set this tag! In the context of Reduce I note that the PSL
1163 * Lisp system sets a tag {\ttfamily psl} on {\ttfamily lispsystem!*} and
1164 * the realistic use of this is to discriminate between CSL and PSL hosted
1165 * copies of Reduce.
1166 */
1167
1168 /*! lispsys [debug] \item[{\ttfamily debug}] \index{{\ttfamily debug}}
1169 * If CSL was compiled with debugging options this is present, and one can imagine
1170 * various bits of code being more cautious or more verbose if it is detected.
1171 */
1172
1173 /*! lispsys [executable] \item[{\ttfamily (executable . name)}] \index{{\ttfamily (executable . name)}}
1174 * The value is the fully rooted name of the executable file that was launched.
1175 */
1176
1177 /*! lispsys [fox] \item[{\ttfamily fox}] \index{{\ttfamily fox}}
1178 * Used to be present if the FOX GUI toolkit was detected and incorporated as
1179 * part of CSL, but now probably never used!
1180 */
1181
1182 /*! lispsys [name] \item[{\ttfamily (name . name)}] \index{{\ttfamily (name . name)}}
1183 * Some indication of the platform. For instance on one system I use it
1184 * is {\ttfamily linux-gnu:x86\_64} and on anther it is just {\ttfamily win32}.
1185 */
1186
1187 /*! lispsys [opsys] \item[{\ttfamily (opsys . operating-system)}] \index{{\ttfamily (opsys . operating-system)}}
1188 * Some crude indication of the host operating system.
1189 */
1190
1191 /*! lispsys [pipes] \item[{\ttfamily pipes}] \index{{\ttfamily pipes}}
1192 * In the earlier days of CSL there were computers where pipes were not
1193 * supported, so this tag notes when they are present and hance the facility
1194 * to create sub-tasks through them can be used.
1195 */
1196
1197 /*! lispsys [record_get] \item[{\ttfamily record\_get}] \index{{\ttfamily record\_get}}
1198 * An an extension to the CSL profiling scheme it it possible to compile
1199 * a special version that tracks and counts each use of property-list access
1200 * functions. This can be useful because there are ways to give special
1201 * treatment to a small number of flags and a small number of properties. The
1202 * special-case flage end up stored as a bitmap in the symbol-header so avoid
1203 * need for property-list searching. But of course recording this extra
1204 * information slows things down. This tag notes when the slow version is
1205 * in use. It might be used to trigger a display of statistics at the end of
1206 * a calculation.
1207 */
1208
1209 /*! lispsys [reduce] \item[{\ttfamily reduce}] \index{{\ttfamily reduce}}
1210 * This is intended to report if the initial heap image is for Reduce rather than
1211 * merely for Lisp.
1212 */
1213
1214 /*! lispsys [shortname] \item[{\ttfamily (shortname . name)}] \index{{\ttfamily (shortname . name)}}
1215 * Gives the short name of the current executable, without its full path.
1216 */
1217
1218 /*! lispsys [showmath] \item[{\ttfamily showmath}] \index{{\ttfamily showmath}}
1219 * If the ``showmath'' capability has been compiled into CSL this will be present
1220 * so that Lisp code can know it is reasonable to try to use it.
1221 */
1222
1223 /*! lispsys [showmath1] \item[{\ttfamily showmath1}] \index{{\ttfamily showmath1}}
1224 * This marks the fact that this version of CSL will support the output
1225 * style where flat simple text preceeds TeX output, with a U+0003 (end of text)
1226 * marker to separate.
1227 */
1228
1229 /*! lispsys [sixty-four] \item[{\ttfamily sixty!-four}] \index{{\ttfamily sixty"!-four}}
1230 * Present if the Lisp was compiled for a 64-bit computer.
1231 */
1232
1233 /*! lispsys [termed] \item[{\ttfamily termed}] \index{{\ttfamily termed}}
1234 * Present if a cursor-addressable console was detected.
1235 */
1236
1237 /*! lispsys [texmacs] \item[{\ttfamily texmacs}] \index{{\ttfamily texmacs}}
1238 * Present if the system was launched with the {\ttfamily --texmacs} flag.
1239 * The intent is that this should only be done when it has been launched with
1240 * texmacs as a front-end.
1241 */
1242
1243 /*! lispsys [revision] \item[{\ttfamily (revision . ver)}] \index{{\ttfamily (revision . ver)}}
1244 * The CSL subversion revision number.
1245 */
1246
1247
1248 /*! lispsys [windowed] \item[{\ttfamily windowed}] \index{{\ttfamily windowed}}
1249 * Present if CSL is running in its own window rather than in console mode.
1250 */
1251
1252 w = cons(make_keyword(OPSYS), nil);
1253 #if defined WIN64 || defined __WIN64__ || defined WIN32
1254 //
1255 // In the WIN64 case I will ALSO tell the user than I am "win32". This is
1256 // a curious thing to do maybe, but is because historically win32 may have
1257 // been used as a "windows" test, and win64 is in general terms a
1258 // compatible extension so all win32 options ought still to be available.
1259 //
1260 w = cons(make_keyword("win32"), w);
1261 #endif
1262 #if defined WIN64 || defined __WIN64__
1263 w = cons(make_keyword("win64"), w);
1264 #endif
1265 setheader(n, qheader(n) | SYM_SPECIAL_VAR);
1266 #endif
1267 defined_symbols = 0;
1268 for (i=0; setup_tables[i]!=nullptr;
1269 i++) count_symbols(setup_tables[i]);
1270 #ifdef COMMON
1271 // A gratuitous misery here is the need to make words
1272 // upper case.
1273 w = acons(make_keyword("OPSYS"),
1274 make_undefined_symbol(OPSYS), w);
1275 w = acons(make_keyword("C-CODE"),
1276 fixnum_of_int(defined_symbols), w);
1277 w = acons(make_keyword("PLATFORM"),
1278 make_undefined_symbol(BUILTFOR), w);
1279 if (SIXTY_FOUR_BIT) w = cons(make_keyword("SIXTY-FOUR"), w);
1280 w = cons(make_keyword("PIPES"), w);
1281 #if defined HAVE_UNISTD_H && \
1282 defined HAVE_SYS_TYPES_H && \
1283 defined HAVE_SYS_STAT_H && \
1284 defined HAVE_SYS_WAIT_H && \
1285 defined HAVE_SIGNAL_H && \
1286 defined HAVE_SYS_SHM_H && \
1287 defined HAVE_SYS_IPC_H && \
1288 defined HAVE_FORK && \
1289 defined HAVE_WAIT && \
1290 defined HAVE_WAITPID && \
1291 defined HAVE_SHMGET && \
1292 defined HAVE_SHMAT && \
1293 defined HAVE_SHMDT && \
1294 defined HAVE_SHMCTL
1295 w = cons(make_keyword("PARALLEL", w);
1296 #endif
1297 #ifdef DEBUG
1298 w = cons(make_keyword("DEBUG"), w);
1299 #endif
1300 #ifdef EXPERIMENT
1301 w = cons(make_keyword("EXPERIMENT"), w);
1302 #endif
1303 w = cons(make_keyword("RECORD_GET"), w);
1304 w = acons(make_keyword("EXECUTABLE"),
1305 make_string(fullProgramName), w);
1306 w = acons(make_keyword("NAME"), make_string(IMPNAME), w);
1307 w = acons(make_keyword("REVISION"), fixnum_of_int(REVISION), w);
1308 w = cons(make_keyword("CCL"), w);
1309 w = cons(make_keyword("COMMON-LISP"), w);
1310
1311
1312 #else // !COMMON
1313
1314
1315 w = acons(make_keyword("opsys"),
1316 make_undefined_symbol(OPSYS), w);
1317 w = acons(make_keyword("c-code"),
1318 fixnum_of_int(defined_symbols), w);
1319 w = acons(make_keyword("platform"),
1320 make_undefined_symbol(BUILTFOR), w);
1321 if (texmacs_mode)
1322 w = cons(make_keyword("texmacs"), w);
1323 if (SIXTY_FOUR_BIT) w = cons(make_keyword("sixty-four"), w);
1324 w = cons(make_keyword("pipes"), w);
1325 #if defined HAVE_CRLIBM
1326 w = cons(make_keyword("crlibm"), w);
1327 #endif
1328 #if defined HAVE_UNISTD_H && \
1329 defined HAVE_SYS_TYPES_H && \
1330 defined HAVE_SYS_STAT_H && \
1331 defined HAVE_SYS_WAIT_H && \
1332 defined HAVE_SIGNAL_H && \
1333 defined HAVE_SYS_SHM_H && \
1334 defined HAVE_SYS_IPC_H && \
1335 defined HAVE_FORK && \
1336 defined HAVE_WAIT && \
1337 defined HAVE_WAITPID && \
1338 defined HAVE_SHMGET && \
1339 defined HAVE_SHMAT && \
1340 defined HAVE_SHMDT && \
1341 defined HAVE_SHMCTL
1342 w = cons(make_keyword("parallel"), w);
1343 #endif
1344 #ifdef DEBUG
1345 w = cons(make_keyword("debug"), w);
1346 #endif
1347 #ifdef EXPERIMENT
1348 w = cons(make_keyword("experiment"), w);
1349 #endif
1350 #ifdef EMBEDDED
1351 w = cons(make_keyword("embedded"), w);
1352 #endif
1353 #ifdef NO_THROW
1354 w = cons(make_keyword("no-throw"), w);
1355 #endif
1356 #ifdef CONSERVATIVE
1357 w = cons(make_keyword("conservative"), w);
1358 #endif
1359 if (fwin_windowmode() & FWIN_WITH_TERMED)
1360 w = cons(make_keyword("termed"), w);
1361 #ifdef HAVE_LIBFOX
1362 if (fwin_windowmode() & FWIN_IN_WINDOW)
1363 { w = cons(make_keyword("windowed"), w);
1364 w = cons(make_keyword("fox"), w);
1365 // It could be the case that SHOWMATH is compiled in but the necessary
1366 // fonts were not located. Or if they were there but "--" has been used to
1367 // redirect standard output to a file.
1368 //
1369 if (showmathInitialised &&
1370 alternative_stdout == nullptr)
1371 { w = cons(make_keyword("showmath"), w);
1372 w = cons(make_keyword("showmath1"), w);
1373 }
1374 }
1375 #endif
1376 #ifdef HAVE_LIBWX
1377 if (fwin_windowmode() & FWIN_IN_WINDOW)
1378 { w = cons(make_keyword("windowed"), w);
1379 w = cons(make_keyword("wx"), w);
1380 // It could be the case that SHOWMATH is compiled in but the necessary
1381 // fonts were not located. Or if they were there but "--" has been used to
1382 // redirect standard output to a file.
1383 //
1384 if (showmathInitialised &&
1385 alternative_stdout == nullptr)
1386 { w = cons(make_keyword("showmath"), w);
1387 w = cons(make_keyword("showmath1"), w);
1388 }
1389 }
1390 #endif
1391 #ifdef RECORD_GET
1392 w = cons(make_keyword("record_get"), w);
1393 #endif
1394 w = acons(make_keyword("executable"),
1395 make_string(fullProgramName), w);
1396 w = acons(make_keyword("shortname"),
1397 make_string(programName), w);
1398 if (!restartp) w = cons(make_keyword("cold-start"), w);
1399 w = acons(make_keyword("name"), make_string(IMPNAME), w);
1400 w = acons(make_keyword("revision"), fixnum_of_int(REVISION), w);
1401 w = cons(make_keyword("csl"), w);
1402 //
1403 // Ha Ha a trick here - if a symbol ADDSQ is defined I view this image
1404 // as being one for REDUCE and push that information onto lispsystem*,
1405 // and I also reset the "about box" information (if using fwin).
1406 //
1407 w1 = make_undefined_symbol("addsq");
1408 if (qfn1(w1) != undefined_1)
1409 { w = cons(make_keyword("reduce"), w);
1410 w1 = qvalue(make_undefined_symbol("version*"));
1411 if (is_vector(w1) &&
1412 is_string_header(vechdr(w1)))
1413 { int n = length_of_byteheader(vechdr(w1))-CELL;
1414 std::sprintf(about_box_title, "About %.*s",
1415 (n > 31-static_cast<int>(std::strlen("About ")) ?
1416 31-static_cast<int>(std::strlen("About ")) : n),
1417 reinterpret_cast<const char *>(&celt(w1, 0)));
1418 std::sprintf(about_box_description, "%.*s",
1419 (n > 31 ? 31 : n),
1420 reinterpret_cast<const char *>(&celt(w1, 0)));
1421 //
1422 // The provision here is that if variables called "author!*" and
1423 // "author2!*" exist with strings as values then those values will
1424 // appear in the "about box". See a commentary in the file fwin.c about
1425 // possibly non-obvious constraints on what text you may properly place
1426 // in these strings.
1427 //
1428 w1 = qvalue(make_undefined_symbol("author1*"));
1429 if (is_vector(w1) &&
1430 is_string_header(vechdr(w1)))
1431 { n = length_of_byteheader(vechdr(w1))-CELL;
1432 std::sprintf(about_box_rights_1, "%.*s",
1433 n > 31 ? 31 : n, reinterpret_cast<const char *>(&celt(w1, 0)));
1434 }
1435 else std::strcpy(about_box_rights_1, "A C Hearn/RAND");
1436 w1 = qvalue(make_undefined_symbol("author2*"));
1437 if (is_vector(w1) &&
1438 is_string_header(vechdr(w1)))
1439 { n = length_of_byteheader(vechdr(w1))-CELL;
1440 std::sprintf(about_box_rights_2, "%.*s",
1441 n > 31 ? 31 : n,
1442 reinterpret_cast<const char *>(&celt(w1, 0)));
1443 }
1444 else std::strcpy(about_box_rights_2, "Codemist ");
1445 }
1446 else
1447 { std::strcpy(about_box_title, "About REDUCE");
1448 std::strcpy(about_box_description, "REDUCE");
1449 std::strcpy(about_box_rights_1, "A C Hearn/RAND");
1450 std::strcpy(about_box_rights_2, "Codemist");
1451 }
1452 }
1453 setheader(n, qheader(n) | SYM_SPECIAL_VAR);
1454 setvalue(n, w);
1455 #endif // COMMON
1456 }
1457 //
1458 // lispargs* and full-lispargs!* give access to command line args used at
1459 // launch. lispargs!* just contains anything beyond the keyword "--args"
1460 // while full-lispargs contains everything.
1461 //
1462 { LispObject aa = nil, faa = nil;
1463 LispObject n = make_undefined_symbol("lispargs*");
1464 int i, seen_args_keyword=0;
1465 for (i=0; i<csl_argc; i++)
1466 { LispObject s = make_string(csl_argv[i]);
1467 faa = cons(s, faa);
1468 if (seen_args_keyword) aa = cons(s, aa);
1469 if (std::strcmp(csl_argv[i], "--args") == 0) seen_args_keyword = 1;
1470 }
1471 aa = Lreverse(nil, aa);
1472 faa = Lreverse(nil, faa);
1473 setheader(n, qheader(n) | SYM_SPECIAL_VAR);
1474 setvalue(n, aa);
1475 n = make_undefined_fluid("full-lispargs*");
1476 setvalue(n, faa);
1477 }
1478 //
1479 // Floating point characteristics are taken from <cfloat> where it is
1480 // supposed that the C compiler involved has got the values correct.
1481 // I do this every time the system is loaded rather than just when an
1482 // image is cold-created. This is because an image file may have been created
1483 // on a system differing from the one on which it is used. Maybe in fact
1484 // IEEE arithmetic is ALMOST universal and I am being too cautious here?
1485 //
1486 make_constant("short-float-epsilon",
1487 pack_short_float(16.0*FLT_EPSILON));
1488 make_constant("single-float-epsilon",
1489 pack_single_float(FLT_EPSILON));
1490 make_constant("double-float-epsilon",
1491 make_boxfloat(DBL_EPSILON, TYPE_DOUBLE_FLOAT));
1492 // Now that LONG FLOAT is 128-bits all the literals set up here are
1493 // liable to be incorrect!
1494 make_constant("long-float-epsilon",
1495 make_boxfloat(DBL_EPSILON, TYPE_LONG_FLOAT));
1496 //
1497 // I assume that I have a radix 2 representation, and float-negative-epsilon
1498 // is just half float-epsilon. Correct me if I am wrong...
1499 //
1500 make_constant("short-float-negative-epsilon",
1501 pack_short_float(16.0*FLT_EPSILON/2.0));
1502 make_constant("single-float-negative-epsilon",
1503 pack_single_float(FLT_EPSILON/2.0));
1504 make_constant("double-float-negative-epsilon",
1505 make_boxfloat(DBL_EPSILON/2.0, TYPE_DOUBLE_FLOAT));
1506 // For now "long" = "double"
1507 make_constant("long-float-negative-epsilon",
1508 make_boxfloat(DBL_EPSILON/2.0, TYPE_LONG_FLOAT));
1509 //
1510 // I hope that the C header file gets extremal values correct. Note that
1511 // because pack_short_float() truncates (rather than rounding) it should give
1512 // correct values for most-positive-short-float etc
1513 //
1514 make_constant("most-positive-short-float",
1515 pack_short_float(FLT_MAX));
1516 make_constant("most-positive-single-float",
1517 pack_single_float(FLT_MAX));
1518 make_constant("most-positive-double-float",
1519 make_boxfloat(DBL_MAX, TYPE_DOUBLE_FLOAT));
1520 make_constant("most-positive-long-float",
1521 make_boxfloat(DBL_MAX, TYPE_LONG_FLOAT));
1522 //
1523 // Here I assume that the floating point representation is sign-and-magnitude
1524 // and hence symmetric about zero.
1525 //
1526 make_constant("most-negative-short-float",
1527 pack_short_float(-FLT_MAX));
1528 make_constant("most-negative-single-float",
1529 pack_single_float(-FLT_MAX));
1530 make_constant("most-negative-double-float",
1531 make_boxfloat(-DBL_MAX, TYPE_DOUBLE_FLOAT));
1532 make_constant("most-negative-long-float",
1533 make_boxfloat(-DBL_MAX, TYPE_LONG_FLOAT));
1534 //
1535 // The "least-xxx" set of values did not consider the case of denormalised
1536 // numbers too carefully in ClTl-1, so in ClTl-2 there are elaborations. I
1537 // believe that a proper C header file <cfloat> will make the macros that
1538 // I use here refer to NORMALISED values, so the numeric results I use
1539 // here will not be quite proper (ie there are smaller floats that are
1540 // un-normalised). But I will ignore that worry just for now.
1541 //
1542 make_constant("least-positive-short-float",
1543 pack_short_float(FLT_MIN));
1544 make_constant("least-positive-single-float",
1545 pack_single_float(FLT_MIN));
1546 make_constant("least-positive-double-float",
1547 make_boxfloat(DBL_MIN, TYPE_DOUBLE_FLOAT));
1548 make_constant("least-positive-long-float",
1549 make_boxfloat(DBL_MIN, TYPE_LONG_FLOAT));
1550 make_constant("least-negative-short-float",
1551 pack_short_float(-FLT_MIN));
1552 make_constant("least-negative-single-float",
1553 pack_single_float(-FLT_MIN));
1554 make_constant("least-negative-double-float",
1555 make_boxfloat(-DBL_MIN, TYPE_DOUBLE_FLOAT));
1556 make_constant("least-negative-long-float",
1557 make_boxfloat(-DBL_MIN, TYPE_LONG_FLOAT));
1558 //
1559 // The bunch here are intended to be NORMALISED numbers, while the unqualified
1560 // ones above may not be.
1561 //
1562 make_constant("least-positive-normalized-short-float",
1563 pack_short_float(FLT_MIN));
1564 make_constant("least-positive-normalized-single-float",
1565 pack_single_float(FLT_MIN));
1566 make_constant("least-positive-normalized-double-float",
1567 make_boxfloat(DBL_MIN, TYPE_DOUBLE_FLOAT));
1568 make_constant("least-positive-normalized-long-float",
1569 make_boxfloat(DBL_MIN, TYPE_LONG_FLOAT));
1570 make_constant("least-negative-normalized-short-float",
1571 pack_short_float(-FLT_MIN));
1572 make_constant("least-negative-normalized-single-float",
1573 pack_single_float(-FLT_MIN));
1574 make_constant("least-negative-normalized-double-float",
1575 make_boxfloat(-DBL_MIN, TYPE_DOUBLE_FLOAT));
1576 make_constant("least-negative-normalized-long-float",
1577 make_boxfloat(-DBL_MIN, TYPE_LONG_FLOAT));
1578 make_constant("internal-time-units-per-second",
1579 fixnum_of_int(1000));
1580
1581 terminal_io = make_undefined_fluid("*terminal-io*");
1582 standard_input = make_undefined_fluid("*standard-input*");
1583 standard_output = make_undefined_fluid("*standard-output*");
1584 error_output = make_undefined_fluid("*error-output*");
1585 trace_output = make_undefined_fluid("*trace-output*");
1586 debug_io = make_undefined_fluid("*debug-io*");
1587 query_io = make_undefined_fluid("*query-io*");
1588
1589 stream_type(lisp_work_stream) = make_undefined_symbol("work-stream");
1590
1591 { LispObject f = lisp_terminal_io;
1592 stream_type(f) = make_undefined_symbol("terminal-stream");
1593 set_stream_read_fn(f, char_from_terminal);
1594 set_stream_read_other(f, read_action_terminal);
1595 set_stream_write_fn(f, char_to_terminal);
1596 set_stream_write_other(f, write_action_terminal);
1597 setvalue(terminal_io, f);
1598 f = lisp_standard_input;
1599 stream_type(f) = make_undefined_symbol("synonym-stream");
1600 #ifdef COMMON
1601 //
1602 // If I do not have COMMON defined I will take a slight short cut here and
1603 // make reading from *standard-input* read directly from the terminal. For
1604 // full Common Lisp compatibility I think *standard-input* is required to
1605 // be a synonym stream that will dynamically look at the value of the variable
1606 // *terminal-io* every time it does anything. Ugh, since people who assign to
1607 // or re-bind *terminal-io* seem to me to be asking for terrible trouble!
1608 //
1609 set_stream_read_fn(f, char_from_synonym);
1610 #else
1611 set_stream_read_fn(f, char_from_terminal);
1612 #endif
1613 set_stream_read_other(f, read_action_synonym);
1614 stream_read_data(f) = terminal_io;
1615 setvalue(standard_input, f);
1616
1617 f = lisp_standard_output;
1618 stream_type(f) = make_undefined_symbol("synonym-stream");
1619 #ifdef COMMON
1620 set_stream_write_fn(f, char_to_synonym);
1621 #else
1622 set_stream_write_fn(f, char_to_terminal);
1623 #endif
1624 set_stream_write_other(f, write_action_synonym);
1625 stream_write_data(f) = terminal_io;
1626 setvalue(standard_output, f);
1627
1628 f = lisp_error_output;
1629 stream_type(f) = make_undefined_symbol("synonym-stream");
1630 #ifdef COMMON
1631 set_stream_write_fn(f, char_to_synonym);
1632 #else
1633 set_stream_write_fn(f, char_to_terminal);
1634 #endif
1635 set_stream_write_other(f, write_action_synonym);
1636 stream_write_data(f) = terminal_io;
1637 setvalue(error_output, f);
1638
1639 f = lisp_trace_output;
1640 stream_type(f) = make_undefined_symbol("synonym-stream");
1641 #ifdef COMMON
1642 set_stream_write_fn(f, char_to_synonym);
1643 #else
1644 set_stream_write_fn(f, char_to_terminal);
1645 #endif
1646 set_stream_write_other(f, write_action_synonym);
1647 stream_write_data(f) = terminal_io;
1648 setvalue(trace_output, f);
1649
1650 f = lisp_debug_io;
1651 stream_type(f) = make_undefined_symbol("synonym-stream");
1652 #ifdef COMMON
1653 set_stream_read_fn(f, char_from_synonym);
1654 #else
1655 set_stream_read_fn(f, char_from_terminal);
1656 #endif
1657 set_stream_read_other(f, read_action_synonym);
1658 stream_read_data(f) = terminal_io;
1659 #ifdef COMMON
1660 set_stream_write_fn(f, char_to_synonym);
1661 #else
1662 set_stream_write_fn(f, char_to_terminal);
1663 #endif
1664 set_stream_write_other(f, write_action_synonym);
1665 stream_write_data(f) = terminal_io;
1666 setvalue(debug_io, f);
1667
1668 f = lisp_query_io;
1669 stream_type(f) = make_undefined_symbol("synonym-stream");
1670 #ifdef COMMON
1671 set_stream_read_fn(f, char_from_synonym);
1672 #else
1673 set_stream_read_fn(f, char_from_terminal);
1674 #endif
1675 set_stream_read_other(f, read_action_synonym);
1676 stream_read_data(f) = terminal_io;
1677 #ifdef COMMON
1678 set_stream_write_fn(f, char_to_synonym);
1679 #else
1680 set_stream_write_fn(f, char_to_terminal);
1681 #endif
1682 set_stream_write_other(f, write_action_synonym);
1683 stream_write_data(f) = terminal_io;
1684 setvalue(query_io, f);
1685 }
1686
1687 #if defined HAVE_LIBFOX || defined HAVE_LIBWX
1688 { LispObject stream = make_undefined_fluid("*math-output*");
1689 LispObject f = make_stream_handle();
1690 stream_type(f) = make_undefined_symbol("math-output");
1691 set_stream_write_fn(f, char_to_math);
1692 set_stream_write_other(f, write_action_math);
1693 setvalue(stream, f);
1694 stream = make_undefined_fluid("*spool-output*");
1695 f = make_stream_handle();
1696 stream_type(f) = make_undefined_symbol("spool-output");
1697 set_stream_write_fn(f, char_to_spool);
1698 set_stream_write_other(f, write_action_spool);
1699 setvalue(stream, f);
1700 }
1701 #endif
1702
1703 // I can now predefine symbols in two ways:
1704 // -D name=val
1705 // --D name=val
1706 // The first of these matches old behaviour and the value assigned to name
1707 // is always a string. The second can turn it into a symbol, number etc.
1708 for (auto ss : symbolsToDefine)
1709 { bool undef = !ss.flag;
1710 const char *s = ss.key.c_str();
1711 if (undef)
1712 { LispObject n = make_undefined_symbol(s);
1713 setvalue(n, unset_var);
1714 }
1715 else
1716 { LispObject n = make_undefined_symbol(s);
1717 Save save(n);
1718 s = ss.data.c_str();
1719 // If you go "--D xxx" then treat it as "--D xxx=t".
1720 LispObject v;
1721 if (std::strlen(s) == 0) v = lisp_true;
1722 else
1723 { v = make_string(s);
1724 v = Lexplodec(nil, v);
1725 v = Lcompress(nil, v);
1726 //
1727 // The above will first make the value in -Dname=value into a string,
1728 // then explode it into a list, and compress back - the effect is as if the
1729 // original value had been passed through the regular Lisp READ function,
1730 // so symbols, numbers and even s-expressions can be parsed. If the
1731 // parsing fails I (silently) treat the value as just NIL.
1732 //
1733 }
1734 save.restore(n);
1735 setheader(n, qheader(n) | SYM_SPECIAL_VAR);
1736 setvalue(n, v);
1737 }
1738 }
1739 for (auto ss : stringsToDefine)
1740 { bool undef = !ss.flag;
1741 const char *s = ss.key.c_str();
1742 if (undef)
1743 { LispObject n = make_undefined_symbol(s);
1744 setvalue(n, unset_var);
1745 }
1746 else
1747 { LispObject n = make_undefined_symbol(s);
1748 Save save(n);
1749 s = ss.data.c_str();
1750 LispObject v;
1751 if (std::strlen(s) == 0) v = lisp_true;
1752 else v = make_string(s);
1753 save.restore(n);
1754 setheader(n, qheader(n) | SYM_SPECIAL_VAR);
1755 setvalue(n, v);
1756 }
1757 }
1758 for (auto ss : stringsToEvaluate)
1759 { const char *s = ss.c_str();
1760 TRY
1761 LispObject v = make_string(s);
1762 errexit();
1763 v = Lexplodec(nil, v);
1764 errexit();
1765 v = Lcompress(nil, v);
1766 errexit();
1767 Save save(v);
1768 Lprin(nil, v);
1769 save.restore(v);
1770 errexit();
1771 v = Leval(nil, v);
1772 errexit();
1773 Save save1(v);
1774 term_printf(" => ");
1775 errexit();
1776 save1.restore(v);
1777 Lprint(nil, v);
1778 // A failure in an expression set to be evaluated here is fatal.
1779 CATCH(LispException)
1780 ensure_screen();
1781 my_exit();
1782 END_CATCH
1783 }
1784 //
1785 // Now if I have the FWIN windowed system I look in the Lisp variables
1786 // loadable-packages!*
1787 // switches!*
1788 // (both expected to be lists of symbols) and copy info into a couple of
1789 // C vectors, whence it can go to the window manager and be used to create
1790 // suitable menus. I might get in a mess if I try to set and reset menus
1791 // multiple times, and so to avoid possible confusion I do this step
1792 // JUST ONCE. This may be limiting (in particular it means that menus get
1793 // set at the very start of a run ONLY) but should only be visible to those
1794 // who call restart!-csl.
1795 //
1796 if (loadable_packages == nullptr && switches==nullptr)
1797 { LispObject w1 = qvalue(make_undefined_symbol("loadable-packages*"));
1798 LispObject w2;
1799 int n;
1800 char *v;
1801 n = 0;
1802 for (w2=w1; consp(w2); w2=cdr(w2)) n++; // How many?
1803 n = 2*n;
1804 loadable_packages = new (std::nothrow) char *[n+1];
1805 if (loadable_packages != nullptr)
1806 { n = 0;
1807 for (w2=w1; consp(w2); w2=cdr(w2))
1808 { LispObject w3 = car(w2);
1809 int n1;
1810 if (is_symbol(w3)) w3 = qpname(w3);
1811 if (!is_vector(w3) ||
1812 !is_string_header(vechdr(w3))) break;
1813 n1 = length_of_byteheader(vechdr(w3))-CELL;
1814 v = new (std::nothrow) char[n1+2];
1815 if (v == nullptr) break;
1816 v[0] = ' ';
1817 std::memcpy(v+1, &celt(w3, 0), n1);
1818 v[n1+1] = 0;
1819 loadable_packages[n++] = v;
1820 loadable_packages[n++] = nullptr;
1821 }
1822 std::qsort(loadable_packages, n/2, 2*sizeof(char *), alpha1);
1823 loadable_packages[n] = nullptr; // nullptr-terminate the list
1824 }
1825 w1 = qvalue(make_undefined_symbol("switches*"));
1826 n = 0;
1827 for (w2=w1; consp(w2); w2=cdr(w2)) n++; // How many?
1828 n = (n+1)*sizeof(char *);
1829 n = 2*n;
1830 switches = new (std::nothrow) char *[n+1];
1831 if (switches != nullptr)
1832 { n = 0;
1833 for (w2=w1; consp(w2); w2=cdr(w2))
1834 { LispObject w3 = car(w2), w4;
1835 char sname[64];
1836 int n1;
1837 if (is_symbol(w3)) w3 = qpname(w3);
1838 if (!is_vector(w3) ||
1839 !is_string_header(vechdr(w3))) break;
1840 n1 = length_of_byteheader(vechdr(w3))-CELL;
1841 if (n1 > 60) break;
1842 std::sprintf(sname, "*%.*s", n1,
1843 reinterpret_cast<const char *>(&celt(w3, 0)));
1844 w4 = make_undefined_symbol(sname);
1845 v = new (std::nothrow) char[n1+2];
1846 if (v == nullptr) break;
1847 //
1848 // The first character records the current state of the switch. With FWIN
1849 // I have entries that say "x" for "I am not at present active" which copes
1850 // with switches that will become relevant only when a package of code is
1851 // loaded. I will scan from time to time to update my information - I guess
1852 // that I can put in a hook that triggers review after any module has been
1853 // loaded. See the function review_switch_settings() the follows...
1854 //
1855 if (qvalue(w4) == nil) v[0] = 'n';
1856 else if (qvalue(w4) == unset_var) v[0] = 'x';
1857 else v[0] = 'y';
1858 std::memcpy(v+1, &celt(w3, 0), n1);
1859 v[n1+1] = 0;
1860 switches[n++] = v;
1861 switches[n++] = nullptr;
1862 }
1863 std::qsort(switches, n/2, 2*sizeof(char *), alpha1);
1864 switches[n] = nullptr;
1865 }
1866 }
1867
1868 #ifdef COMMON
1869 CP = saved_package;
1870 #endif
1871 return nil;
1872 }
1873
1874 #ifndef COMMON
1875
1876 //
1877 // This alse reviews the list of loaded packages...
1878 //
1879 void review_switch_settings()
1880 { LispObject sw = qvalue(make_undefined_symbol("switches*"));
1881 while (consp(sw))
1882 { LispObject s = car(sw);
1883 char sname[64];
1884 int n1;
1885 char *v;
1886 char **p;
1887 LispObject starsw;
1888 sw = cdr(sw);
1889 if (is_symbol(s)) s = qpname(s);
1890 if (!is_vector(s) || !is_string_header(vechdr(s))) continue;
1891 n1 = length_of_byteheader(vechdr(s))-CELL;
1892 if (n1 > 60) continue;
1893 std::sprintf(sname, "*%.*s", n1,
1894 reinterpret_cast<const char *>(&celt(s, 0)));
1895 for (p=switches; *p!=nullptr; p+=2)
1896 { if (std::strcmp(1+*p, &sname[1]) == 0) break;
1897 }
1898 if ((v=*p) == nullptr) continue;
1899 starsw = make_undefined_symbol(sname);
1900 if (qvalue(starsw) == nil) switch(*v)
1901 { case 'y': *v = 0x3f&'N'; break;
1902 case 'n': break;
1903 case 'x': *v = 'N'; break;
1904 }
1905 else if (qvalue(starsw) == unset_var) switch(*v)
1906 { case 'y': *v = 'X'; break;
1907 case 'n': *v = 'X'; break;
1908 case 'x': break;
1909 }
1910 else switch(*v)
1911 { case 'y': break;
1912 case 'n': *v = 0x3f&'Y'; break;
1913 case 'x': *v = 'Y'; break;
1914 }
1915 }
1916 sw = qvalue(make_undefined_symbol("loaded-packages*"));
1917 while (consp(sw))
1918 { LispObject s = car(sw);
1919 char sname[64];
1920 int n1;
1921 char *v;
1922 char **p;
1923 sw = cdr(sw);
1924 if (is_symbol(s)) s = qpname(s);
1925 if (!is_vector(s) || !is_string_header(s)) continue;
1926 n1 = length_of_byteheader(vechdr(s))-CELL;
1927 if (n1 > 60) continue;
1928 std::sprintf(sname, "%.*s", n1,
1929 reinterpret_cast<const char *>(&celt(s, 0)));
1930 for (p=loadable_packages; *p!=nullptr; p+=2)
1931 { if (std::strcmp(1+*p, sname) == 0) break;
1932 }
1933 if ((v=*p) == nullptr) continue;
1934 if (*v == ' ') *v = 'X'; // X here says "update the info"
1935 }
1936 fwin_refresh_switches(switches, loadable_packages);
1937 }
1938
1939 #endif
1940
1941 bool CSL_MD5_busy;
1942
1943 // Used to ensure that an image file matches up with the C code compiled
1944 // into the main executable. The linear search here for the place the
1945 // checksum lives is a bit crummy. But the total cost is linear in the
1946 // number of things that have been compiled into C.
1947
1948 static void get_checksum(const setup_type *p)
1949 { while (p->name!=nullptr) p++;
1950 if (p->one != nullptr && p->two != nullptr)
1951 { const unsigned char *w = reinterpret_cast<const unsigned char *>
1952 (p->two);
1953 CSL_MD5_Update(w, std::strlen(reinterpret_cast<const char *>(w)));
1954 }
1955 }
1956
1957 void get_user_files_checksum(unsigned char *b)
1958 { size_t i;
1959 CSL_MD5_Init();
1960 for (i=0; setup_tables[i]!=nullptr; i++)
1961 get_checksum(setup_tables[i]);
1962 CSL_MD5_Final(b);
1963 }
1964
1965 #ifdef __ARM__
1966 // June 2016: on the Raspberry pi this code gets messed up by -O2 and -O3.
1967 // This may well be my fault, but for now I will hold the fort by sticking in
1968 // a pragma to downgrade the optimization (with a "z") level... Ugh. Every so
1969 // often I should revisit this and see if I can understand what aspect of the
1970 // code causes pain, or whether the Raspberry Pi version of g++ has moved on!
1971 #pragma GCC optimize ("1")
1972 #endif
1973
1974 void setup(int restart_flag, double store_size)
1975 {
1976 //
1977 // restart_flag is a set of options passed as a bitmap:
1978 // 1 Do a warm start, ie re-load a heap image.
1979 // The alternative is a cold start that should only
1980 // be called for as part of a system bootstrap process.
1981 // 2 Grab memory for CSL to use.
1982 // The alternative is to assume that memory has already been
1983 // allocated, and to re-use what there is.
1984 // 4, 8, ... not used yet!
1985 //
1986 int32_t i;
1987 if ((restart_flag & 2) != 0) init_heap_segments(store_size);
1988 garbage_collection_permitted = false;
1989 stack = stackBase;
1990 *stack = nil;
1991 exit_tag = exit_value = nil;
1992 exit_reason = UNWIND_NULL;
1993 for (int j=0; j<=LOG2_VECTOR_CHUNK_BYTES; j++)
1994 free_vectors[j] = 0;
1995
1996 if ((restart_flag & 1) != 0)
1997 { char junkbuf[120];
1998 char filename[LONGEST_LEGAL_FILENAME];
1999 std::memset(junkbuf, 0, sizeof(junkbuf));
2000 std::memset(filename, 0, sizeof(filename));
2001 if (IopenRoot(filename, 0, 0))
2002 { term_printf("\n+++ Image file \"%s\" can not be read\n",
2003 filename);
2004 my_exit();
2005 }
2006 // The initial record at the start of an image file is not compressed...
2007 Iread(junkbuf, 112);
2008 if (init_flags & INIT_VERBOSE)
2009 { term_printf("Created: %.25s\n", &junkbuf[64]);
2010 // Time dump was taken
2011 }
2012 unsigned char chk[16];
2013 get_user_files_checksum(chk);
2014 for (i=0; i<16; i++)
2015 { if (chk[i] != (junkbuf[90+i] & 0xff))
2016 { term_printf(
2017 "\n+++ Image file belongs with a different version\n");
2018 term_printf(
2019 " of the executable file (incompatible code\n");
2020 term_printf(
2021 " has been optimised into C and incorporated)\n");
2022 term_printf(
2023 " Unable to use this image file, so stopping\n");
2024 term_printf(
2025 " File is: %s\n", filename);
2026 my_exit();
2027 }
2028 }
2029 //
2030 // To make things more responsive for the user I will display a
2031 // banner rather early (before reading the bulk of the image file).
2032 // The banner that I will display is one provided to be by PRESERVE.
2033 //
2034 { char b[64];
2035 if (IopenRoot(filename, BANNER_CODE, 0)) b[0] = 0;
2036 else
2037 { for (i=0; i<64; i++) b[i] = static_cast<char>(Igetc());
2038 // The banner will not be subject to compression technology because it will
2039 // normally be too short to benefit.
2040 IcloseInput();
2041 }
2042 //
2043 // A banner set via startup-banner takes precedence over one from preserve.
2044 // But as a very special hack I detect if --texmacs was on the command
2045 // line and in that case I stay quiet...
2046 //
2047 if (!texmacs_mode)
2048 { if (b[0] != 0)
2049 { term_printf("%s\n", b);
2050 ensure_screen();
2051 }
2052 else if (junkbuf[0] != 0)
2053 { term_printf("%s\n", junkbuf);
2054 ensure_screen();
2055 }
2056 }
2057 }
2058 }
2059 else for (LispObject **p = list_bases; *p!=nullptr; p++) **p = nil;
2060
2061 stackLimit = reinterpret_cast<LispObject *>(
2062 ~static_cast<uintptr_t>(0xff) &
2063 reinterpret_cast<uintptr_t>(
2064 &stack[stack_segsize*CSL_PAGE_SIZE/CELL-200]));
2065 // allow some slop at end
2066
2067 #ifndef CONSERVATIVE
2068 void *p = vheap_pages[vheap_pages_count++] =
2069 allocate_page("vheap warm setup");
2070 vfringe = reinterpret_cast<LispObject>(
2071 8 + reinterpret_cast<char *>(doubleword_align_up(
2072 reinterpret_cast<intptr_t>(p))));
2073 vheaplimit = static_cast<LispObject>(vfringe + (CSL_PAGE_SIZE - 16));
2074 p = heap_pages[heap_pages_count++] = allocate_page("heap warm setup");
2075 lheaplimit = (intptr_t)p;
2076 lfringe = static_cast<LispObject>(lheaplimit + CSL_PAGE_SIZE);
2077 lheaplimit = static_cast<LispObject>(lheaplimit + SPARE);
2078 #endif // !CONSERVATIVE
2079
2080 if ((restart_flag & 1) != 0) warm_setup();
2081 else cold_setup();
2082
2083 if (init_flags & INIT_QUIET) Lverbos(nil, fixnum_of_int(1));
2084 if (init_flags & INIT_VERBOSE) Lverbos(nil, fixnum_of_int(3));
2085 #ifndef CONSERVATIVE
2086 //
2087 // Here I grab more memory (if I am allowed to) until the proportion of the
2088 // heap active at the end of garbage collection is less than 1/2. If the
2089 // attempt to grab more memory fails I clear the bit in init_flags that
2090 // allows me to try to expand, so I will not waste time again.
2091 // The aim of keeping the heap less than half full is an heuristic and
2092 // could be adjusted on the basis of experience with this code.
2093 //
2094 if ((init_flags & INIT_EXPANDABLE) != 0)
2095 { int32_t more = heap_pages_count + vheap_pages_count;
2096 more = 3 *more - pages_count;
2097 while (more-- > 0)
2098 { void *page = reinterpret_cast<void *>(
2099 new (std::nothrow) char[CSL_PAGE_SIZE]);
2100 if (page == nullptr)
2101 { init_flags &= ~INIT_EXPANDABLE;
2102 break;
2103 }
2104 else pages[pages_count++] = page;
2105 }
2106 }
2107 #endif
2108 { int32_t w = 0;
2109 //
2110 // The total store allocated is that used plus that free, including the
2111 // page set aside for the Lisp stack. I had better report this in Kbytes
2112 // which should then be sort of OK up to a total of 4000 Gbytes before the
2113 // unsigned long overflows on me.
2114 //
2115 if (init_flags & INIT_VERBOSE)
2116 { unsigned long m =
2117 (static_cast<unsigned long>(CSL_PAGE_SIZE/1000))*(pages_count+w+1);
2118 if (m > 4000)
2119 term_printf("Memory allocation: %lu Mbytes\n", m/1000);
2120 else term_printf("Memory allocation: %lu Kbytes\n", m);
2121 }
2122 }
2123 if (init_flags & INIT_VERBOSE)
2124 { unsigned int n = number_of_processors();
2125 if (n > 1)
2126 term_printf("There are %u processors available\n", n);
2127 }
2128 garbage_collection_permitted = true;
2129 return;
2130 }
2131
2132 LispObject multiplication_buffer;
2133
2134 // Here is a table of all the list-bases that CSL marks from, and that
2135 // must have their values captured in checkpoint files.
2136
2137 LispObject *list_bases[] =
2138 { ¤t_package,
2139 &B_reg,
2140 &codevec,
2141 &litvec,
2142 &exit_tag,
2143 &exit_value,
2144 &catch_tags,
2145 &lisp_package,
2146 &boffo,
2147 &charvec,
2148 &sys_hash_table,
2149 &sxhash_hash_table,
2150 &help_index,
2151 &gensym_base,
2152 &err_table,
2153 &supervisor,
2154 &startfn,
2155 &faslvec,
2156 &tracedfn,
2157 &prompt_thing,
2158 &faslgensyms,
2159 ¤t_function,
2160 &active_stream,
2161 ¤t_module,
2162 &autoload_symbol,
2163 &big_divisor,
2164 &big_dividend,
2165 &big_quotient,
2166 &big_fake1,
2167 &big_fake2,
2168 &append_symbol,
2169 &applyhook,
2170 &cfunarg,
2171 &comma_at_symbol,
2172 &comma_symbol,
2173 &compiler_symbol,
2174 &comp_symbol,
2175 &cons_symbol,
2176 &list_symbol,
2177 &liststar_symbol,
2178 &eq_symbol,
2179 &eql_symbol,
2180 &cl_equal_symbol,
2181 &equal_symbol,
2182 &equalp_symbol,
2183 &go_symbol,
2184 &cond_symbol,
2185 &echo_symbol,
2186 &emsg_star,
2187 &evalhook,
2188 &eval_symbol,
2189 &expr_symbol,
2190 &features_symbol,
2191 &fexpr_symbol,
2192 &funarg,
2193 &function_symbol,
2194 &lambda,
2195 &lisp_true,
2196 &lower_symbol,
2197 ¯oexpand_hook,
2198 ¯o_symbol,
2199 &opt_key,
2200 &prinl_symbol,
2201 &progn_symbol,
2202 "e_symbol,
2203 &raise_symbol,
2204 &redef_msg,
2205 &rest_key,
2206 &savedef,
2207 &string_char_sym,
2208 &unset_var,
2209 &work_symbol,
2210 &lex_words,
2211 &get_counts,
2212 &fastget_names,
2213 &input_libraries,
2214 &output_library,
2215 ¤t_file,
2216 &break_function,
2217 &lisp_work_stream,
2218 &lisp_standard_output,
2219 &lisp_standard_input,
2220 &lisp_debug_io,
2221 &lisp_error_output,
2222 &lisp_query_io,
2223 &lisp_terminal_io,
2224 &lisp_trace_output,
2225 &standard_output,
2226 &standard_input,
2227 &debug_io,
2228 &error_output,
2229 &query_io,
2230 &terminal_io,
2231 &trace_output,
2232 &fasl_stream,
2233 &mv_call_symbol,
2234 &startup_symbol,
2235 &traceprint_symbol,
2236 &load_source_symbol,
2237 &load_selected_source_symbol,
2238 &bytecoded_symbol,
2239 &funcall_symbol,
2240 &gchook,
2241 &resources,
2242 &callstack,
2243 &procstack,
2244 &procmem,
2245 &multiplication_buffer,
2246 &trap_time,
2247 &gcknt_symbol,
2248 &apply_symbol,
2249 &keyword_package,
2250 &all_packages,
2251 &package_symbol,
2252 &internal_symbol,
2253 &external_symbol,
2254 &inherited_symbol,
2255 &key_key,
2256 &allow_other_keys,
2257 &aux_key,
2258 &format_symbol,
2259 &expand_def_symbol,
2260 &allow_key_key,
2261 &declare_symbol,
2262 &special_symbol,
2263 &large_modulus,
2264 &used_space,
2265 &avail_space,
2266 &eof_symbol,
2267 &call_stack,
2268 &nicknames_symbol,
2269 &use_symbol,
2270 &and_symbol,
2271 &or_symbol,
2272 ¬_symbol,
2273 &reader_workspace,
2274 &named_character,
2275 &read_float_format,
2276 &short_float,
2277 &single_float,
2278 &double_float,
2279 &long_float,
2280 &bit_symbol,
2281 &pathname_symbol,
2282 &print_array_sym,
2283 &read_base,
2284 &initial_element,
2285 &builtin0_symbol,
2286 &builtin1_symbol,
2287 &builtin2_symbol,
2288 &builtin3_symbol,
2289 &builtin4_symbol,
2290 &user_base_0,
2291 &user_base_1,
2292 &user_base_2,
2293 &user_base_3,
2294 &user_base_4,
2295 &user_base_5,
2296 &user_base_6,
2297 &user_base_7,
2298 &user_base_8,
2299 &user_base_9,
2300 &workbase[0],
2301 &workbase[1],
2302 &workbase[2], // a.k.a mv_2
2303 &workbase[3],
2304 &workbase[4],
2305 &workbase[5],
2306 &workbase[6],
2307 &workbase[7],
2308 &workbase[8],
2309 &workbase[9],
2310 &workbase[10],
2311 &workbase[11],
2312 &workbase[12],
2313 &workbase[13],
2314 &workbase[14],
2315 &workbase[15],
2316 &workbase[16],
2317 &workbase[17],
2318 &workbase[18],
2319 &workbase[19],
2320 &workbase[20],
2321 &workbase[21],
2322 &workbase[22],
2323 &workbase[23],
2324 &workbase[24],
2325 &workbase[25],
2326 &workbase[26],
2327 &workbase[27],
2328 &workbase[28],
2329 &workbase[29],
2330 &workbase[30],
2331 &workbase[31],
2332 &workbase[32],
2333 &workbase[33],
2334 &workbase[34],
2335 &workbase[35],
2336 &workbase[36],
2337 &workbase[37],
2338 &workbase[38],
2339 &workbase[39],
2340 &workbase[40],
2341 &workbase[41],
2342 &workbase[42],
2343 &workbase[43],
2344 &workbase[44],
2345 &workbase[45],
2346 &workbase[46],
2347 &workbase[47],
2348 &workbase[48],
2349 &workbase[49],
2350 &workbase[50],
2351 nullptr // Used to mark the end of the table.
2352 };
2353
2354 //
2355 // June 2015: I am now going to try MD5 code from Alexander Peslyak
2356 // (Solar Designer). The code is public domain and all I do here is provide
2357 // wrappers so it appears to the bulk of CSL just as the previous version had.
2358 // The main motivation for this is that I must have corrupted the Eric
2359 // Younger code at some stage since it returned incorrect results for input
2360 // strings whose length was 55 mod 64. This showed up when comparing behaviour
2361 // with a Java-coded equivalent. I expect I could track down just what I had
2362 // wrong, but moving to the alternative public domain implementation seemed
2363 // both a good way to verify that the existing code I had was wrong and to end
2364 // up with something clean and tidy for the future.
2365 //
2366 // Please note that these days MD5 is not considered cryptographically secure,
2367 // and the implementation here will not be robust against side-attacks etc.
2368 // The proper uses hare are as a checksum fur use when chance rather than
2369 // malice is the opponent.
2370 //
2371 // The Checksums here are used in two areas in CSL:
2372 // (1) There is a user-visible checksum function that can be applied to
2373 // arbitrary Lisp objects. It is for whatever use anybody might like to
2374 // make of it.
2375 // (2) There is a scheme that ensures that Lisp that has been translated
2376 // into C++ and put in u01.cpp .. u60.cpp is only activated when a
2377 // Lisp function with the same checksum is to be used.
2378
2379 #include "md5.cpp"
2380
2381 MD5_CTX context;
2382
2383 void CSL_MD5_Init()
2384 { CSL_MD5_busy = true;
2385 MD5_Init(&context);
2386 }
2387
2388 void CSL_MD5_Update(const unsigned char *data, size_t len)
2389 { MD5_Update(&context, data, len);
2390 }
2391
2392 void CSL_MD5_Final(unsigned char *md)
2393 { MD5_Final(md, &context);
2394 CSL_MD5_busy = false;
2395 }
2396
2397 // end of restart.cpp
2398