Projects : gscm : gscm_usrbin
1 | /************** |
2 | * Gales Scheme |
3 | * |
4 | * A Scheme interpreter for Unix striving for simplicity, soundness, minimal |
5 | * artificial restrictions, and R5RS compliance with strict error checking. |
6 | * |
7 | * J. Welsh |
8 | * January 2017 - April 2018 |
9 | */ |
10 | |
11 | #include <errno.h> |
12 | #include <limits.h> |
13 | #include <math.h> |
14 | #include <setjmp.h> |
15 | |
16 | #include <fcntl.h> |
17 | #include <unistd.h> |
18 | #include <poll.h> |
19 | #include <sys/mman.h> |
20 | #include <sys/wait.h> |
21 | |
22 | #include <sys/socket.h> |
23 | #include <sys/un.h> |
24 | #include <netinet/in.h> |
25 | |
26 | #ifndef MAP_ANON |
27 | #define MAP_ANON MAP_ANONYMOUS |
28 | #endif |
29 | |
30 | int snprintf(char *, size_t, const char *, ...); /* to be replaced */ |
31 | void abort(void); |
32 | size_t strlen(const char *); |
33 | char *strerror(int); |
34 | void *memcpy(void *, const void *, size_t); |
35 | void *memset(void *, int, size_t); |
36 | int memcmp(const void *, const void *, size_t); |
37 | pid_t vfork(void); |
38 | |
39 | #include "gscm.h" |
40 | |
41 | |
42 | /****************** |
43 | * Memory structure |
44 | */ |
45 | |
46 | /* The Scheme heap is an array of N-bit cells where N is the size of a machine |
47 | * address. */ |
48 | |
49 | typedef size_t value; |
50 | typedef value (*builtin_func_t)(value args); |
51 | typedef unsigned char uchar; |
52 | typedef unsigned long ulong; |
53 | typedef unsigned int uint; |
54 | |
55 | /* Principal type tag: three most significant bits of cell */ |
56 | #define TAG_BITS 3 |
57 | |
58 | #define T_SPECIAL 0 /* Special values listed below */ |
59 | #define T_MOVED 1 /* "Broken heart" pointer to GC moved object */ |
60 | #define T_IMMUT_PAIR 2 /* Pointer to car with cdr following */ |
61 | #define T_PAIR 3 |
62 | #define T_CHARACTER 4 /* Character in least significant byte */ |
63 | #define T_FIXNUM 5 /* N-3 bit two's complement signed integer */ |
64 | #define T_EXTENDED 6 /* Pointer to extended object */ |
65 | #define T_EXT_HEADER 7 /* Extended type header */ |
66 | |
67 | /* Special values indicated by T_SPECIAL. Since that's zero, these can be |
68 | * compared with values directly. */ |
69 | #define SC_NULL 0 |
70 | #define SC_TRUE 1 |
71 | #define SC_FALSE 2 |
72 | #define SC_EOF 3 |
73 | #define SC_NULL_ENV 4 |
74 | #define SC_REPORT_ENV 5 |
75 | #define SC_GSCM_ENV 6 |
76 | #define SC_INTERACT_ENV 7 |
77 | #define SC_TOPLEVEL_ENV 8 |
78 | /* Inaccessible from Scheme */ |
79 | #define UNDEFINED 9 |
80 | #define RD_CLOSEPAREN 10 /* Returned internally by reader subroutines */ |
81 | #define RD_DOT 11 |
82 | |
83 | /* T_SPECIAL is also implicitly (ab)used for return addresses (EV_*, RD_* and |
84 | * so on) and loop counters on the stack. GC doesn't have to know what they |
85 | * really are as long as it treats them as immediate values. */ |
86 | |
87 | /* Extended objects consist of a header cell (T_EXT_HEADER) containing extended |
88 | * type information followed by possibly untagged data cells, depending on |
89 | * type. The four bits following the principal tag in the header are the |
90 | * extended type tag: */ |
91 | #define T_IMMUT_STRING 0x0 |
92 | #define T_STRING 0x1 |
93 | #define T_IMMUT_VECTOR 0x2 |
94 | #define T_VECTOR 0x3 |
95 | #define T_VARIABLE_REF 0x4 |
96 | #define T_SYMBOL 0x5 |
97 | #define T_BUILTIN 0x6 |
98 | #define T_PROCEDURE 0x7 |
99 | #define T_CONTINUATION 0x8 |
100 | #define T_PROMISE 0x9 |
101 | #define T_PORT 0xA |
102 | #define T_FLONUM 0xB /* is_number assumes all numbers from here */ |
103 | #define T_BIGNUM 0xC |
104 | #define T_NEG_BIGNUM 0xD |
105 | #define T_RATIONAL 0xE |
106 | #define T_COMPLEX 0xF |
107 | |
108 | /* Tags for types with immutable variants, both principal and extended, must |
109 | * be equal to the bitwise OR of 1 with the immutable variant. That is, the |
110 | * least significant tag bit is the mutability flag, where applicable. */ |
111 | |
112 | /* Symbols, strings, vectors, and bignums store their length in the header as |
113 | * an N-7 bit unsigned integer. For vectors and bignums, that many cells |
114 | * follow. Strings and symbols are packed, so ceil(length/(N/8)) cells follow. |
115 | * Lexical variable references store the argument index in this space. |
116 | * |
117 | * Example for 32-bit systems: |
118 | * - Pointers/fixnums have 29 bits |
119 | * - Max heap size is 2^29 = 512M cells of 4 bytes = 2 GiB (4 during GC) |
120 | * - Longest string is 2^25 characters = 32 MiB |
121 | * - Longest vector is 2^25 cells = 128 MiB (not counting any pointer targets) |
122 | * - Longest bignum is 2^25 cells = 2^30 bits for a magnitute ~ 10^10^8 |
123 | * |
124 | * If the size limits are a problem, the length could be stored in an untagged |
125 | * or fixnum cell after the header. */ |
126 | |
127 | #if __SIZEOF_POINTER__ == 8 |
128 | #define VAL_BITS 61 |
129 | #define EXT_VAL_BITS 57 |
130 | #define FIXNUM_MAX 0x0FFFFFFFFFFFFFFF |
131 | #define FIXNUM_MIN -0x1000000000000000 |
132 | #define EXT_LENGTH_MAX 0x01FFFFFFFFFFFFFF |
133 | #define packed_str_len(bytes) (((bytes) + 7) >> 3) |
134 | #define FLONUM_CELLS 1 |
135 | |
136 | #elif __SIZEOF_POINTER__ == 4 |
137 | #define VAL_BITS 29 |
138 | #define EXT_VAL_BITS 25 |
139 | #define FIXNUM_MAX 0x0FFFFFFF |
140 | #define FIXNUM_MIN -0x10000000 |
141 | #define EXT_LENGTH_MAX 0x01FFFFFF |
142 | #define packed_str_len(bytes) (((bytes) + 3) >> 2) |
143 | #define FLONUM_CELLS 2 |
144 | |
145 | #else |
146 | #error Unsupported pointer size |
147 | #endif |
148 | |
149 | #define tag(v) (((value)(v)) >> VAL_BITS) |
150 | #define add_tag(v, t) ((v) | (((value)(t)) << VAL_BITS)) |
151 | #define untag(v) ((((value)(v)) << 3) >> 3) |
152 | #define untag_signed(v) (((long) (((value)(v)) << 3)) >> 3) |
153 | #define ext_tag(v) (((v) >> EXT_VAL_BITS) & 0xF) |
154 | #define ext_add_tag(v, t) ((v) | ((value)(t) << EXT_VAL_BITS) | \ |
155 | (((value)T_EXT_HEADER) << VAL_BITS)) |
156 | #define ext_untag(v) ((((value)(v)) << 7) >> 7) |
157 | #define ext_untag_signed(v) (((long) (((value)(v)) << 7)) >> 7) |
158 | /* WARNING: add_tag/ext_add_tag assume v's tag bits are zero */ |
159 | |
160 | static value car(value); |
161 | static value cdr(value); |
162 | |
163 | |
164 | /****************** |
165 | * Scheme registers |
166 | */ |
167 | |
168 | /* General purpose */ |
169 | static value r0, r1, r2, r3, r4, r5, r6; |
170 | /* Special purpose */ |
171 | static value r_stack, r_spool, r_error_cont, r_signal_handler, r_compiler, |
172 | r_compiler_expr, r_input_port, r_output_port, r_dump; |
173 | static enum { |
174 | f_none, |
175 | f_compile, |
176 | f_apply, |
177 | f_force, |
178 | f_call_with_values, |
179 | f_values, |
180 | } r_flag; |
181 | |
182 | /* Register aliases to make usage more readable. Some rules for validation: |
183 | * - A subroutine may use a single register under different aliases, but before |
184 | * it is read or used as an argument under one alias, it must have been: |
185 | * - Assigned or declared as a parameter under the same alias, and |
186 | * - Not meanwhile assigned under a different alias. |
187 | * - Parameter registers must be distinct. |
188 | */ |
189 | #define R_EXPR r0 /* expression being evaluated */ |
190 | #define R_ARGS r0 /* arguments to apply procedure to */ |
191 | |
192 | #define R_ENV r1 /* evaluation environment */ |
193 | #define R_PROC r1 /* procedure to apply */ |
194 | #define R_PORT r1 /* argument to I/O routines */ |
195 | #define R_ARG r1 |
196 | |
197 | #define R_RESULT r2 /* subroutine return value */ |
198 | #define R_LEXEME r2 |
199 | #define R_FORMALS r2 |
200 | #define R_WIND_TO r2 |
201 | |
202 | #define R_VARNAME r3 |
203 | #define R_TAIL r3 /* last pair of a list being built */ |
204 | #define R_LCA r3 |
205 | |
206 | #define R_OPERANDS r4 |
207 | #define R_SECOND_LAST r4 |
208 | |
209 | #define R_CAR r5 /* argument to cons or push */ |
210 | |
211 | #define R_CDR r6 /* argument to cons */ |
212 | #define R_ITER r6 |
213 | |
214 | |
215 | /***************** |
216 | * Syscall helpers |
217 | */ |
218 | |
219 | static int open_cloexec(const char *path, int flags) { |
220 | return open(path, flags | O_CLOEXEC, 0666); |
221 | /* Non-atomic version for systems lacking O_CLOEXEC |
222 | int fd = open(path, flags, 0666); |
223 | if (fd != -1) fcntl(fd, F_SETFD, FD_CLOEXEC); |
224 | return fd; |
225 | */ |
226 | } |
227 | |
228 | static int pipe_cloexec(int pipefd[2]) { |
229 | return pipe2(pipefd, O_CLOEXEC); |
230 | /* Non-atomic version for systems lacking pipe2 |
231 | if (pipe(pipefd) == -1) return -1; |
232 | fcntl(pipefd[0], F_SETFD, FD_CLOEXEC); |
233 | fcntl(pipefd[1], F_SETFD, FD_CLOEXEC); |
234 | return 0; |
235 | */ |
236 | } |
237 | |
238 | /* Reliably catching close errors is NOT POSSIBLE on Linux and others. The call |
239 | * may block and be interrupted by a signal handler, yet cannot be retried as |
240 | * the FD is deallocated early. HPUX at least has the atypical behavior of |
241 | * leaving the FD open, so it would leak. Should figure out where exactly close |
242 | * can block. */ |
243 | static void blind_close(int fd) { |
244 | int saved_errno = errno; |
245 | close(fd); |
246 | errno = saved_errno; |
247 | } |
248 | |
249 | static int poll1(int fd, short events, int timeout) { |
250 | int r; |
251 | struct pollfd sp; |
252 | sp.fd = fd; |
253 | sp.events = events; |
254 | while ((r = poll(&sp, 1, timeout)) == -1) |
255 | if (errno != EAGAIN && errno != EINTR) sc_perror(); |
256 | return r; |
257 | } |
258 | |
259 | static int write_all(int fd, const char *buf, ssize_t len) { |
260 | ssize_t n; |
261 | while ((n = write(fd, buf, len)) < len) { |
262 | if (n != -1) len -= n, buf += n; |
263 | else if (errno == EAGAIN || errno == EWOULDBLOCK) |
264 | poll1(fd, POLLOUT, -1); |
265 | else if (errno != EINTR) return -1; |
266 | } |
267 | return 0; |
268 | } |
269 | |
270 | void sc_write_error(const char *msg) { |
271 | size_t len = strlen(msg); |
272 | if (len) write_all(2, msg, len); |
273 | } |
274 | #define write_err sc_write_error |
275 | |
276 | static void flush_all(void); |
277 | |
278 | __attribute__((noreturn)) |
279 | void sc_exit(int status) { |
280 | flush_all(); |
281 | _exit(status); |
282 | } |
283 | |
284 | |
285 | /**************** |
286 | * Error handling |
287 | */ |
288 | |
289 | /* Failsafe error handler */ |
290 | |
291 | __attribute__((noreturn)) |
292 | static void fatal(const char *msg) { |
293 | write_err("FATAL: "); |
294 | write_err(msg); |
295 | write_err("\n"); |
296 | sc_exit(1); |
297 | } |
298 | |
299 | __attribute__((noreturn)) |
300 | static void fatal1(const char *msg, const char *detail) { |
301 | write_err("FATAL: "); |
302 | write_err(msg); |
303 | write_err(": "); |
304 | write_err(detail); |
305 | write_err("\n"); |
306 | sc_exit(1); |
307 | } |
308 | |
309 | __attribute__((noreturn)) |
310 | void sc_error(const char *msg) { sc_error1(msg, UNDEFINED); } |
311 | |
312 | __attribute__((noreturn)) |
313 | void sc_perror(void) { sc_error(strerror(errno)); } |
314 | |
315 | __attribute__((noreturn)) |
316 | void sc_perror1(value detail) { sc_error1(strerror(errno), detail); } |
317 | |
318 | static int chkp(int r) { if (r == -1) sc_perror(); return r; } |
319 | |
320 | static const char *fmt_ulong_dec(ulong); |
321 | |
322 | __attribute__((noreturn)) |
323 | void sc_assert_fail(const char *file, ulong line, const char *func, |
324 | const char *expr) { |
325 | const char *sep = ": "; |
326 | static int aborting = 0; |
327 | if (!aborting) flush_all(); |
328 | aborting = 1; |
329 | write_err("Assertion failed: "); |
330 | write_err(file); write_err(sep); |
331 | write_err(fmt_ulong_dec(line)); write_err(sep); |
332 | write_err(func); write_err(sep); |
333 | write_err(expr); write_err("\n"); |
334 | abort(); |
335 | } |
336 | |
337 | /* various common errors */ |
338 | |
339 | __attribute__((noreturn)) |
340 | static void not_a_number(value v) { sc_error1("not a number:", v); } |
341 | |
342 | |
343 | /******************************* |
344 | * Garbage collector & allocator |
345 | */ |
346 | |
347 | /* Heap discipline: |
348 | * |
349 | * This garbage collector uses the stop-and-copy (Minsky-Fenichel-Yochelson) |
350 | * method. Because it relocates values into a new heap and is triggered by |
351 | * allocation, any function that directly or indirectly calls sc_malloc cannot |
352 | * keep pointer types (T_PAIR, T_IMMUT_PAIR, T_EXTENDED) in local variables |
353 | * across such calls, as the addresses may be invalidated. The Scheme stack, |
354 | * registers, or otherwise statically stored variables registered as roots must |
355 | * be used instead. |
356 | * |
357 | * Such functions will generally be constructors and take their arguments |
358 | * through the stack or registers. Notably included are push and cons. |
359 | * Specifically not included are pop, peek, drop, car, cdr, set_car and |
360 | * set_cdr. |
361 | * |
362 | * The reward for this trouble is fast and compacting garbage collection. |
363 | */ |
364 | |
365 | static value *heap, *new_heap; |
366 | static value heap_size, free_ptr; |
367 | |
368 | #define ROOTS_ALLOC 48 |
369 | static value *roots[ROOTS_ALLOC]; |
370 | static value roots_fill; |
371 | |
372 | static void gc_root(value *handle) { |
373 | if (roots_fill >= ROOTS_ALLOC) fatal("insufficient ROOTS_ALLOC"); |
374 | roots[roots_fill] = handle; |
375 | ++roots_fill; |
376 | } |
377 | |
378 | static value ext_obj_size(value header) { |
379 | switch (ext_tag(header)) { |
380 | case T_IMMUT_STRING: |
381 | case T_STRING: return 1 + packed_str_len(ext_untag(header)); |
382 | case T_IMMUT_VECTOR: |
383 | case T_VECTOR: return 1 + ext_untag(header); |
384 | case T_VARIABLE_REF: return 2; |
385 | case T_SYMBOL: return 1 + packed_str_len(ext_untag(header)); |
386 | case T_BUILTIN: return 3; |
387 | case T_PROCEDURE: return 4; |
388 | case T_CONTINUATION: return 3; |
389 | case T_PROMISE: return 3; |
390 | case T_PORT: return 6; |
391 | case T_FLONUM: return 1 + FLONUM_CELLS; |
392 | case T_BIGNUM: |
393 | case T_NEG_BIGNUM: return 1 + ext_untag(header); |
394 | case T_RATIONAL: return 3; |
395 | case T_COMPLEX: return 3; |
396 | default: fatal("BUG: invalid extended tag"); |
397 | } |
398 | } |
399 | |
400 | /* Process one cell (in either a root or the new heap), returning number of |
401 | * cells to advance */ |
402 | static value scan_cell(value *scan_val) { |
403 | int scan_tag = tag(*scan_val); |
404 | value ptr, old_val, length; |
405 | assert(scan_tag != T_MOVED); |
406 | switch (scan_tag) { |
407 | case T_IMMUT_PAIR: |
408 | case T_PAIR: |
409 | case T_EXTENDED: |
410 | ptr = untag(*scan_val); |
411 | old_val = heap[ptr]; |
412 | if (tag(old_val) == T_MOVED) |
413 | *scan_val = add_tag(untag(old_val), scan_tag); |
414 | else { |
415 | *scan_val = add_tag(free_ptr, scan_tag); |
416 | length = (scan_tag == T_EXTENDED) ? ext_obj_size(old_val) : 2; |
417 | memcpy(&new_heap[free_ptr], &heap[ptr], length*sizeof(value)); |
418 | heap[ptr] = add_tag(free_ptr, T_MOVED); |
419 | free_ptr += length; |
420 | } |
421 | return 1; |
422 | case T_EXT_HEADER: |
423 | switch (ext_tag(*scan_val)) { |
424 | /* For compound types, skip the header and scan each element */ |
425 | case T_IMMUT_VECTOR: |
426 | case T_VECTOR: |
427 | case T_VARIABLE_REF: |
428 | case T_PROCEDURE: |
429 | case T_CONTINUATION: |
430 | case T_PROMISE: |
431 | case T_PORT: |
432 | case T_RATIONAL: |
433 | case T_COMPLEX: |
434 | return 1; |
435 | /* Otherwise skip the whole blob */ |
436 | default: |
437 | return ext_obj_size(*scan_val); |
438 | } |
439 | default: |
440 | /* All other principal types are immediate values */ |
441 | return 1; |
442 | } |
443 | } |
444 | |
445 | uint sc_gc_verbose = 0, sc_gc_thrash_factor = 16; |
446 | |
447 | void sc_gc(void) { |
448 | value root, scan_ptr, *tmp; |
449 | if (sc_gc_verbose) { |
450 | static ulong gc_count = 0; |
451 | write_err("GC: cycle "); |
452 | write_err(fmt_ulong_dec(++gc_count)); |
453 | write_err(" | "); |
454 | } |
455 | free_ptr = 0; |
456 | for (root = 0; root < roots_fill; ++root) scan_cell(roots[root]); |
457 | for (scan_ptr = 0; scan_ptr < free_ptr; |
458 | scan_ptr += scan_cell(&new_heap[scan_ptr])) |
459 | assert(free_ptr <= heap_size); |
460 | tmp = heap; |
461 | heap = new_heap; |
462 | new_heap = tmp; |
463 | if (sc_gc_verbose) { |
464 | /* using floating point to avoid overflow */ |
465 | double live_bytes = free_ptr*sizeof(value); |
466 | double live_pct = 100.*free_ptr/heap_size; |
467 | write_err(fmt_ulong_dec(free_ptr)); |
468 | write_err(" cells | "); |
469 | write_err(fmt_ulong_dec((live_bytes+1023.)/1024.)); |
470 | write_err("K | "); |
471 | write_err(fmt_ulong_dec(live_pct)); |
472 | write_err("."); |
473 | write_err(fmt_ulong_dec(((unsigned)(10.*live_pct))%10)); |
474 | write_err("% live\n"); |
475 | } |
476 | } |
477 | |
478 | static value sc_malloc(size_t cells) { |
479 | value result = free_ptr; |
480 | free_ptr += cells; |
481 | if (free_ptr > heap_size) { |
482 | sc_gc(); |
483 | result = free_ptr; |
484 | free_ptr += cells; |
485 | if (free_ptr > (heap_size - heap_size/sc_gc_thrash_factor)) { |
486 | /* Clear registers in hopes of freeing space. While not guaranteed, |
487 | * this can help simple cases like recovering the REPL after a |
488 | * runaway recursion. */ |
489 | r0 = r1 = r2 = r3 = r4 = r5 = r6 = r_stack = SC_NULL; |
490 | sc_error("out of memory"); |
491 | } |
492 | } |
493 | return result; |
494 | } |
495 | |
496 | |
497 | /************************* |
498 | * Scheme stack operations |
499 | */ |
500 | |
501 | /* Push R_CAR onto the stack (no other side effects) */ |
502 | static void push(void) { |
503 | value new_stack = sc_malloc(2); |
504 | heap[new_stack] = R_CAR; |
505 | heap[new_stack+1] = r_stack; |
506 | r_stack = add_tag(new_stack, T_PAIR); |
507 | } |
508 | |
509 | /* Shorthand to push an arbitrary value */ |
510 | #define PUSH(val) { R_CAR = (val); push(); } |
511 | |
512 | /* Remove the top of the stack */ |
513 | static void drop(void) { |
514 | r_stack = cdr(r_stack); |
515 | } |
516 | |
517 | /* Return the top of the stack */ |
518 | static value peek(void) { |
519 | return car(r_stack); |
520 | } |
521 | |
522 | /* Remove and return the top of the stack */ |
523 | static value pop(void) { |
524 | value v = car(r_stack); |
525 | r_stack = cdr(r_stack); |
526 | return v; |
527 | } |
528 | |
529 | |
530 | /*************************************************** |
531 | * Builtin type constructors, predicates & accessors |
532 | */ |
533 | |
534 | static int is_ext_type(value v, uint t) { |
535 | return tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) == t; |
536 | } |
537 | |
538 | static int is_mutable(value v) { |
539 | int t = tag(v); |
540 | if (t != T_EXTENDED) return t == T_PAIR; |
541 | t = ext_tag(heap[untag(v)]); |
542 | return t == T_STRING || t == T_VECTOR; |
543 | } |
544 | |
545 | /* Booleans */ |
546 | |
547 | static value boolean(int b) { return b ? SC_TRUE : SC_FALSE; } |
548 | static int is_boolean(value v) { return v == SC_TRUE || v == SC_FALSE; } |
549 | |
550 | /* Pairs & lists */ |
551 | |
552 | /* Return a new pair from the values of R_CAR and R_CDR */ |
553 | static value cons(void) { |
554 | value p = sc_malloc(2); |
555 | heap[p] = R_CAR; |
556 | heap[p+1] = R_CDR; |
557 | return add_tag(p, T_PAIR); |
558 | } |
559 | static value cons_immutable(void) { |
560 | value p = sc_malloc(2); |
561 | heap[p] = R_CAR; |
562 | heap[p+1] = R_CDR; |
563 | return add_tag(p, T_IMMUT_PAIR); |
564 | } |
565 | static int is_pair(value v) { return (tag(v) | 1) == T_PAIR; } |
566 | static value car(value p) { |
567 | assert(is_pair(p)); |
568 | return heap[untag(p)]; |
569 | } |
570 | static value cdr(value p) { |
571 | assert(is_pair(p)); |
572 | return heap[untag(p)+1]; |
573 | } |
574 | static void set_car(value p, value v) { |
575 | assert(is_pair(p)); |
576 | heap[untag(p)] = v; |
577 | } |
578 | static void set_cdr(value p, value v) { |
579 | assert(is_pair(p)); |
580 | heap[untag(p)+1] = v; |
581 | } |
582 | static value safe_car(value p) { |
583 | if (!is_pair(p)) sc_error1("not a pair:", p); |
584 | return car(p); |
585 | } |
586 | static value safe_cdr(value p) { |
587 | if (!is_pair(p)) sc_error1("not a pair:", p); |
588 | return cdr(p); |
589 | } |
590 | #define cadr(x) car(cdr(x)) |
591 | |
592 | /* Safely compute the length of a list, returning -1 if not a proper list */ |
593 | static long safe_list_length(value v) { |
594 | /* Floyd's cycle-finding algorithm */ |
595 | value slow = v, fast = v, length = 0; |
596 | while (is_pair(fast)) { |
597 | slow = cdr(slow); |
598 | fast = cdr(fast); |
599 | length++; |
600 | if (!is_pair(fast)) break; |
601 | fast = cdr(fast); |
602 | if (fast == slow) return -1; /* cycle */ |
603 | length++; |
604 | } |
605 | if (fast != SC_NULL) return -1; /* improper list or not a pair */ |
606 | return length; |
607 | } |
608 | static int is_list(value v) { return safe_list_length(v) >= 0; } |
609 | |
610 | /* Compute the length of a proper list */ |
611 | static value list_length(value l) { |
612 | value length = 0; |
613 | for (; l != SC_NULL; l = cdr(l)) length++; |
614 | return length; |
615 | } |
616 | |
617 | /* Find the first node shared by two proper lists; that is, the LCA of two |
618 | * nodes in the parent-pointer tree rooted at the empty list. */ |
619 | static value lowest_common_ancestor(value a, value b) { |
620 | value al = list_length(a), bl = list_length(b); |
621 | if (al != bl) { |
622 | if (al > bl) |
623 | do a = cdr(a), --al; while (al > bl); |
624 | else |
625 | do b = cdr(b), --bl; while (bl > al); |
626 | } |
627 | while (a != b) a = cdr(a), b = cdr(b); |
628 | return a; |
629 | } |
630 | |
631 | /* Numbers */ |
632 | |
633 | static value fixnum_zero, fixnum_one; |
634 | |
635 | /* Not bounds checked! */ |
636 | static value fixnum(long n) { return add_tag(untag(n), T_FIXNUM); } |
637 | static int is_fixnum(value v) { return tag(v) == T_FIXNUM; } |
638 | static long fixnum_val(value v) { |
639 | assert(is_fixnum(v)); |
640 | return untag_signed(v); |
641 | } |
642 | static ulong unsigned_fixnum_val(value v) { |
643 | assert(is_fixnum(v)); |
644 | return untag(v); |
645 | } |
646 | static long safe_fixnum_val(value v) { |
647 | if (is_fixnum(v)) return untag_signed(v); |
648 | sc_error1("not an integer or out of bounds:", v); |
649 | } |
650 | |
651 | static value flonum(double x) { |
652 | value f = sc_malloc(1 + FLONUM_CELLS); |
653 | heap[f] = ext_add_tag(0, T_FLONUM); |
654 | /* strict aliasing? |
655 | *((double *)&heap[f+1]) = x; */ |
656 | memcpy(&heap[f+1], &x, sizeof x); |
657 | return add_tag(f, T_EXTENDED); |
658 | } |
659 | static int is_flonum(value v) { return is_ext_type(v, T_FLONUM); } |
660 | static double flonum_val(value f) { |
661 | /* strict aliasing? |
662 | return *((double *)&heap[untag(f)+1]); */ |
663 | double x; |
664 | assert(is_flonum(f)); |
665 | memcpy(&x, &heap[untag(f)+1], sizeof x); |
666 | return x; |
667 | } |
668 | |
669 | static value make_bignum_uninit(value len, int neg) { |
670 | value ptr; |
671 | if (len > EXT_LENGTH_MAX) sc_error("length too large for bignum"); |
672 | ptr = sc_malloc(1 + len); |
673 | heap[ptr] = ext_add_tag(len, T_BIGNUM | neg); |
674 | return add_tag(ptr, T_EXTENDED); |
675 | } |
676 | static int is_bignum(value v) { |
677 | return tag(v) == T_EXTENDED && (ext_tag(heap[untag(v)]) | 1) == |
678 | T_NEG_BIGNUM; |
679 | } |
680 | static value bignum_len(value n) { |
681 | assert(is_bignum(n)); |
682 | return ext_untag(heap[untag(n)]); |
683 | } |
684 | static value bignum_ref(value n, value k) { |
685 | assert(k < bignum_len(n)); |
686 | return heap[untag(n)+k+1]; |
687 | } |
688 | static void bignum_set(value n, value k, value word) { |
689 | assert(k < bignum_len(n)); |
690 | assert(is_fixnum(word)); |
691 | heap[untag(n)+k+1] = word; |
692 | } |
693 | static int is_bignum_negative(value n) { |
694 | assert(is_bignum(n)); |
695 | return ext_tag(heap[untag(n)]) & 1; |
696 | } |
697 | static value bignum_set_negative(value n) { |
698 | assert(is_bignum(n)); |
699 | heap[untag(n)] |= (1UL << EXT_VAL_BITS); |
700 | return n; |
701 | } |
702 | /* Truncate bignum in place (consider carefully how GC works) */ |
703 | static value bignum_truncate(value n, value len) { |
704 | assert(len <= bignum_len(n)); |
705 | value ptr = untag(n); |
706 | heap[ptr] = ext_add_tag(len, ext_tag(heap[ptr])); |
707 | return n; |
708 | } |
709 | |
710 | static int is_rational(value v) { return is_ext_type(v, T_RATIONAL); } |
711 | |
712 | static int is_exact(value v) { |
713 | return is_fixnum(v) || is_bignum(v) || is_rational(v); |
714 | } |
715 | static int is_number(value v) { |
716 | return is_fixnum(v) || |
717 | (tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) >= T_FLONUM); |
718 | } |
719 | static int is_integer(value v) { |
720 | if (is_fixnum(v) || is_bignum(v)) return 1; |
721 | if (is_flonum(v)) { |
722 | double f = flonum_val(v); |
723 | return f == nearbyint(f); |
724 | } |
725 | return 0; |
726 | } |
727 | |
728 | /* Characters */ |
729 | |
730 | static value character(uchar c) { return add_tag(c, T_CHARACTER); } |
731 | static int is_character(value v) { return tag(v) == T_CHARACTER; } |
732 | static uchar safe_char_val(value c) { |
733 | if (!is_character(c)) sc_error1("not a character:", c); |
734 | return (uchar)c; |
735 | } |
736 | #define char_val(c) ((uchar)(c)) |
737 | |
738 | /* Convert ASCII characters to upper/lowercase */ |
739 | static uchar uc(uchar c) { |
740 | if (c >= 'a' && c <= 'z') return c - 0x20; |
741 | return c; |
742 | } |
743 | static uchar lc(uchar c) { |
744 | if (c >= 'A' && c <= 'Z') return c + 0x20; |
745 | return c; |
746 | } |
747 | |
748 | /* Strings */ |
749 | |
750 | static value alloc_string(value len) { |
751 | if (len > EXT_LENGTH_MAX) |
752 | sc_error("length negative or too large for string"); |
753 | return sc_malloc(1 + packed_str_len(len)); |
754 | } |
755 | static value make_string_uninit(value len) { |
756 | value ptr = alloc_string(len); |
757 | heap[ptr] = ext_add_tag(len, T_STRING); |
758 | return add_tag(ptr, T_EXTENDED); |
759 | } |
760 | static value make_immutable_string(value len) { |
761 | value ptr = alloc_string(len); |
762 | heap[ptr] = ext_add_tag(len, T_IMMUT_STRING); |
763 | return add_tag(ptr, T_EXTENDED); |
764 | } |
765 | static int is_string(value v) { |
766 | return tag(v) == T_EXTENDED && (ext_tag(heap[untag(v)]) | 1) == T_STRING; |
767 | } |
768 | static int is_mutable_string(value v) { |
769 | return tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) == T_STRING; |
770 | } |
771 | static int is_symbol(value); |
772 | static uchar * string_buf(value s) { |
773 | assert(is_string(s) || is_symbol(s)); |
774 | return (uchar *)&heap[untag(s)+1]; |
775 | } |
776 | /* C thinks strings are made of signed chars for some reason... */ |
777 | static char * c_string_buf(value s) { |
778 | assert(is_string(s) || is_symbol(s)); |
779 | return (char *)string_buf(s); |
780 | } |
781 | static value string_len(value s) { |
782 | assert(is_string(s) || is_symbol(s)); |
783 | return ext_untag(heap[untag(s)]); |
784 | } |
785 | /* Construct string from null-terminated C string not on the Scheme heap */ |
786 | static value string(const char *c_str) { |
787 | value len = strlen(c_str); |
788 | value str = make_string_uninit(len); |
789 | memcpy(string_buf(str), c_str, len); |
790 | return str; |
791 | } |
792 | static value make_string(value len, uchar fill) { |
793 | value s = make_string_uninit(len); |
794 | memset(string_buf(s), fill, len); |
795 | return s; |
796 | } |
797 | /* Construct immutable copy of string or symbol in R_EXPR */ |
798 | static value string_copy_immutable(void) { |
799 | value len = string_len(R_EXPR), ptr = alloc_string(len); |
800 | heap[ptr] = ext_add_tag(len, T_IMMUT_STRING); |
801 | memcpy(heap+ptr+1, string_buf(R_EXPR), len); |
802 | return add_tag(ptr, T_EXTENDED); |
803 | } |
804 | /* Construct copy of string in R_EXPR */ |
805 | static value string_copy(void) { |
806 | value len = string_len(R_EXPR); |
807 | value result = make_string_uninit(len); |
808 | memcpy(string_buf(result), string_buf(R_EXPR), len); |
809 | return result; |
810 | } |
811 | /* Construct copy of string in R_EXPR with null byte appended */ |
812 | static value string_append_null(void) { |
813 | value len = string_len(R_EXPR); |
814 | value result = make_string_uninit(len + 1); |
815 | uchar *buf = string_buf(result); |
816 | memcpy(buf, string_buf(R_EXPR), len); |
817 | buf[len] = '\0'; |
818 | return result; |
819 | } |
820 | /* Truncate string in place (consider carefully how GC works) */ |
821 | static void string_truncate(value s, value len) { |
822 | assert(len <= string_len(s)); |
823 | value ptr = untag(s); |
824 | heap[ptr] = ext_add_tag(len, ext_tag(heap[ptr])); |
825 | } |
826 | |
827 | /* Symbols */ |
828 | |
829 | static value symbols; /* interning list */ |
830 | |
831 | /* Frequently used symbols */ |
832 | static value s_lambda, s_quote, s_quasiquote, s_unquote, s_unquote_splicing, |
833 | s_if, s_set, s_begin, s_letrec, s_define, s_delay, s_literal, |
834 | s_open_paren, s_close_paren, s_dot, s_open_vector, s_identifier, |
835 | s_named_char, s_abbrev, s_number, s_truncate, s_overwrite, |
836 | s_append, s_sync, s_data_sync; |
837 | |
838 | static value find_symbol(const uchar *buf, value len) { |
839 | value iter, sym; |
840 | /* some type checks skipped because interning list is not (directly) user |
841 | * modifiable */ |
842 | for (iter = symbols; iter != SC_NULL; iter = cdr(iter)) { |
843 | sym = car(iter); |
844 | if (len == ext_untag(heap[untag(sym)]) && |
845 | memcmp(buf, &heap[untag(sym)+1], len) == 0) |
846 | return sym; |
847 | } |
848 | return SC_NULL; |
849 | } |
850 | /* Get symbol from a null-terminated C string not on the Scheme heap, not |
851 | * converting case (side effects: R_CAR R_CDR) */ |
852 | static value symbol(const char *c_str) { |
853 | value len = strlen(c_str); |
854 | value sym = find_symbol((uchar *)c_str, len); |
855 | if (sym != SC_NULL) return sym; |
856 | value sym_ptr = sc_malloc(1 + packed_str_len(len)); |
857 | heap[sym_ptr] = ext_add_tag(len, T_SYMBOL); |
858 | memcpy(&heap[sym_ptr+1], c_str, len); |
859 | R_CAR = add_tag(sym_ptr, T_EXTENDED); |
860 | R_CDR = symbols; |
861 | symbols = cons(); |
862 | return R_CAR; |
863 | } |
864 | /* Get symbol from a Scheme string in R_CAR, not converting case |
865 | * (side effects: R_CAR R_CDR) */ |
866 | static value string_to_symbol(void) { |
867 | value len = string_len(R_CAR); |
868 | value sym = find_symbol(string_buf(R_CAR), len); |
869 | if (sym != SC_NULL) return sym; |
870 | value sym_ptr = sc_malloc(1 + packed_str_len(len)); |
871 | heap[sym_ptr] = ext_add_tag(len, T_SYMBOL); |
872 | memcpy(&heap[sym_ptr+1], string_buf(R_CAR), len); |
873 | R_CAR = add_tag(sym_ptr, T_EXTENDED); |
874 | R_CDR = symbols; |
875 | symbols = cons(); |
876 | return R_CAR; |
877 | } |
878 | static int is_symbol(value v) { return is_ext_type(v, T_SYMBOL); } |
879 | |
880 | /* Vectors */ |
881 | |
882 | static value alloc_vector(value len) { |
883 | if (len > EXT_LENGTH_MAX) |
884 | sc_error("length negative or too large for vector"); |
885 | return sc_malloc(1 + len); |
886 | } |
887 | /* Uninitialized constructors: caller must fill without further allocation */ |
888 | static value make_vector_uninit(value len) { |
889 | value vec = alloc_vector(len); |
890 | heap[vec] = ext_add_tag(len, T_VECTOR); |
891 | return add_tag(vec, T_EXTENDED); |
892 | } |
893 | static value make_immutable_vector(value len) { |
894 | value vec = alloc_vector(len); |
895 | heap[vec] = ext_add_tag(len, T_IMMUT_VECTOR); |
896 | return add_tag(vec, T_EXTENDED); |
897 | } |
898 | /* Build a new vector with each element initialized to R_EXPR */ |
899 | static value make_vector(value len) { |
900 | value vec = make_vector_uninit(len), *p; |
901 | for (p = heap+untag(vec)+1; len; --len, ++p) *p = R_EXPR; |
902 | return vec; |
903 | } |
904 | /* Build a new vector by reversing the elements of proper list R_EXPR */ |
905 | static value rev_list_to_vec(void) { |
906 | value len = list_length(R_EXPR), |
907 | vec = make_vector_uninit(len), |
908 | *p = heap+untag(vec)+len; |
909 | for (; R_EXPR != SC_NULL; --p, R_EXPR = cdr(R_EXPR)) *p = car(R_EXPR); |
910 | return vec; |
911 | } |
912 | static int is_vector(value v) { |
913 | return tag(v) == T_EXTENDED && (ext_tag(heap[untag(v)]) | 1) == T_VECTOR; |
914 | } |
915 | static int is_mutable_vector(value v) { |
916 | return tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) == T_VECTOR; |
917 | } |
918 | static value vector_len(value v) { |
919 | assert(is_vector(v)); |
920 | return ext_untag(heap[untag(v)]); |
921 | } |
922 | static value vector_ref(value v, value k) { |
923 | assert(k < vector_len(v)); |
924 | return heap[untag(v)+k+1]; |
925 | } |
926 | static void vector_set(value v, value k, value obj) { |
927 | assert(k < vector_len(v)); |
928 | heap[untag(v)+k+1] = obj; |
929 | } |
930 | |
931 | /* Builtin procedures */ |
932 | |
933 | static value builtin(const char *name, builtin_func_t func) { |
934 | value b = sc_malloc(3); |
935 | heap[b] = ext_add_tag(0, T_BUILTIN); |
936 | heap[b+1] = (value)name; |
937 | heap[b+2] = (value)func; |
938 | return add_tag(b, T_EXTENDED); |
939 | } |
940 | static int is_builtin(value v) { return is_ext_type(v, T_BUILTIN); } |
941 | static const char * builtin_name(value b) { |
942 | return (char *)heap[untag(b)+1]; |
943 | } |
944 | static builtin_func_t builtin_func(value b) { |
945 | return (builtin_func_t)heap[untag(b)+2]; |
946 | } |
947 | |
948 | /* Compound procedures */ |
949 | |
950 | /* Return a new procedure object from lambda expression operands in R_OPERANDS |
951 | * and environment in R_ENV. |
952 | * Side effects: R_OPERANDS R_CAR R_CDR */ |
953 | static value procedure(void) { |
954 | value p, arity; |
955 | arity = car(R_OPERANDS); |
956 | if (is_fixnum(arity)) { |
957 | /* Compiler annotated parameter list attributes to save a traversal */ |
958 | R_OPERANDS = cdr(R_OPERANDS); |
959 | } |
960 | else { |
961 | /* ...this traversal (still needed for bootstrapping), which in turn |
962 | * saves traversing each time the procedure is applied */ |
963 | p = arity; /* parameter list */ |
964 | arity = 0; |
965 | for (; is_pair(p); p = cdr(p)) arity++; |
966 | if (p == SC_NULL) arity = fixnum(arity); |
967 | else { |
968 | /* improper (variadic) */ |
969 | assert(is_symbol(p)); |
970 | arity = (value)(-1L - (long)arity); |
971 | } |
972 | } |
973 | p = sc_malloc(4); |
974 | heap[p] = ext_add_tag(ext_untag(arity), T_PROCEDURE); |
975 | heap[p+1] = car(R_OPERANDS); /* parameter list */ |
976 | heap[p+2] = cdr(R_OPERANDS); /* body */ |
977 | heap[p+3] = R_ENV; |
978 | return add_tag(p, T_EXTENDED); |
979 | } |
980 | static int is_compound_proc(value v) { return is_ext_type(v, T_PROCEDURE); } |
981 | static long proc_arity(value p) { return ext_untag_signed(heap[untag(p)]); } |
982 | static value proc_params(value p) { return heap[untag(p)+1]; } |
983 | static value proc_body(value p) { return heap[untag(p)+2]; } |
984 | static value proc_env(value p) { return heap[untag(p)+3]; } |
985 | |
986 | /* Continuations */ |
987 | |
988 | static value current_continuation(void) { |
989 | value cont = sc_malloc(3); |
990 | heap[cont] = ext_add_tag(0, T_CONTINUATION); |
991 | heap[cont+1] = r_stack; |
992 | heap[cont+2] = r_spool; |
993 | return add_tag(cont, T_EXTENDED); |
994 | } |
995 | static int is_continuation(value v) { return is_ext_type(v, T_CONTINUATION); } |
996 | static value continuation_stack(value c) { return heap[untag(c)+1]; } |
997 | static value continuation_spool(value c) { return heap[untag(c)+2]; } |
998 | |
999 | static int is_procedure(value v) { |
1000 | return is_builtin(v) || is_compound_proc(v) || is_continuation(v); |
1001 | } |
1002 | |
1003 | /* Promises */ |
1004 | |
1005 | /* Construct a promise from an expression in R_EXPR and environment in R_ENV */ |
1006 | static value promise(void) { |
1007 | value p = sc_malloc(3); |
1008 | heap[p] = ext_add_tag(0, T_PROMISE); |
1009 | heap[p+1] = R_EXPR; |
1010 | heap[p+2] = R_ENV; |
1011 | return add_tag(p, T_EXTENDED); |
1012 | } |
1013 | static int is_promise(value v) { return is_ext_type(v, T_PROMISE); } |
1014 | static int promise_done(value p) { return heap[untag(p)] & 1; } |
1015 | static value promise_value(value p) { return heap[untag(p)+1]; } |
1016 | static value promise_env(value p) { return heap[untag(p)+2]; } |
1017 | static void promise_memoize(value p, value v) { |
1018 | value ptr = untag(p); |
1019 | heap[ptr] = ext_add_tag(1, T_PROMISE); |
1020 | heap[ptr+1] = v; |
1021 | heap[ptr+2] = SC_NULL; /* release to GC */ |
1022 | } |
1023 | |
1024 | /* Ports */ |
1025 | |
1026 | static value stdin_port, stdout_port; |
1027 | |
1028 | #define DEFAULT_R_BUF 4096 |
1029 | #define DEFAULT_W_BUF 4096 |
1030 | |
1031 | /* Flags in header */ |
1032 | #define PORT_OUTPUT_BIT 1 |
1033 | #define PORT_SOCKET_BIT 2 |
1034 | #define PORT_EOF_BIT 4 |
1035 | |
1036 | /* Fields */ |
1037 | #define PORT_FD 1 |
1038 | #define PORT_START 2 |
1039 | #define PORT_FILL 3 |
1040 | #define PORT_BUF 4 |
1041 | #define PORT_COUNTERPART 5 |
1042 | |
1043 | /* Construct unidirectional port. Side effects: R_RESULT */ |
1044 | static value make_port(int fd, int is_output, long buf_size) { |
1045 | value port, *p; |
1046 | if (buf_size < 1) sc_error("buffer size must be at least one"); |
1047 | R_RESULT = make_string_uninit(buf_size); |
1048 | port = sc_malloc(6); |
1049 | p = heap+port; |
1050 | p[0] = ext_add_tag(is_output ? PORT_OUTPUT_BIT : 0, T_PORT); |
1051 | p[PORT_FD] = fixnum(fd); |
1052 | p[PORT_START] = fixnum(0); |
1053 | p[PORT_FILL] = fixnum(0); |
1054 | p[PORT_BUF] = R_RESULT; |
1055 | p[PORT_COUNTERPART] = SC_NULL; |
1056 | return add_tag(port, T_EXTENDED); |
1057 | } |
1058 | /* Construct input port in r0 and output port in r1 from socket file |
1059 | * descriptor. Side effects: R_RESULT */ |
1060 | static void make_socket_ports(int fd, value rbuf_size, value wbuf_size) { |
1061 | value *p; |
1062 | chkp(fcntl(fd, F_SETFL, O_NONBLOCK)); |
1063 | r0 = make_port(fd, 0, rbuf_size); |
1064 | r1 = make_port(fd, 1, wbuf_size); |
1065 | /* Cross-reference the two directions so the underlying FD can be closed |
1066 | * promptly when both ports are. */ |
1067 | p = heap+untag(r0); |
1068 | p[0] |= PORT_SOCKET_BIT; |
1069 | p[PORT_COUNTERPART] = r1; |
1070 | p = heap+untag(r1); |
1071 | p[0] |= PORT_SOCKET_BIT; |
1072 | p[PORT_COUNTERPART] = r0; |
1073 | } |
1074 | |
1075 | static int is_port(value v) { return is_ext_type(v, T_PORT); } |
1076 | static int is_input_port(value v) { |
1077 | value header; |
1078 | if (tag(v) != T_EXTENDED) return 0; |
1079 | header = heap[untag(v)]; |
1080 | return ext_tag(header) == T_PORT && (header & PORT_OUTPUT_BIT) == 0; |
1081 | } |
1082 | static int is_output_port(value v) { |
1083 | value header; |
1084 | if (tag(v) != T_EXTENDED) return 0; |
1085 | header = heap[untag(v)]; |
1086 | return ext_tag(header) == T_PORT && (header & PORT_OUTPUT_BIT) != 0; |
1087 | } |
1088 | |
1089 | static int set_port_closed(value *p) { |
1090 | int fd = fixnum_val(p[PORT_FD]); |
1091 | /* Set an invalid FD so writes to a closed port are caught by the kernel |
1092 | * with no extra cost in the normal case. Disable buffering so they're |
1093 | * caught immediately. */ |
1094 | p[PORT_FD] = fixnum(-1); |
1095 | p[PORT_START] = p[PORT_FILL] = fixnum(0); |
1096 | string_truncate(p[PORT_BUF], 1); |
1097 | if (p[PORT_COUNTERPART] == SC_NULL) return close(fd); |
1098 | heap[untag(p[PORT_COUNTERPART])+PORT_COUNTERPART] = SC_NULL; |
1099 | p[PORT_COUNTERPART] = SC_NULL; |
1100 | return 0; |
1101 | } |
1102 | static ssize_t fill_input_port(value *p, int nonblock) { |
1103 | int fd = fixnum_val(p[PORT_FD]); |
1104 | uchar *buf = string_buf(p[PORT_BUF]); |
1105 | value len = string_len(p[PORT_BUF]); |
1106 | ssize_t n; |
1107 | while ((n = read(fd, buf, len)) < 0) { |
1108 | if (errno == EINTR) continue; |
1109 | if (errno == EAGAIN || errno == EWOULDBLOCK) { |
1110 | if (nonblock) return -1; |
1111 | poll1(fd, POLLIN, -1); continue; |
1112 | } |
1113 | if (fd == -1) sc_error("input port closed"); |
1114 | sc_perror(); |
1115 | } |
1116 | p[PORT_START] = fixnum(0); |
1117 | p[PORT_FILL] = fixnum(n); |
1118 | return n; |
1119 | } |
1120 | static void flush_output_port(value *p) { |
1121 | int fd = fixnum_val(p[PORT_FD]); |
1122 | long fill = fixnum_val(p[PORT_FILL]); |
1123 | assert(fill > 0); /* zero-length write unspecified on non-regular files */ |
1124 | assert((ulong)fill <= string_len(p[PORT_BUF])); |
1125 | p[PORT_FILL] = fixnum(0); |
1126 | if (write_all(fd, c_string_buf(p[PORT_BUF]), fill) == -1) { |
1127 | int saved; |
1128 | if (fd == -1) sc_error("output port closed"); |
1129 | /* Probably no sensible way to recover from write errors, so force the |
1130 | * port closed. XXX Closing standard streams is a concern (i.e. a |
1131 | * subsequent open gets FD 1 or 2 and terminal output goes to the file |
1132 | * unexpectedly), except: 1) the interpreter writes to stdout through |
1133 | * the port object only; 2) the open-subprocess extension always pipes |
1134 | * the child's stdout; 3) there's no port for stderr. But these are |
1135 | * fragile assumptions. */ |
1136 | saved = errno; set_port_closed(p); errno = saved; |
1137 | sc_perror(); |
1138 | } |
1139 | } |
1140 | |
1141 | static void flush_if_needed(value port) { |
1142 | value *p = heap+untag(port); |
1143 | if (fixnum_val(p[PORT_FILL]) > 0) flush_output_port(p); |
1144 | } |
1145 | static void close_port(value port) { |
1146 | value *p = heap+untag(port), header = p[0]; |
1147 | int fd = fixnum_val(p[PORT_FD]); |
1148 | if (fd == -1) return; |
1149 | if (header & PORT_OUTPUT_BIT) flush_if_needed(port); |
1150 | if (header & PORT_SOCKET_BIT) |
1151 | shutdown(fd, header & PORT_OUTPUT_BIT ? SHUT_WR : SHUT_RD); |
1152 | chkp(set_port_closed(p)); |
1153 | } |
1154 | static value read_char(value port) { |
1155 | value *p = heap+untag(port), start = p[PORT_START]; |
1156 | uchar *buf = string_buf(p[PORT_BUF]); |
1157 | if (start == p[PORT_FILL]) { |
1158 | if (p[0] & PORT_EOF_BIT) { p[0] ^= PORT_EOF_BIT; return SC_EOF; } |
1159 | if (!fill_input_port(p, 0)) return SC_EOF; |
1160 | start = 0; |
1161 | } |
1162 | else start = untag(start); |
1163 | p[PORT_START] = fixnum(start+1); |
1164 | return character(buf[start]); |
1165 | } |
1166 | static value peek_char(value port) { |
1167 | value *p = heap+untag(port), start = p[PORT_START]; |
1168 | uchar *buf = string_buf(p[PORT_BUF]); |
1169 | if (start == p[PORT_FILL]) { |
1170 | /* EOF is not always permanent, e.g. on a tty, so the condition must be |
1171 | * saved specially for the next peek or read. */ |
1172 | if (p[0] & PORT_EOF_BIT) return SC_EOF; |
1173 | if (!fill_input_port(p, 0)) { p[0] |= PORT_EOF_BIT; return SC_EOF; } |
1174 | start = 0; |
1175 | } |
1176 | else start = untag(start); |
1177 | return character(buf[start]); |
1178 | } |
1179 | static value input_port_ready(value port) { |
1180 | value *p; |
1181 | int fd; |
1182 | p = heap+untag(port); |
1183 | fd = fixnum_val(p[PORT_FD]); |
1184 | if (p[PORT_START] < p[PORT_FILL]) return SC_TRUE; |
1185 | if (fd == -1) sc_error("input port closed"); |
1186 | if (!poll1(fd, POLLIN, 0)) return SC_FALSE; |
1187 | /* XXX Linux poll/select are broken and have false positives for |
1188 | * readability, at least for sockets, so we try a nonblocking read. But |
1189 | * this doesn't work for regular files! Seems marginally better to break |
1190 | * "the next READ-CHAR operation on the given PORT is guaranteed not to |
1191 | * hang" than have CHAR-READY? itself hang. Alternately, djb's SIGALARM |
1192 | * hack could be used. */ |
1193 | if (p[0] & PORT_SOCKET_BIT && fill_input_port(p, 1) == -1) return SC_FALSE; |
1194 | return SC_TRUE; |
1195 | } |
1196 | /* Barbarous relic from writing the lexer based on stdio/ungetc */ |
1197 | #define EOF (-1) |
1198 | static void put_back_char(int c) { |
1199 | value *p; |
1200 | assert(is_port(R_PORT)); |
1201 | p = heap+untag(R_PORT); |
1202 | if (c == EOF) p[0] |= PORT_EOF_BIT; |
1203 | else { |
1204 | value start = untag(p[PORT_START]); |
1205 | assert(start); |
1206 | --start; |
1207 | string_buf(p[PORT_BUF])[start] = c; |
1208 | p[PORT_START] = fixnum(start); |
1209 | } |
1210 | } |
1211 | static void write_char(uchar c) { |
1212 | value *p, fill, len; |
1213 | uchar *buf; |
1214 | assert(is_port(R_PORT)); |
1215 | p = heap+untag(R_PORT); |
1216 | fill = untag(p[PORT_FILL]); |
1217 | len = string_len(p[PORT_BUF]); |
1218 | assert(fill < len); |
1219 | buf = string_buf(p[PORT_BUF]); |
1220 | buf[fill] = c; |
1221 | ++fill; |
1222 | p[PORT_FILL] = fixnum(fill); |
1223 | if (fill == len) flush_output_port(p); |
1224 | } |
1225 | |
1226 | static int stdout_ready; |
1227 | static void flush_all(void) { |
1228 | /* TODO */ |
1229 | if (stdout_ready) flush_if_needed(stdout_port); |
1230 | } |
1231 | |
1232 | static void write_cstr(const char *s) { for (; *s; ++s) write_char(*s); } |
1233 | static void write_str(value s) { /* also for symbols */ |
1234 | value len = string_len(s); |
1235 | uchar *buf = string_buf(s); |
1236 | assert(is_string(s) || is_symbol(s)); |
1237 | for (; len; --len, ++buf) write_char(*buf); |
1238 | } |
1239 | static void write_str_quoted(value s) { |
1240 | value i, len = string_len(s); |
1241 | uchar *buf = string_buf(s); |
1242 | write_char('"'); |
1243 | for (i = 0; i < len; i++) { |
1244 | uchar c = buf[i]; |
1245 | if (c == '"' || c == '\\') write_char('\\'); |
1246 | write_char(c); |
1247 | } |
1248 | write_char('"'); |
1249 | } |
1250 | static void newline(void) { write_char('\n'); } |
1251 | |
1252 | /* Environments |
1253 | * |
1254 | * An environment is a list of lexical frames followed by global frames. |
1255 | * |
1256 | * A lexical frame is a vector of which the first element is the list of |
1257 | * symbols naming the variables (possibly improper, as in a lambda expression), |
1258 | * and the remaining elements are the corresponding values. |
1259 | * |
1260 | * A global frame is a list of (symbol . value) binding pairs. */ |
1261 | |
1262 | static value r5rs_env, gscm_env, interaction_env, toplevel_env; |
1263 | |
1264 | static void check_mutable_env(value env, value name) { |
1265 | if (env != interaction_env) { |
1266 | assert(env == r5rs_env || env == gscm_env || env == toplevel_env); |
1267 | sc_error1("variable in immutable environment:", name); |
1268 | } |
1269 | } |
1270 | |
1271 | /* Construct a new lexical frame for the application of the procedure in R_PROC |
1272 | * to the freshly allocated argument list in R_ARGS (no other side effects) */ |
1273 | static value make_lex_frame(void) { |
1274 | value k, frame, args, arity, fixed_arity; |
1275 | long encoded_arity = proc_arity(R_PROC); |
1276 | if (encoded_arity < 0) { |
1277 | arity = (value)(-encoded_arity); |
1278 | fixed_arity = arity - 1; |
1279 | } |
1280 | else { |
1281 | arity = (value)encoded_arity; |
1282 | fixed_arity = arity; |
1283 | } |
1284 | frame = make_vector_uninit(1 + arity); |
1285 | vector_set(frame, 0, proc_params(R_PROC)); |
1286 | args = R_ARGS; |
1287 | for (k = 1; k <= fixed_arity; k++) { |
1288 | if (args == SC_NULL) sc_error("too few arguments"); |
1289 | vector_set(frame, k, car(args)); |
1290 | args = cdr(args); |
1291 | } |
1292 | if (fixed_arity < arity) vector_set(frame, k, args); |
1293 | else if (args != SC_NULL) sc_error("too many arguments"); |
1294 | return frame; |
1295 | } |
1296 | |
1297 | /* Construct a new lexical frame for a LETREC binding list in r2, that is, bind |
1298 | * the given names to not-yet-defined values. The name list is constructed in |
1299 | * reverse order. |
1300 | * Side effects: r2 R_CAR R_CDR */ |
1301 | static value make_letrec_frame(void) { |
1302 | /* TODO optimize: transpose the binding list? */ |
1303 | value k, len, frame; |
1304 | R_CDR = SC_NULL; |
1305 | len = 1; |
1306 | for (; r2 != SC_NULL; r2 = cdr(r2)) { |
1307 | len++; |
1308 | R_CAR = car(car(r2)); |
1309 | R_CDR = cons(); |
1310 | } |
1311 | frame = make_vector_uninit(len); |
1312 | vector_set(frame, 0, R_CDR); |
1313 | for (k = 1; k < len; k++) |
1314 | vector_set(frame, k, UNDEFINED); |
1315 | return frame; |
1316 | } |
1317 | |
1318 | /* Add a new binding for R_CAR to R_CDR to the topmost frame of global R_ENV. |
1319 | * Side effects: R_CAR R_CDR */ |
1320 | static void extend_global_env(void) { |
1321 | R_CAR = cons(); /* new binding */ |
1322 | R_CDR = car(R_ENV); /* top frame */ |
1323 | assert(is_pair(R_CDR) || R_CDR == SC_NULL); |
1324 | R_CDR = cons(); |
1325 | set_car(R_ENV, R_CDR); |
1326 | } |
1327 | |
1328 | /* Construct a new global frame containing copies of the bindings in the frame |
1329 | * in R_EXPR. Side effects: R_CAR R_CDR R_EXPR R_TAIL R_RESULT */ |
1330 | static value copy_global_frame(void) { |
1331 | value temp; |
1332 | R_CAR = R_CDR = SC_NULL; |
1333 | R_TAIL = R_RESULT = cons(); |
1334 | for (; R_EXPR != SC_NULL; R_EXPR = cdr(R_EXPR)) { |
1335 | temp = car(R_EXPR); |
1336 | R_CAR = car(temp); R_CDR = cdr(temp); |
1337 | R_CAR = cons(); /* copied binding */ |
1338 | R_CDR = SC_NULL; |
1339 | temp = cons(); |
1340 | set_cdr(R_TAIL, temp); |
1341 | R_TAIL = temp; |
1342 | } |
1343 | return cdr(R_RESULT); |
1344 | } |
1345 | |
1346 | static value global_frame_lookup(value name, value frame) { |
1347 | value binding; |
1348 | for (; frame != SC_NULL; frame = cdr(frame)) { |
1349 | binding = car(frame); |
1350 | if (car(binding) == name) return binding; |
1351 | } |
1352 | return SC_FALSE; |
1353 | } |
1354 | |
1355 | static value lex_frame_lookup(value name, value frame) { |
1356 | value names, index; |
1357 | index = 1; |
1358 | for (names = vector_ref(frame, 0); is_pair(names); names = cdr(names)) { |
1359 | if (car(names) == name) goto found; |
1360 | index++; |
1361 | } |
1362 | if (names != name) return 0; |
1363 | found: |
1364 | if (vector_ref(frame, 1) == UNDEFINED) /* see LETREC */ |
1365 | sc_error1("undefined variable:", name); |
1366 | return index; |
1367 | } |
1368 | |
1369 | static value env_lookup(value name, value env) { |
1370 | value frame, binding, index; |
1371 | assert(is_symbol(name)); |
1372 | for (; env != SC_NULL; env = cdr(env)) { |
1373 | frame = car(env); |
1374 | if (is_vector(frame)) { |
1375 | index = lex_frame_lookup(name, frame); |
1376 | if (index) return vector_ref(frame, index); |
1377 | } |
1378 | else { |
1379 | binding = global_frame_lookup(name, frame); |
1380 | if (binding != SC_FALSE) return cdr(binding); |
1381 | } |
1382 | } |
1383 | sc_error1("unbound variable:", name); |
1384 | } |
1385 | |
1386 | static void env_lookup_set(value name, value env, value new) { |
1387 | value frame, binding, index; |
1388 | assert(is_symbol(name)); |
1389 | for (; env != SC_NULL; env = cdr(env)) { |
1390 | frame = car(env); |
1391 | if (is_vector(frame)) { |
1392 | index = lex_frame_lookup(name, frame); |
1393 | if (index) { |
1394 | vector_set(frame, index, new); |
1395 | return; |
1396 | } |
1397 | } |
1398 | else { |
1399 | binding = global_frame_lookup(name, frame); |
1400 | if (binding != SC_FALSE) { |
1401 | check_mutable_env(env, name); |
1402 | set_cdr(binding, new); |
1403 | return; |
1404 | } |
1405 | } |
1406 | } |
1407 | sc_error1("unbound variable:", name); |
1408 | } |
1409 | |
1410 | /* Variable references: created by compiler to memoize environment lookups */ |
1411 | |
1412 | static int is_variable_ref(value v) { return is_ext_type(v, T_VARIABLE_REF); } |
1413 | |
1414 | /* Return an unresolved variable reference for a symbol in R_CAR */ |
1415 | static value make_variable_ref() { |
1416 | assert(is_symbol(R_CAR)); |
1417 | value ref = sc_malloc(2); |
1418 | heap[ref] = ext_add_tag(0, T_VARIABLE_REF); |
1419 | heap[ref+1] = R_CAR; |
1420 | return add_tag(ref, T_EXTENDED); |
1421 | } |
1422 | |
1423 | /* Look up an unresolved variable reference and memoize */ |
1424 | static void resolve_variable_ref(value ref, value env, int mutable) { |
1425 | value ptr, name, frame, height, binding, index; |
1426 | ptr = untag(ref); |
1427 | name = heap[ptr+1]; |
1428 | assert(is_symbol(name)); |
1429 | height = 0; |
1430 | for (; env != SC_NULL; env = cdr(env)) { |
1431 | frame = car(env); |
1432 | if (is_vector(frame)) { |
1433 | index = lex_frame_lookup(name, frame); |
1434 | if (index) { |
1435 | if (height > FIXNUM_MAX) |
1436 | /* maybe possible on small architectures */ |
1437 | sc_error("environment too deep"); |
1438 | heap[ptr] = ext_add_tag(index, T_VARIABLE_REF); |
1439 | heap[ptr+1] = add_tag(height, T_FIXNUM); |
1440 | return; |
1441 | } |
1442 | } |
1443 | else { |
1444 | binding = global_frame_lookup(name, frame); |
1445 | if (binding != SC_FALSE) { |
1446 | if (mutable) check_mutable_env(env, name); |
1447 | heap[ptr+1] = binding; |
1448 | return; |
1449 | } |
1450 | } |
1451 | height++; |
1452 | } |
1453 | sc_error1("unbound variable:", name); |
1454 | } |
1455 | |
1456 | static value variable_ref_get(value ref, value env) { |
1457 | value ptr, contents, height; |
1458 | ptr = untag(ref); |
1459 | retry: |
1460 | contents = heap[ptr+1]; |
1461 | if (is_pair(contents)) /* global */ |
1462 | return cdr(contents); |
1463 | else if (is_fixnum(contents)) { /* lexical */ |
1464 | for (height = fixnum_val(contents); height; height--) |
1465 | env = cdr(env); |
1466 | return vector_ref(car(env), ext_untag(heap[ptr])); |
1467 | } |
1468 | else { /* unresolved */ |
1469 | resolve_variable_ref(ref, env, 0); |
1470 | goto retry; |
1471 | } |
1472 | } |
1473 | |
1474 | static void variable_ref_set(value ref, value env, value new) { |
1475 | value ptr, contents, height; |
1476 | ptr = untag(ref); |
1477 | retry: |
1478 | contents = heap[ptr+1]; |
1479 | if (is_pair(contents)) /* global */ |
1480 | set_cdr(contents, new); |
1481 | else if (is_fixnum(contents)) { /* lexical */ |
1482 | for (height = fixnum_val(contents); height; height--) |
1483 | env = cdr(env); |
1484 | vector_set(car(env), ext_untag(heap[ptr]), new); |
1485 | } |
1486 | else { /* unresolved */ |
1487 | resolve_variable_ref(ref, env, 1); |
1488 | goto retry; |
1489 | } |
1490 | } |
1491 | |
1492 | |
1493 | /*********** |
1494 | * Debugging |
1495 | */ |
1496 | |
1497 | static void shallow_print(void); |
1498 | |
1499 | void sc_dump(value v) { |
1500 | r_dump = v; |
1501 | PUSH(R_CAR); |
1502 | PUSH(R_EXPR); |
1503 | PUSH(R_PORT); |
1504 | R_EXPR = r_dump; |
1505 | R_PORT = stdout_port; |
1506 | shallow_print(); |
1507 | newline(); |
1508 | R_PORT = pop(); |
1509 | R_EXPR = pop(); |
1510 | R_CAR = pop(); |
1511 | r_dump = SC_NULL; |
1512 | } |
1513 | |
1514 | |
1515 | /**************** |
1516 | * Core evaluator |
1517 | * |
1518 | * The evaluator is a set of subroutines delimited by labels, with "switch" |
1519 | * cases serving as pushable return addresses. (Caution is needed in case of |
1520 | * nested switches or "break".) Properly tail recursive calls are where "goto" |
1521 | * is used rather than CALL, that is, a new return address is not pushed. |
1522 | * Nothing else may be left on the subroutine's stack frame in these cases! |
1523 | */ |
1524 | |
1525 | /* Shorthand for non-tail subroutine calls. Beware of the register side effects |
1526 | * or confusing RETURN with C return. */ |
1527 | #define CALL(subroutine_label, return_address) \ |
1528 | { R_CAR = return_address; push(); goto subroutine_label; } |
1529 | #define RETURN(val) { R_RESULT = (val); goto dispatch; } |
1530 | |
1531 | /* Return addresses */ |
1532 | #define EV_DONE 0 |
1533 | #define EV_COMPILE_RESULT 1 |
1534 | #define EV_CALL_OPERATOR 2 |
1535 | #define EV_CALL_LOOP 3 |
1536 | #define EV_UNWIND_LOOP 4 |
1537 | #define EV_REWIND_LOOP 5 |
1538 | #define EV_SEQ_LOOP 6 |
1539 | #define EV_IF_PREDICATE 7 |
1540 | #define EV_SET_RESULT 8 |
1541 | #define EV_LETREC_LOOP 9 |
1542 | #define EV_DEFINE_RESULT 10 |
1543 | #define EV_FORCE_RESULT 11 |
1544 | #define EV_CALL_WITH_VALUES 12 |
1545 | |
1546 | static const char *err_context; |
1547 | static jmp_buf err_longjmp_env; |
1548 | |
1549 | /* Takes expression in R_EXPR and environment in R_ENV */ |
1550 | static void evaluator(void) { |
1551 | value k; |
1552 | if (setjmp(err_longjmp_env)) goto APPLY; |
1553 | if (r_compiler) CALL(COMPILE, EV_DONE); |
1554 | CALL(EVAL, EV_DONE); |
1555 | dispatch: |
1556 | switch (pop()) { |
1557 | case EV_DONE: |
1558 | assert(r_stack == SC_NULL); |
1559 | r_error_cont = SC_NULL; |
1560 | break; |
1561 | |
1562 | COMPILE: |
1563 | /* Compile expression R_EXPR then evaluate in environment R_ENV */ |
1564 | PUSH(R_ENV); |
1565 | R_CAR = R_EXPR; |
1566 | R_CDR = SC_NULL; |
1567 | R_ARGS = cons(); |
1568 | R_PROC = r_compiler; |
1569 | CALL(APPLY, EV_COMPILE_RESULT); |
1570 | case EV_COMPILE_RESULT: |
1571 | R_EXPR = R_RESULT; |
1572 | R_ENV = pop(); |
1573 | goto EVAL; |
1574 | |
1575 | EVAL: |
1576 | /* Evaluate expression R_EXPR in environment R_ENV */ |
1577 | err_context = "eval"; |
1578 | if (is_pair(R_EXPR)) { /* Combination */ |
1579 | R_OPERANDS = cdr(R_EXPR); |
1580 | R_EXPR = car(R_EXPR); |
1581 | if (is_symbol(R_EXPR)) { |
1582 | if (R_EXPR == s_lambda) RETURN(procedure()); |
1583 | if (R_EXPR == s_if) goto IF; |
1584 | if (R_EXPR == s_set) goto SET; |
1585 | if (R_EXPR == s_begin) goto EVAL_BODY; |
1586 | if (R_EXPR == s_letrec) goto LETREC; |
1587 | if (R_EXPR == s_quote) RETURN(car(R_OPERANDS)); |
1588 | if (R_EXPR == s_define) goto DEFINE; |
1589 | if (R_EXPR == s_delay) goto DELAY; |
1590 | } |
1591 | goto EVAL_CALL; |
1592 | } |
1593 | if (is_variable_ref(R_EXPR)) /* Cacheable variable reference */ |
1594 | RETURN(variable_ref_get(R_EXPR, R_ENV)); |
1595 | if (is_symbol(R_EXPR)) |
1596 | /* Slow and stupid variable lookup: replacing symbols in the |
1597 | * expression tree with variable references is done by the |
1598 | * compiler, so this is needed to bootstrap */ |
1599 | RETURN(env_lookup(R_EXPR, R_ENV)); |
1600 | assert(is_number(R_EXPR) || |
1601 | is_boolean(R_EXPR) || |
1602 | is_character(R_EXPR) || |
1603 | is_string(R_EXPR) || |
1604 | /* not valid Scheme, but allowed in compiler output */ |
1605 | R_EXPR == SC_NULL || |
1606 | is_vector(R_EXPR)); |
1607 | RETURN(R_EXPR); /* Self-evaluating */ |
1608 | |
1609 | EVAL_CALL: |
1610 | /* Procedure call (operator operand ...) |
1611 | * Evaluate operator in R_EXPR and each operand in R_OPERANDS, build |
1612 | * argument list and apply in R_ENV. */ |
1613 | PUSH(R_OPERANDS); |
1614 | PUSH(R_ENV); |
1615 | CALL(EVAL, EV_CALL_OPERATOR); |
1616 | case EV_CALL_OPERATOR: |
1617 | R_ENV = pop(); |
1618 | R_CAR = R_RESULT; |
1619 | R_OPERANDS = pop(); |
1620 | push(); /* evaluated operator */ |
1621 | R_CAR = R_CDR = SC_NULL; |
1622 | R_TAIL = cons(); /* arg list tail pointer */ |
1623 | PUSH(R_TAIL); /* arg list head pointer */ |
1624 | PUSH(R_ENV); |
1625 | for (; R_OPERANDS != SC_NULL; R_OPERANDS = cdr(R_OPERANDS)) { |
1626 | PUSH(R_OPERANDS); |
1627 | PUSH(R_TAIL); |
1628 | R_EXPR = car(R_OPERANDS); |
1629 | CALL(EVAL, EV_CALL_LOOP); |
1630 | case EV_CALL_LOOP: |
1631 | R_CAR = R_RESULT; |
1632 | R_TAIL = pop(); |
1633 | R_OPERANDS = pop(); |
1634 | R_ENV = peek(); |
1635 | R_CDR = SC_NULL; |
1636 | R_CDR = cons(); |
1637 | set_cdr(R_TAIL, R_CDR); |
1638 | R_TAIL = R_CDR; |
1639 | } |
1640 | drop(); /* environment */ |
1641 | R_ARGS = cdr(pop()); /* arg list head pointer */ |
1642 | R_PROC = pop(); /* evaluated operator */ |
1643 | goto APPLY; |
1644 | |
1645 | APPLY: |
1646 | /* Extend the lexical environment of procedure R_PROC by binding its |
1647 | * formal parameters to arguments in the freshly allocated list R_ARGS, |
1648 | * then evaluate its body in the new environment. */ |
1649 | if (is_builtin(R_PROC)) { |
1650 | err_context = builtin_name(R_PROC); |
1651 | r_flag = f_none; |
1652 | R_RESULT = (builtin_func(R_PROC))(R_ARGS); |
1653 | /* Builtins cannot call back into the evaluator as that would break |
1654 | * tail recursion and enable unlimited recursion on the C stack. |
1655 | * Instead they can set a flag to signal a tail call to a given |
1656 | * subroutine. */ |
1657 | switch (r_flag) { |
1658 | case f_none: RETURN(R_RESULT); |
1659 | case f_compile: goto COMPILE; |
1660 | case f_apply: goto APPLY; |
1661 | case f_force: goto FORCE; |
1662 | case f_call_with_values: goto CALL_WITH_VALUES; |
1663 | /* optimization, see RETURN_VALUES */ |
1664 | case f_values: goto VALUES; |
1665 | } |
1666 | } |
1667 | err_context = "apply"; |
1668 | if (is_compound_proc(R_PROC)) { |
1669 | R_OPERANDS = proc_body(R_PROC); |
1670 | R_CAR = make_lex_frame(); |
1671 | R_CDR = proc_env(R_PROC); |
1672 | R_ENV = cons(); |
1673 | goto EVAL_BODY; |
1674 | } |
1675 | if (is_continuation(R_PROC)) goto APPLY_CONTINUATION; |
1676 | sc_error1("not a procedure:", R_PROC); |
1677 | |
1678 | APPLY_CONTINUATION: |
1679 | /* Return the value(s) R_ARGS to the continuation R_PROC, restoring its |
1680 | * stack and applying any thunks registered to exit the current dynamic |
1681 | * extent and re-enter the captured one. */ |
1682 | R_WIND_TO = continuation_spool(R_PROC); |
1683 | if (r_spool != R_WIND_TO) { |
1684 | R_LCA = lowest_common_ancestor(r_spool, R_WIND_TO); |
1685 | r_stack = SC_NULL; |
1686 | PUSH(R_ARGS); |
1687 | PUSH(R_PROC); |
1688 | /* Unwind: apply "after" thunks from the current extent up to (but |
1689 | * not including) the narrowest common extent */ |
1690 | while (r_spool != R_LCA) { |
1691 | assert(r_spool != SC_NULL); |
1692 | /* XXX ^ possible to violate if thunk escapes? */ |
1693 | R_PROC = cdr(car(r_spool)); |
1694 | r_spool = cdr(r_spool); |
1695 | R_ARGS = SC_NULL; |
1696 | PUSH(R_LCA); |
1697 | CALL(APPLY, EV_UNWIND_LOOP); |
1698 | case EV_UNWIND_LOOP: |
1699 | R_LCA = pop(); |
1700 | } |
1701 | /* Rewind: apply "before" thunks down to the captured extent |
1702 | * starting below the common extent */ |
1703 | R_WIND_TO = continuation_spool(peek()); |
1704 | for (r_spool = R_WIND_TO; r_spool != R_LCA; r_spool = cdr(r_spool)) |
1705 | PUSH(r_spool); |
1706 | while (r_spool != R_WIND_TO) { |
1707 | R_PROC = car(car(peek())); |
1708 | R_ARGS = SC_NULL; |
1709 | PUSH(R_WIND_TO); |
1710 | CALL(APPLY, EV_REWIND_LOOP); |
1711 | case EV_REWIND_LOOP: |
1712 | R_WIND_TO = pop(); |
1713 | r_spool = pop(); |
1714 | } |
1715 | R_PROC = pop(); |
1716 | R_ARGS = pop(); |
1717 | assert(r_stack == SC_NULL); |
1718 | } |
1719 | r_stack = continuation_stack(R_PROC); |
1720 | VALUES: |
1721 | if (peek() == EV_CALL_WITH_VALUES) { |
1722 | drop(); |
1723 | goto CALL_WITH_VALUES_CONT; |
1724 | } |
1725 | if (R_ARGS == SC_NULL) sc_error("no value for ordinary continuation"); |
1726 | if (cdr(R_ARGS) != SC_NULL) |
1727 | sc_error1("multiple values for ordinary continuation:", R_ARGS); |
1728 | RETURN(car(R_ARGS)); |
1729 | |
1730 | EVAL_BODY: |
1731 | /* Evaluate one or more commands/expressions. (No definitions; we don't |
1732 | * need to distinguish sequence from body, as internal definitions are |
1733 | * converted to letrec by the compiler.) |
1734 | * Paramters: R_OPERANDS R_ENV */ |
1735 | PUSH(R_ENV); |
1736 | assert(R_OPERANDS != SC_NULL); |
1737 | for (; cdr(R_OPERANDS) != SC_NULL; R_OPERANDS = cdr(R_OPERANDS)) { |
1738 | R_EXPR = car(R_OPERANDS); |
1739 | PUSH(R_OPERANDS); |
1740 | CALL(EVAL, EV_SEQ_LOOP); |
1741 | case EV_SEQ_LOOP: |
1742 | R_OPERANDS = pop(); |
1743 | R_ENV = peek(); |
1744 | } |
1745 | drop(); /* environment */ |
1746 | R_EXPR = car(R_OPERANDS); |
1747 | goto EVAL; |
1748 | |
1749 | IF: |
1750 | /* (if predicate consequent [alternate]) |
1751 | * Parameters: R_OPERANDS R_ENV */ |
1752 | R_EXPR = car(R_OPERANDS); /* predicate */ |
1753 | R_OPERANDS = cdr(R_OPERANDS); |
1754 | R_CAR = car(R_OPERANDS); /* consequent */ |
1755 | R_OPERANDS = cdr(R_OPERANDS); |
1756 | push(); /* consequent */ |
1757 | PUSH(R_OPERANDS); /* (alternate) */ |
1758 | PUSH(R_ENV); |
1759 | CALL(EVAL, EV_IF_PREDICATE); |
1760 | case EV_IF_PREDICATE: |
1761 | R_ENV = pop(); |
1762 | if (R_RESULT != SC_FALSE) { |
1763 | drop(); /* (alternate) */ |
1764 | R_EXPR = pop(); /* consequent */ |
1765 | goto EVAL; |
1766 | } |
1767 | R_EXPR = pop(); /* (alternate) */ |
1768 | drop(); /* consequent */ |
1769 | if (R_EXPR != SC_NULL) { |
1770 | R_EXPR = car(R_EXPR); /* alternate */ |
1771 | goto EVAL; |
1772 | } |
1773 | RETURN(SC_NULL); |
1774 | |
1775 | SET: |
1776 | /* (set! variable value) |
1777 | * Parameters: R_OPERANDS R_ENV */ |
1778 | err_context = "set!"; |
1779 | R_CAR = car(R_OPERANDS); /* variable name/ref */ |
1780 | R_EXPR = cadr(R_OPERANDS); /* value expression */ |
1781 | push(); |
1782 | PUSH(R_ENV); |
1783 | CALL(EVAL, EV_SET_RESULT); |
1784 | case EV_SET_RESULT: |
1785 | R_ENV = pop(); |
1786 | R_CAR = pop(); /* variable name/ref */ |
1787 | if (is_variable_ref(R_CAR)) |
1788 | variable_ref_set(R_CAR, R_ENV, R_RESULT); |
1789 | else /* Slow and stupid lookup for bootstrap, as in EVAL */ |
1790 | env_lookup_set(R_CAR, R_ENV, R_RESULT); |
1791 | RETURN(SC_NULL); |
1792 | |
1793 | LETREC: |
1794 | /* (letrec ((var init) ...) body) |
1795 | * Parameters: R_OPERANDS R_ENV */ |
1796 | r2 = R_ARGS = car(R_OPERANDS); /* binding specifiers */ |
1797 | PUSH(cdr(R_OPERANDS)); /* body */ |
1798 | R_CAR = make_letrec_frame(); /* new frame */ |
1799 | k = vector_len(R_CAR); |
1800 | R_CDR = R_ENV; |
1801 | R_ENV = cons(); /* new environment */ |
1802 | /* Evaluate initializers in the new environment */ |
1803 | PUSH(R_ENV); |
1804 | for (; R_ARGS != SC_NULL; R_ARGS = cdr(R_ARGS)) { |
1805 | k--; |
1806 | PUSH(k); |
1807 | PUSH(R_ARGS); |
1808 | R_EXPR = car(cdr(car(R_ARGS))); |
1809 | CALL(EVAL, EV_LETREC_LOOP); |
1810 | case EV_LETREC_LOOP: |
1811 | R_ARGS = pop(); |
1812 | k = pop(); |
1813 | R_ENV = peek(); |
1814 | vector_set(car(R_ENV), k, R_RESULT); |
1815 | /* Trick: all variables in a frame are considered UNDEFINED if the |
1816 | * first one is. (Checking this is cheap due to memoized variable |
1817 | * refs.) Since we're filling in the frame backwards, to match the |
1818 | * reversed name list from make_letrec_frame, we catch uses of |
1819 | * undefined variables in the initializers without needing to store |
1820 | * their results in a temporary list here and then copy. */ |
1821 | } |
1822 | drop(); |
1823 | assert(k == 1); |
1824 | /* Evaluate body in the now populated environment */ |
1825 | R_OPERANDS = pop(); /* body */ |
1826 | goto EVAL_BODY; |
1827 | |
1828 | DEFINE: |
1829 | /* (define variable value) |
1830 | * Paramters: R_OPERANDS R_ENV */ |
1831 | if (R_ENV != interaction_env) { |
1832 | err_context = "define"; |
1833 | sc_error("not allowed in this environment"); |
1834 | } |
1835 | PUSH(car(R_OPERANDS)); /* variable name */ |
1836 | R_EXPR = car(cdr(R_OPERANDS)); /* value expression */ |
1837 | CALL(EVAL, EV_DEFINE_RESULT); |
1838 | case EV_DEFINE_RESULT: |
1839 | /* XXX is this supposed to not handle variable refs? */ |
1840 | R_ENV = interaction_env; |
1841 | R_CAR = pop(); /* variable name */ |
1842 | R_EXPR = global_frame_lookup(R_CAR, car(R_ENV)); |
1843 | if (R_EXPR == SC_FALSE) { |
1844 | R_CDR = R_RESULT; |
1845 | extend_global_env(); |
1846 | } |
1847 | else set_cdr(R_EXPR, R_RESULT); |
1848 | RETURN(SC_NULL); |
1849 | |
1850 | DELAY: |
1851 | /* (delay expr) |
1852 | * Parameters: R_OPERANDS R_ENV */ |
1853 | R_EXPR = car(R_OPERANDS); |
1854 | RETURN(promise()); |
1855 | |
1856 | FORCE: |
1857 | /* Parameters: R_EXPR: promise */ |
1858 | if (!is_promise(R_EXPR)) sc_error1("not a promise:", R_EXPR); |
1859 | if (promise_done(R_EXPR)) RETURN(promise_value(R_EXPR)); |
1860 | PUSH(R_EXPR); |
1861 | R_ENV = promise_env(R_EXPR); |
1862 | R_EXPR = promise_value(R_EXPR); |
1863 | CALL(EVAL, EV_FORCE_RESULT); |
1864 | case EV_FORCE_RESULT: |
1865 | R_EXPR = pop(); |
1866 | /* If promise forces itself recursively, keep the first result */ |
1867 | if (promise_done(R_EXPR)) RETURN(promise_value(R_EXPR)); |
1868 | promise_memoize(R_EXPR, R_RESULT); |
1869 | RETURN(R_RESULT); |
1870 | |
1871 | CALL_WITH_VALUES: |
1872 | /* Parameters: R_PROC: producer, R_ARGS: consumer */ |
1873 | PUSH(R_ARGS); |
1874 | R_ARGS = SC_NULL; |
1875 | CALL(APPLY, EV_CALL_WITH_VALUES); |
1876 | case EV_CALL_WITH_VALUES: |
1877 | /* Producer returned a single value normally */ |
1878 | R_CAR = R_RESULT; |
1879 | R_CDR = SC_NULL; |
1880 | R_ARGS = cons(); |
1881 | CALL_WITH_VALUES_CONT: |
1882 | /* Producer returned by calling a continuation */ |
1883 | R_PROC = pop(); |
1884 | goto APPLY; |
1885 | |
1886 | } |
1887 | } |
1888 | |
1889 | /* Internal error signaller: similar in form to an evaluator subroutine, but |
1890 | * callable from downstack C functions. */ |
1891 | __attribute__((noreturn)) |
1892 | void sc_error1(const char *msg, value detail) { |
1893 | static int in_handler = 0; |
1894 | const char *sep = ": "; |
1895 | if (r_error_cont != SC_NULL) { |
1896 | /* Hook installed by toplevel. As it's a captured continuation, |
1897 | * unwinding from where the error occurred happens in the usual way. */ |
1898 | R_PROC = r_error_cont; |
1899 | /* Mirroring toplevel, fall back to the default if an error is |
1900 | * recursively raised in the handler (or the allocations here). If a |
1901 | * handler is restored using SET-ERROR-HANDLER!, r_error_cont is |
1902 | * restored alongside. */ |
1903 | r_error_cont = SC_NULL; |
1904 | R_CDR = SC_NULL; |
1905 | if (detail != UNDEFINED) { |
1906 | R_CAR = detail; |
1907 | R_CDR = cons(); |
1908 | } |
1909 | if (err_context) { |
1910 | value cl = strlen(err_context), sl = strlen(sep), ml = strlen(msg); |
1911 | uchar *buf = string_buf(R_CAR = make_string_uninit(cl + sl + ml)); |
1912 | memcpy(buf, err_context, cl); buf += cl; |
1913 | memcpy(buf, sep, sl); buf += sl; |
1914 | memcpy(buf, msg, ml); |
1915 | } |
1916 | else R_CAR = string(msg); |
1917 | R_CAR = cons(); |
1918 | R_CDR = SC_NULL; |
1919 | R_ARGS = cons(); |
1920 | longjmp(err_longjmp_env, 1); |
1921 | } |
1922 | else if (stdout_port && !in_handler) { |
1923 | /* Default handler: print and halt */ |
1924 | in_handler = 1; /* fall back to fatal if this too raises an error */ |
1925 | R_PORT = stdout_port; |
1926 | write_cstr("ERROR [fallback]: "); |
1927 | if (err_context) { |
1928 | write_cstr(err_context); |
1929 | write_cstr(sep); |
1930 | } |
1931 | write_cstr(msg); |
1932 | if (detail != UNDEFINED) { |
1933 | write_char(' '); |
1934 | R_EXPR = detail; |
1935 | shallow_print(); |
1936 | } |
1937 | newline(); |
1938 | sc_exit(1); |
1939 | } |
1940 | else fatal(msg); /* Not initialized, or loop */ |
1941 | } |
1942 | |
1943 | |
1944 | /***************** |
1945 | * Lexical scanner |
1946 | */ |
1947 | |
1948 | /* Initial buffer allocation for token types that need it */ |
1949 | #define DEFAULT_LEXBUF_SIZE 32 |
1950 | |
1951 | static value lexeme_length; |
1952 | static void lexbuf_init(void) { |
1953 | lexeme_length = 0; |
1954 | R_LEXEME = make_string_uninit(DEFAULT_LEXBUF_SIZE); |
1955 | } |
1956 | static void lexbuf_append(uchar c) { |
1957 | value buf_length = string_len(R_LEXEME); |
1958 | if (lexeme_length == buf_length) { |
1959 | value new_length = buf_length * 2; |
1960 | if (new_length > EXT_LENGTH_MAX) { |
1961 | new_length = EXT_LENGTH_MAX; |
1962 | if (lexeme_length == new_length) sc_error("token too long"); |
1963 | } |
1964 | value new_buf = make_string_uninit(new_length); |
1965 | memcpy(string_buf(new_buf), string_buf(R_LEXEME), buf_length); |
1966 | R_LEXEME = new_buf; |
1967 | } |
1968 | string_buf(R_LEXEME)[lexeme_length] = c; |
1969 | lexeme_length++; |
1970 | } |
1971 | static void lexbuf_done(void) { string_truncate(R_LEXEME, lexeme_length); } |
1972 | |
1973 | static int is_letter(int c) { |
1974 | return (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'); |
1975 | } |
1976 | static int is_digit(int c) { return (c >= '0' && c <= '9'); } |
1977 | static int in_str(int c, const char *s) { |
1978 | for (; *s; s++) if (*s == c) return 1; |
1979 | return 0; |
1980 | } |
1981 | static int is_whitespace(int c) { return in_str(c, " \t\n\f\r"); } |
1982 | static int is_delimiter(int c) { return c == EOF || in_str(c, " \t\n\f\r()\";"); } |
1983 | static int is_special_initial(int c) { return in_str(c, "!$%&*/:<=>?^_~"); } |
1984 | static int is_special_subsequent(int c) { return in_str(c, "+-.@"); } |
1985 | |
1986 | typedef enum { |
1987 | tok_eof, |
1988 | tok_literal, |
1989 | tok_open_paren, |
1990 | tok_close_paren, |
1991 | tok_dot, |
1992 | tok_open_vector, |
1993 | tok_identifier, |
1994 | tok_named_char, |
1995 | tok_abbrev, |
1996 | tok_number, |
1997 | } token_type; |
1998 | |
1999 | typedef enum { |
2000 | lex_start, |
2001 | lex_comment, |
2002 | lex_sharp, |
2003 | lex_bool, |
2004 | lex_comma, |
2005 | lex_dot, |
2006 | lex_dot2, |
2007 | lex_dot3, |
2008 | lex_ident, |
2009 | lex_string, |
2010 | lex_string_escape, |
2011 | lex_char, |
2012 | lex_char2, |
2013 | lex_named_char, |
2014 | lex_plus, |
2015 | lex_minus, |
2016 | lex_number, |
2017 | } lexer_state; |
2018 | |
2019 | /* Finite state machine to read a token from R_PORT. Returns the token type and |
2020 | * sets R_LEXEME to the value, if applicable: the expanded symbol for the |
2021 | * quoting abbreviations, and a string for identifiers, named characters, and |
2022 | * numbers. */ |
2023 | |
2024 | static token_type read_token(void) { |
2025 | lexer_state state = lex_start; |
2026 | uchar saved_char = 0; |
2027 | R_LEXEME = SC_NULL; |
2028 | #define TRANSITION(s) { state = s; continue; } |
2029 | #define PUT_BACK put_back_char(c) |
2030 | for (;;) { |
2031 | int c; |
2032 | value cv = read_char(R_PORT); |
2033 | c = (cv == SC_EOF) ? EOF : char_val(cv); |
2034 | |
2035 | switch (state) { |
2036 | case lex_start: |
2037 | switch (c) { |
2038 | case EOF: return tok_eof; |
2039 | case '(': return tok_open_paren; |
2040 | case ')': return tok_close_paren; |
2041 | case '\'': R_LEXEME = s_quote; return tok_abbrev; |
2042 | case '`': R_LEXEME = s_quasiquote; return tok_abbrev; |
2043 | case '#': TRANSITION(lex_sharp); |
2044 | case ',': TRANSITION(lex_comma); |
2045 | case '.': TRANSITION(lex_dot); |
2046 | case ';': TRANSITION(lex_comment); |
2047 | case '"': lexbuf_init(); TRANSITION(lex_string); |
2048 | case '+': TRANSITION(lex_plus); |
2049 | case '-': TRANSITION(lex_minus); |
2050 | default: |
2051 | if (is_whitespace(c)) continue; |
2052 | lexbuf_init(); |
2053 | if (is_letter(c) || is_special_initial(c)) { |
2054 | lexbuf_append(lc(c)); TRANSITION(lex_ident); |
2055 | } |
2056 | if (is_digit(c)) { |
2057 | lexbuf_append(c); TRANSITION(lex_number); |
2058 | } |
2059 | sc_error1("bad character at start of token:", character(c)); |
2060 | } |
2061 | case lex_comment: |
2062 | if (c == '\n') TRANSITION(lex_start); |
2063 | if (c == EOF) return tok_eof; |
2064 | continue; |
2065 | case lex_sharp: |
2066 | switch (lc(c)) { |
2067 | case '(': return tok_open_vector; |
2068 | case 't': R_LEXEME = SC_TRUE; TRANSITION(lex_bool); |
2069 | case 'f': R_LEXEME = SC_FALSE; TRANSITION(lex_bool); |
2070 | case 'e': |
2071 | case 'i': |
2072 | case 'b': |
2073 | case 'o': |
2074 | case 'd': |
2075 | case 'x': lexbuf_init(); lexbuf_append('#'); lexbuf_append(c); |
2076 | TRANSITION(lex_number); |
2077 | case '\\': TRANSITION(lex_char); |
2078 | default: sc_error("bad # sequence"); |
2079 | } |
2080 | case lex_bool: |
2081 | PUT_BACK; |
2082 | if (!is_delimiter(c)) sc_error("bad # sequence"); |
2083 | return tok_literal; |
2084 | case lex_comma: |
2085 | if (c == '@') { R_LEXEME = s_unquote_splicing; return tok_abbrev; } |
2086 | PUT_BACK; R_LEXEME = s_unquote; return tok_abbrev; |
2087 | case lex_dot: |
2088 | if (is_delimiter(c)) { PUT_BACK; return tok_dot; } |
2089 | if (c == '.') TRANSITION(lex_dot2); |
2090 | lexbuf_init(); lexbuf_append('.'); lexbuf_append(c); |
2091 | TRANSITION(lex_number); |
2092 | case lex_dot2: |
2093 | if (c != '.') { PUT_BACK; sc_error("bad . sequence"); } |
2094 | TRANSITION(lex_dot3); |
2095 | case lex_dot3: |
2096 | PUT_BACK; |
2097 | if (is_delimiter(c)) { |
2098 | R_LEXEME = string("..."); return tok_identifier; |
2099 | } |
2100 | sc_error("bad . sequence"); |
2101 | case lex_ident: |
2102 | if (is_letter(c) || is_special_initial(c) || |
2103 | is_digit(c) || is_special_subsequent(c)) { |
2104 | lexbuf_append(lc(c)); continue; |
2105 | } |
2106 | PUT_BACK; |
2107 | if (is_delimiter(c)) { lexbuf_done(); return tok_identifier; } |
2108 | sc_error("bad identifier"); |
2109 | case lex_string: |
2110 | switch (c) { |
2111 | case EOF: sc_error("unexpected end-of-file in string"); |
2112 | case '"': lexbuf_done(); return tok_literal; |
2113 | case '\\': TRANSITION(lex_string_escape); |
2114 | default: lexbuf_append(c); continue; |
2115 | } |
2116 | case lex_string_escape: |
2117 | switch (c) { |
2118 | case EOF: sc_error("unexpected end-of-file in string"); |
2119 | case '"': |
2120 | case '\\': lexbuf_append(c); TRANSITION(lex_string); |
2121 | default: sc_error("bad escape in string"); |
2122 | } |
2123 | case lex_char: |
2124 | if (c == EOF) sc_error("unexpected end-of-file in character"); |
2125 | saved_char = c; TRANSITION(lex_char2); |
2126 | case lex_char2: |
2127 | if (is_delimiter(c)) { |
2128 | PUT_BACK; R_LEXEME = character(saved_char); return tok_literal; |
2129 | } |
2130 | lexbuf_init(); lexbuf_append(lc(saved_char)); lexbuf_append(lc(c)); |
2131 | TRANSITION(lex_named_char); |
2132 | case lex_named_char: |
2133 | if (is_delimiter(c)) { |
2134 | PUT_BACK; |
2135 | lexbuf_done(); |
2136 | return tok_named_char; |
2137 | } |
2138 | lexbuf_append(lc(c)); continue; |
2139 | case lex_plus: |
2140 | if (is_delimiter(c)) { |
2141 | PUT_BACK; R_LEXEME = string("+"); return tok_identifier; |
2142 | } |
2143 | lexbuf_init(); lexbuf_append('+'); lexbuf_append(c); |
2144 | TRANSITION(lex_number); |
2145 | case lex_minus: |
2146 | if (is_delimiter(c)) { |
2147 | PUT_BACK; R_LEXEME = string("-"); return tok_identifier; |
2148 | } |
2149 | lexbuf_init(); lexbuf_append('-'); lexbuf_append(c); |
2150 | TRANSITION(lex_number); |
2151 | case lex_number: |
2152 | if (is_delimiter(c)) { |
2153 | PUT_BACK; |
2154 | lexbuf_done(); |
2155 | return tok_number; |
2156 | } |
2157 | lexbuf_append(c); continue; |
2158 | } |
2159 | } |
2160 | } |
2161 | |
2162 | |
2163 | /****************** |
2164 | * Bootstrap reader |
2165 | */ |
2166 | |
2167 | /* Read a value from R_PORT, using a predictive parser for Scheme's LL(1) |
2168 | * grammar (report section 7.1.2). The sole purpose is to parse the compiler |
2169 | * and library code at startup (though this started out as the only reader). |
2170 | * Does not handle named characters or any numeric syntax beyond plain decimal |
2171 | * fixnums. |
2172 | * |
2173 | * O(n) runtime except for symbols, as interning is currently proportional to |
2174 | * the symbol table size for each one. Implemented as subroutines calling on |
2175 | * the Scheme stack, much like the evaluator, so there is no overflow hazard or |
2176 | * nesting depth limit other than available heap space. */ |
2177 | |
2178 | /* Minimal base-10 fixnum decoder */ |
2179 | static value str_to_fixnum(value s) { |
2180 | uchar *p = string_buf(s); |
2181 | value len = string_len(s), neg = 0, acc = 0; |
2182 | if (!len) goto err; |
2183 | if (*p == '-') { |
2184 | neg = 1; --len; ++p; |
2185 | if (!len) goto err; |
2186 | } |
2187 | for (; len; --len, ++p) { |
2188 | if (!is_digit(*p)) goto err; |
2189 | if (acc > FIXNUM_MAX/10) goto err; |
2190 | acc = 10*acc + (*p - '0'); |
2191 | } |
2192 | if (acc > FIXNUM_MAX) goto err; |
2193 | return fixnum(neg ? -acc : acc); |
2194 | err: |
2195 | sc_error("bad number token"); |
2196 | } |
2197 | |
2198 | /* Return addresses */ |
2199 | #define RD_DONE 0 |
2200 | #define RD_LIST_FIRST 1 |
2201 | #define RD_LIST_LOOP 2 |
2202 | #define RD_LIST_DOT 3 |
2203 | #define RD_ABBREV 4 |
2204 | #define RD_VEC_LOOP 5 |
2205 | |
2206 | static value sc_read(void) { |
2207 | token_type t; |
2208 | CALL(datum, RD_DONE); |
2209 | |
2210 | dispatch: |
2211 | switch (pop()) { |
2212 | case RD_DONE: |
2213 | break; |
2214 | |
2215 | datum: |
2216 | t = read_token(); |
2217 | switch (t) { |
2218 | case tok_eof: RETURN(SC_EOF); |
2219 | case tok_literal: RETURN(R_LEXEME); |
2220 | case tok_open_paren: goto list; |
2221 | case tok_close_paren: RETURN(RD_CLOSEPAREN); |
2222 | case tok_dot: RETURN(RD_DOT); |
2223 | case tok_open_vector: goto vector; |
2224 | case tok_identifier: R_CAR = R_LEXEME; RETURN(string_to_symbol()); |
2225 | case tok_named_char: sc_error("named characters unsupported"); |
2226 | case tok_abbrev: goto abbrev; |
2227 | case tok_number: RETURN(str_to_fixnum(R_LEXEME)); |
2228 | } |
2229 | |
2230 | list: |
2231 | CALL(datum, RD_LIST_FIRST); |
2232 | case RD_LIST_FIRST: |
2233 | if (R_RESULT == RD_CLOSEPAREN) RETURN(SC_NULL); |
2234 | if (R_RESULT == RD_DOT) sc_error("dotted list without first item"); |
2235 | if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in list"); |
2236 | R_CAR = R_RESULT; |
2237 | R_CDR = SC_NULL; |
2238 | R_CAR = cons(); |
2239 | push(); /* list head */ |
2240 | for (;;) { |
2241 | push(); /* list tail */ |
2242 | CALL(datum, RD_LIST_LOOP); |
2243 | case RD_LIST_LOOP: |
2244 | if (R_RESULT == RD_CLOSEPAREN) { |
2245 | drop(); /* list tail */ |
2246 | RETURN(pop()); /* list head */ |
2247 | } |
2248 | if (R_RESULT == RD_DOT) { |
2249 | CALL(datum, RD_LIST_DOT); |
2250 | case RD_LIST_DOT: |
2251 | if (R_RESULT == RD_CLOSEPAREN) |
2252 | sc_error("dotted list without last item"); |
2253 | if (R_RESULT == RD_DOT) sc_error("extra dot in dotted list"); |
2254 | if (R_RESULT == SC_EOF) |
2255 | sc_error("unexpected end-of-file in list"); |
2256 | PUSH(R_RESULT) |
2257 | t = read_token(); |
2258 | R_RESULT = pop(); |
2259 | R_CAR = pop(); /* list tail */ |
2260 | if (t == tok_close_paren) { |
2261 | set_cdr(R_CAR, R_RESULT); |
2262 | RETURN(pop()); /* list head */ |
2263 | } |
2264 | if (t == tok_eof) sc_error("unexpected end-of-file in list"); |
2265 | sc_error("excess item in tail of dotted list"); |
2266 | } |
2267 | if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in list"); |
2268 | R_CAR = R_RESULT; |
2269 | R_CDR = SC_NULL; |
2270 | R_CAR = cons(); |
2271 | R_CDR = pop(); /* list tail */ |
2272 | set_cdr(R_CDR, R_CAR); |
2273 | } |
2274 | |
2275 | abbrev: /* 'x -> (quote x) etc. */ |
2276 | PUSH(R_LEXEME) /* expanded abbrev symbol */ |
2277 | CALL(datum, RD_ABBREV); |
2278 | case RD_ABBREV: |
2279 | if (R_RESULT == RD_CLOSEPAREN) |
2280 | sc_error("unexpected close-paren in abbreviation"); |
2281 | if (R_RESULT == RD_DOT) |
2282 | sc_error("unexpected dot in abbreviation"); |
2283 | if (R_RESULT == SC_EOF) |
2284 | sc_error("unexpected end-of-file in abbreviation"); |
2285 | R_CAR = R_RESULT; |
2286 | R_CDR = SC_NULL; |
2287 | R_CDR = cons(); |
2288 | R_CAR = pop(); /* expanded abbrev symbol */ |
2289 | RETURN(cons()); |
2290 | |
2291 | vector: |
2292 | /* First build a list */ |
2293 | R_CAR = SC_NULL; |
2294 | for (;;) { |
2295 | push(); /* list head */ |
2296 | CALL(datum, RD_VEC_LOOP); |
2297 | case RD_VEC_LOOP: |
2298 | if (R_RESULT == RD_CLOSEPAREN) { |
2299 | /* Then copy to a new vector while un-reversing */ |
2300 | R_EXPR = pop(); /* list head */ |
2301 | RETURN(rev_list_to_vec()); |
2302 | } |
2303 | if (R_RESULT == RD_DOT) sc_error("unexpected dot in vector"); |
2304 | if (R_RESULT == SC_EOF) |
2305 | sc_error("unexpected end-of-file in vector"); |
2306 | R_CAR = R_RESULT; |
2307 | R_CDR = pop(); /* list head */ |
2308 | R_CAR = cons(); |
2309 | } |
2310 | |
2311 | } |
2312 | if (R_RESULT == RD_CLOSEPAREN) sc_error("unexpected close-paren"); |
2313 | if (R_RESULT == RD_DOT) sc_error("unexpected dot"); |
2314 | return R_RESULT; |
2315 | } |
2316 | |
2317 | |
2318 | /***************** |
2319 | * Number printers |
2320 | */ |
2321 | |
2322 | static char fmt_buf[128]; /* TODO justify size */ |
2323 | static const char *fmt_fixnum_dec(long val) { |
2324 | int i = sizeof(fmt_buf) - 1, neg = 0; |
2325 | /* TODO null termination is convenient here but perhaps not ideal */ |
2326 | fmt_buf[i] = 0; |
2327 | if (val < 0) { neg = 1; val = -val; } |
2328 | do { |
2329 | --i; assert(i); |
2330 | fmt_buf[i] = '0' + (val % 10); |
2331 | val /= 10; |
2332 | } while (val); |
2333 | if (neg) fmt_buf[--i] = '-'; |
2334 | return fmt_buf+i; |
2335 | } |
2336 | static const char *fmt_ulong_dec(ulong val) { |
2337 | int i = sizeof(fmt_buf) - 1; |
2338 | fmt_buf[i] = 0; |
2339 | do { |
2340 | --i; assert(i >= 0); |
2341 | fmt_buf[i] = '0' + (val % 10); |
2342 | val /= 10; |
2343 | } while (val); |
2344 | return fmt_buf+i; |
2345 | } |
2346 | static const char *fmt_fixnum_hex(long val) { |
2347 | int i = sizeof(fmt_buf) - 1, neg = 0; |
2348 | fmt_buf[i] = 0; |
2349 | if (val < 0) { neg = 1; val = -val; } |
2350 | do { |
2351 | --i; assert(i); |
2352 | fmt_buf[i] = "0123456789abcdef"[val & 0xf]; |
2353 | val >>= 4; |
2354 | } while (val); |
2355 | if (neg) fmt_buf[--i] = '-'; |
2356 | return fmt_buf+i; |
2357 | } |
2358 | static const char *fmt_fixnum_oct(long val) { |
2359 | int i = sizeof(fmt_buf) - 1, neg = 0; |
2360 | fmt_buf[i] = 0; |
2361 | if (val < 0) { neg = 1; val = -val; } |
2362 | do { |
2363 | --i; assert(i); |
2364 | fmt_buf[i] = '0' + (val & 7); |
2365 | val >>= 3; |
2366 | } while (val); |
2367 | if (neg) fmt_buf[--i] = '-'; |
2368 | return fmt_buf+i; |
2369 | } |
2370 | static const char *fmt_fixnum_bin(long val) { |
2371 | int i = sizeof(fmt_buf) - 1, neg = 0; |
2372 | fmt_buf[i] = 0; |
2373 | if (val < 0) { neg = 1; val = -val; } |
2374 | do { |
2375 | --i; assert(i); |
2376 | fmt_buf[i] = '0' + (val & 1); |
2377 | val >>= 1; |
2378 | } while (val); |
2379 | if (neg) fmt_buf[--i] = '-'; |
2380 | return fmt_buf+i; |
2381 | } |
2382 | static const char *fmt_ulong_bin(ulong val) { |
2383 | int i = sizeof(fmt_buf) - 1; |
2384 | fmt_buf[i] = 0; |
2385 | do { |
2386 | --i; assert(i); |
2387 | fmt_buf[i] = '0' + (val & 1); |
2388 | val >>= 1; |
2389 | } while (val); |
2390 | return fmt_buf+i; |
2391 | } |
2392 | static const char *fmt_flonum_dec(double val) { |
2393 | /* TODO follow up on R5RS citations 3 and 5 */ |
2394 | if ((size_t)snprintf(fmt_buf, sizeof fmt_buf, "%.15g", val) >= |
2395 | sizeof fmt_buf) |
2396 | sc_error("BUG: flonum formatting truncated"); |
2397 | return fmt_buf; |
2398 | } |
2399 | |
2400 | /**************************** |
2401 | * Fallback (shallow) printer |
2402 | */ |
2403 | |
2404 | /* Print the value in R_EXPR to R_PORT, using "write" style (quoting strings |
2405 | * and characters) but not expanding named characters or looking inside |
2406 | * compound objects. (This used to be the real printer, implemented as |
2407 | * recursive subroutines on the Scheme stack like the reader and evaluator, but |
2408 | * is now just for low-level debug and fallback error handlers.) */ |
2409 | |
2410 | static void shallow_print(void) { |
2411 | int t = tag(R_EXPR); |
2412 | if (t == T_SPECIAL) { |
2413 | const char *s; |
2414 | if (R_EXPR == SC_NULL) s = "()"; |
2415 | else if (R_EXPR == SC_TRUE) s = "#t"; |
2416 | else if (R_EXPR == SC_FALSE) s = "#f"; |
2417 | else if (R_EXPR == SC_EOF) s = "#EOF"; |
2418 | else if (R_EXPR == SC_NULL_ENV) s = "#ENVSPEC:NULL"; |
2419 | else if (R_EXPR == SC_REPORT_ENV) s = "#ENVSPEC:SCHEME-REPORT"; |
2420 | else if (R_EXPR == SC_GSCM_ENV) s = "#ENVSPEC:GALES-SCHEME"; |
2421 | else if (R_EXPR == SC_INTERACT_ENV) s = "#ENVSPEC:INTERACTION"; |
2422 | else if (R_EXPR == SC_TOPLEVEL_ENV) s = "#ENVSPEC:TOPLEVEL"; |
2423 | else if (R_EXPR == UNDEFINED) s = "#UNDEFINED"; |
2424 | else if (R_EXPR == RD_CLOSEPAREN) s = "#RDSENTINEL:CLOSEPAREN"; |
2425 | else if (R_EXPR == RD_DOT) s = "#RDSENTINEL:DOT"; |
2426 | else fatal("BUG: invalid special in shallow_print"); |
2427 | write_cstr(s); |
2428 | } |
2429 | else if (t == T_IMMUT_PAIR) write_cstr("#IMMUTABLE-PAIR"); |
2430 | else if (t == T_PAIR) write_cstr("#PAIR"); |
2431 | else if (t == T_CHARACTER) { write_cstr("#\\"); write_char(R_EXPR); } |
2432 | else if (t == T_FIXNUM) write_cstr(fmt_fixnum_dec(fixnum_val(R_EXPR))); |
2433 | else if (t == T_EXTENDED) { |
2434 | t = ext_tag(heap[untag(R_EXPR)]); |
2435 | if ((t | 1) == T_STRING) write_str_quoted(R_EXPR); |
2436 | else if ((t | 1) == T_VECTOR) { |
2437 | if (t == T_VECTOR) write_cstr("#VECTOR:"); |
2438 | else write_cstr("#IMMUTABLE-VECTOR:"); |
2439 | write_cstr(fmt_fixnum_dec(vector_len(R_EXPR))); |
2440 | } |
2441 | else if (t == T_SYMBOL) write_str(R_EXPR); |
2442 | else if (t == T_BUILTIN) { |
2443 | write_cstr("#BUILTIN:"); |
2444 | write_cstr(builtin_name(R_EXPR)); |
2445 | } |
2446 | else if (t == T_PROCEDURE) write_cstr("#PROCEDURE"); |
2447 | else if (t == T_CONTINUATION) write_cstr("#CONTINUATION"); |
2448 | else if (t == T_PROMISE) write_cstr("#PROMISE"); |
2449 | else if (t == T_PORT) write_cstr("#PORT"); |
2450 | else if (t == T_FLONUM) write_cstr("#FLONUM"); |
2451 | else if (t == T_BIGNUM) write_cstr("#BIGNUM"); |
2452 | else if (t == T_RATIONAL) write_cstr("#RATIONAL"); |
2453 | else if (t == T_COMPLEX) write_cstr("#COMPLEX"); |
2454 | else if (t == T_VARIABLE_REF) write_cstr("#VARIABLE-REF"); |
2455 | else fatal("BUG: invalid extended tag in shallow_print"); |
2456 | } |
2457 | else fatal("BUG: invalid tag in shallow_print"); |
2458 | } |
2459 | |
2460 | |
2461 | /******************** |
2462 | * Builtin procedures |
2463 | */ |
2464 | |
2465 | /* Argument wrangling helpers for builtins */ |
2466 | |
2467 | static void require_args(value args) { |
2468 | if (args == SC_NULL) sc_error("too few arguments"); |
2469 | } |
2470 | |
2471 | static void no_args(value args) { |
2472 | if (args != SC_NULL) sc_error("too many arguments"); |
2473 | } |
2474 | |
2475 | static value extract_arg(value *args) { |
2476 | require_args(*args); |
2477 | value arg = car(*args); |
2478 | *args = cdr(*args); |
2479 | return arg; |
2480 | } |
2481 | |
2482 | static value final_arg(value args) { |
2483 | require_args(args); |
2484 | no_args(cdr(args)); |
2485 | return car(args); |
2486 | } |
2487 | |
2488 | static value require_input_port(value arg) { |
2489 | if (!is_input_port(arg)) sc_error("not an input port"); return arg; |
2490 | } |
2491 | |
2492 | static value require_output_port(value arg) { |
2493 | if (!is_output_port(arg)) sc_error("not an output port"); return arg; |
2494 | } |
2495 | |
2496 | static value opt_final_in_port_arg(value args) { |
2497 | return require_input_port(args == SC_NULL ? r_input_port : |
2498 | final_arg(args)); |
2499 | } |
2500 | |
2501 | static value opt_final_out_port_arg(value args) { |
2502 | return require_output_port(args == SC_NULL ? r_output_port : |
2503 | final_arg(args)); |
2504 | } |
2505 | |
2506 | static value require_symbol(value arg) { |
2507 | if (!is_symbol(arg)) sc_error1("not a symbol:", arg); |
2508 | return arg; |
2509 | } |
2510 | |
2511 | static value require_string(value arg) { |
2512 | if (!is_string(arg)) sc_error1("not a string:", arg); |
2513 | return arg; |
2514 | } |
2515 | |
2516 | static value require_mutable_string(value arg) { |
2517 | if (!is_mutable_string(arg)) { |
2518 | if (is_string(arg)) sc_error1("immutable string:", arg); |
2519 | sc_error1("not a string:", arg); |
2520 | } |
2521 | return arg; |
2522 | } |
2523 | |
2524 | static value require_stringlike(value arg) { |
2525 | if (!(is_string(arg) || is_symbol(arg))) |
2526 | sc_error1("not a string or symbol:", arg); |
2527 | return arg; |
2528 | } |
2529 | |
2530 | static value require_vector(value arg) { |
2531 | if (!is_vector(arg)) sc_error1("not a vector:", arg); |
2532 | return arg; |
2533 | } |
2534 | |
2535 | static value require_mutable_vector(value arg) { |
2536 | if (!is_mutable_vector(arg)) { |
2537 | if (is_vector(arg)) sc_error1("immutable vector:", arg); |
2538 | sc_error1("not a vector:", arg); |
2539 | } |
2540 | return arg; |
2541 | } |
2542 | |
2543 | static value require_fixnum(value arg) { |
2544 | if (!is_fixnum(arg)) sc_error1("not a fixnum:", arg); |
2545 | return arg; |
2546 | } |
2547 | |
2548 | static value require_procedure(value arg) { |
2549 | if (!is_procedure(arg)) sc_error1("not a procedure:", arg); |
2550 | return arg; |
2551 | } |
2552 | |
2553 | #define BUILTIN(name) static value name(value args) |
2554 | |
2555 | /* Mnemonic for multi-valued returns, i.e. passing multiple values to the |
2556 | * current continuation. f_values is strictly an optimization; we could just as |
2557 | * well set R_PROC to current_continuation() and r_flag to f_apply. |
2558 | * The arg list must be newly allocated! */ |
2559 | #define RETURN_VALUES(args) { \ |
2560 | R_ARGS = args; \ |
2561 | r_flag = f_values; \ |
2562 | return SC_NULL; \ |
2563 | } |
2564 | |
2565 | /* 6.1 Equivalence predicates */ |
2566 | |
2567 | BUILTIN(builtin_is_eq) { |
2568 | value a = extract_arg(&args); |
2569 | return boolean(a == final_arg(args)); |
2570 | } |
2571 | |
2572 | /* 6.2.5 Numerical operations */ |
2573 | |
2574 | BUILTIN(builtin_is_number) { return boolean(is_number(final_arg(args))); } |
2575 | BUILTIN(builtin_is_integer) { return boolean(is_integer(final_arg(args))); } |
2576 | BUILTIN(builtin_is_exact) { return boolean(is_exact(final_arg(args))); } |
2577 | BUILTIN(builtin_is_inexact) { return boolean(is_flonum(final_arg(args))); } |
2578 | |
2579 | /* 6.3.1 Booleans */ |
2580 | |
2581 | BUILTIN(builtin_not) { return boolean(final_arg(args) == SC_FALSE); } |
2582 | BUILTIN(builtin_is_boolean) { return boolean(is_boolean(final_arg(args))); } |
2583 | |
2584 | /* 6.3.2 Pairs and lists */ |
2585 | |
2586 | BUILTIN(builtin_is_pair) { return boolean(is_pair(final_arg(args))); } |
2587 | BUILTIN(builtin_cons) { |
2588 | R_CAR = extract_arg(&args); |
2589 | R_CDR = final_arg(args); |
2590 | return cons(); |
2591 | } |
2592 | |
2593 | BUILTIN(builtin_car) { return safe_car(final_arg(args)); } |
2594 | BUILTIN(builtin_cdr) { return safe_cdr(final_arg(args)); } |
2595 | |
2596 | BUILTIN(builtin_caar) { return safe_car(builtin_car(args)); } |
2597 | BUILTIN(builtin_cadr) { return safe_car(builtin_cdr(args)); } |
2598 | BUILTIN(builtin_cdar) { return safe_cdr(builtin_car(args)); } |
2599 | BUILTIN(builtin_cddr) { return safe_cdr(builtin_cdr(args)); } |
2600 | |
2601 | BUILTIN(builtin_caaar) { return safe_car(builtin_caar(args)); } |
2602 | BUILTIN(builtin_caadr) { return safe_car(builtin_cadr(args)); } |
2603 | BUILTIN(builtin_cadar) { return safe_car(builtin_cdar(args)); } |
2604 | BUILTIN(builtin_caddr) { return safe_car(builtin_cddr(args)); } |
2605 | BUILTIN(builtin_cdaar) { return safe_cdr(builtin_caar(args)); } |
2606 | BUILTIN(builtin_cdadr) { return safe_cdr(builtin_cadr(args)); } |
2607 | BUILTIN(builtin_cddar) { return safe_cdr(builtin_cdar(args)); } |
2608 | BUILTIN(builtin_cdddr) { return safe_cdr(builtin_cddr(args)); } |
2609 | |
2610 | BUILTIN(builtin_caaaar) { return safe_car(builtin_caaar(args)); } |
2611 | BUILTIN(builtin_caaadr) { return safe_car(builtin_caadr(args)); } |
2612 | BUILTIN(builtin_caadar) { return safe_car(builtin_cadar(args)); } |
2613 | BUILTIN(builtin_caaddr) { return safe_car(builtin_caddr(args)); } |
2614 | BUILTIN(builtin_cadaar) { return safe_car(builtin_cdaar(args)); } |
2615 | BUILTIN(builtin_cadadr) { return safe_car(builtin_cdadr(args)); } |
2616 | BUILTIN(builtin_caddar) { return safe_car(builtin_cddar(args)); } |
2617 | BUILTIN(builtin_cadddr) { return safe_car(builtin_cdddr(args)); } |
2618 | BUILTIN(builtin_cdaaar) { return safe_cdr(builtin_caaar(args)); } |
2619 | BUILTIN(builtin_cdaadr) { return safe_cdr(builtin_caadr(args)); } |
2620 | BUILTIN(builtin_cdadar) { return safe_cdr(builtin_cadar(args)); } |
2621 | BUILTIN(builtin_cdaddr) { return safe_cdr(builtin_caddr(args)); } |
2622 | BUILTIN(builtin_cddaar) { return safe_cdr(builtin_cdaar(args)); } |
2623 | BUILTIN(builtin_cddadr) { return safe_cdr(builtin_cdadr(args)); } |
2624 | BUILTIN(builtin_cdddar) { return safe_cdr(builtin_cddar(args)); } |
2625 | BUILTIN(builtin_cddddr) { return safe_cdr(builtin_cdddr(args)); } |
2626 | |
2627 | BUILTIN(builtin_set_car) { |
2628 | value p = extract_arg(&args); |
2629 | value val = final_arg(args); |
2630 | if (tag(p) != T_PAIR) { |
2631 | if (tag(p) == T_IMMUT_PAIR) sc_error("immutable pair"); |
2632 | sc_error("not a pair"); |
2633 | } |
2634 | set_car(p, val); |
2635 | return SC_NULL; |
2636 | } |
2637 | BUILTIN(builtin_set_cdr) { |
2638 | value p = extract_arg(&args); |
2639 | value val = final_arg(args); |
2640 | if (tag(p) != T_PAIR) { |
2641 | if (tag(p) == T_IMMUT_PAIR) sc_error("immutable pair"); |
2642 | sc_error("not a pair"); |
2643 | } |
2644 | set_cdr(p, val); |
2645 | return SC_NULL; |
2646 | } |
2647 | |
2648 | BUILTIN(builtin_is_null) { return boolean(final_arg(args) == SC_NULL); } |
2649 | BUILTIN(builtin_is_list) { return boolean(is_list(final_arg(args))); } |
2650 | |
2651 | BUILTIN(builtin_length) { |
2652 | long len = safe_list_length(final_arg(args)); |
2653 | if (len < 0) sc_error("not a list"); |
2654 | return fixnum(len); |
2655 | } |
2656 | |
2657 | /* 6.3.3 Symbols */ |
2658 | |
2659 | BUILTIN(builtin_is_symbol) { return boolean(is_symbol(final_arg(args))); } |
2660 | |
2661 | BUILTIN(builtin_sym_to_str) { |
2662 | /* TODO use immutability to avoid copying */ |
2663 | R_EXPR = require_symbol(final_arg(args)); |
2664 | return string_copy_immutable(); |
2665 | } |
2666 | |
2667 | BUILTIN(builtin_str_to_sym) { |
2668 | R_CAR = require_string(final_arg(args)); |
2669 | return string_to_symbol(); |
2670 | } |
2671 | |
2672 | /* 6.3.4 Characters */ |
2673 | |
2674 | BUILTIN(builtin_is_char) { return boolean(is_character(final_arg(args))); } |
2675 | |
2676 | #define CHAR1 uchar a = safe_char_val(final_arg(args)); |
2677 | #define CHAR2 uchar a = safe_char_val(extract_arg(&args)); \ |
2678 | uchar b = safe_char_val(final_arg(args)); |
2679 | |
2680 | BUILTIN(builtin_char_eq) { CHAR2 return boolean(a == b); } |
2681 | BUILTIN(builtin_char_lt) { CHAR2 return boolean(a < b); } |
2682 | BUILTIN(builtin_char_gt) { CHAR2 return boolean(a > b); } |
2683 | BUILTIN(builtin_char_le) { CHAR2 return boolean(a <= b); } |
2684 | BUILTIN(builtin_char_ge) { CHAR2 return boolean(a >= b); } |
2685 | BUILTIN(builtin_char_ci_eq) { CHAR2 return boolean(lc(a) == lc(b)); } |
2686 | BUILTIN(builtin_char_ci_lt) { CHAR2 return boolean(lc(a) < lc(b)); } |
2687 | BUILTIN(builtin_char_ci_gt) { CHAR2 return boolean(lc(a) > lc(b)); } |
2688 | BUILTIN(builtin_char_ci_le) { CHAR2 return boolean(lc(a) <= lc(b)); } |
2689 | BUILTIN(builtin_char_ci_ge) { CHAR2 return boolean(lc(a) >= lc(b)); } |
2690 | |
2691 | BUILTIN(builtin_char_is_alpha) { |
2692 | CHAR1 return boolean((a >= 'A' && a <= 'Z') || (a >= 'a' && a <= 'z')); |
2693 | } |
2694 | BUILTIN(builtin_char_is_num) { |
2695 | CHAR1 return boolean(a >= '0' && a <= '9'); |
2696 | } |
2697 | BUILTIN(builtin_char_is_white) { CHAR1 return boolean(is_whitespace(a)); } |
2698 | BUILTIN(builtin_char_is_upper) { CHAR1 return boolean(a >= 'A' && a <= 'Z'); } |
2699 | BUILTIN(builtin_char_is_lower) { CHAR1 return boolean(a >= 'a' && a <= 'z'); } |
2700 | |
2701 | BUILTIN(builtin_char_to_int) { CHAR1 return fixnum(a); } |
2702 | |
2703 | BUILTIN(builtin_int_to_char) { |
2704 | long n = safe_fixnum_val(final_arg(args)); |
2705 | if (n < 0 || n > 255) sc_error1("out of bounds:", fixnum(n)); |
2706 | return character(n); |
2707 | } |
2708 | |
2709 | BUILTIN(builtin_char_upcase) { CHAR1 return character(uc(a)); } |
2710 | BUILTIN(builtin_char_downcase) { CHAR1 return character(lc(a)); } |
2711 | |
2712 | /* 6.3.5 Strings */ |
2713 | |
2714 | BUILTIN(builtin_is_str) { return boolean(is_string(final_arg(args))); } |
2715 | |
2716 | BUILTIN(builtin_make_str) { |
2717 | long len = safe_fixnum_val(extract_arg(&args)); |
2718 | uchar fill = (args == SC_NULL) ? ' ' : safe_char_val(final_arg(args)); |
2719 | return make_string(len, fill); |
2720 | } |
2721 | |
2722 | BUILTIN(builtin_str_length) { |
2723 | return fixnum(string_len(require_string(final_arg(args)))); |
2724 | } |
2725 | |
2726 | BUILTIN(builtin_str_ref) { |
2727 | value s = require_string(extract_arg(&args)); |
2728 | value k = final_arg(args); |
2729 | value k_unsigned = safe_fixnum_val(k); |
2730 | /* see builtin_vec_ref comments */ |
2731 | if (k_unsigned >= string_len(s)) sc_error1("out of bounds:", k); |
2732 | return character(string_buf(s)[k_unsigned]); |
2733 | } |
2734 | |
2735 | BUILTIN(builtin_str_set) { |
2736 | value s = require_mutable_string(extract_arg(&args)); |
2737 | value k = extract_arg(&args); |
2738 | uchar new_char = safe_char_val(final_arg(args)); |
2739 | value k_unsigned = safe_fixnum_val(k); |
2740 | /* see builtin_vec_ref comments */ |
2741 | if (k_unsigned >= string_len(s)) sc_error1("out of bounds:", k); |
2742 | string_buf(s)[k_unsigned] = new_char; |
2743 | return SC_NULL; |
2744 | } |
2745 | |
2746 | #define STR2 value a = require_string(extract_arg(&args)); \ |
2747 | value b = require_string(final_arg(args)); \ |
2748 | size_t a_len = string_len(a), b_len = string_len(b); \ |
2749 | uchar *a_buf = string_buf(a), *b_buf = string_buf(b); |
2750 | |
2751 | BUILTIN(builtin_str_eq) { |
2752 | STR2 |
2753 | if (a_len != b_len) return SC_FALSE; |
2754 | return boolean(memcmp(a_buf, b_buf, a_len) == 0); |
2755 | } |
2756 | |
2757 | #define STRCMP \ |
2758 | STR2 int cmp = memcmp(a_buf, b_buf, (a_len < b_len) ? a_len : b_len); |
2759 | |
2760 | BUILTIN(builtin_str_lt) { |
2761 | STRCMP return boolean(cmp < 0 || (cmp == 0 && a_len < b_len)); |
2762 | } |
2763 | BUILTIN(builtin_str_gt) { |
2764 | STRCMP return boolean(cmp > 0 || (cmp == 0 && a_len > b_len)); |
2765 | } |
2766 | BUILTIN(builtin_str_le) { |
2767 | STRCMP return boolean(cmp < 0 || (cmp == 0 && a_len <= b_len)); |
2768 | } |
2769 | BUILTIN(builtin_str_ge) { |
2770 | STRCMP return boolean(cmp > 0 || (cmp == 0 && a_len >= b_len)); |
2771 | } |
2772 | |
2773 | static int memcmp_ci(const void *s1, const void *s2, size_t n) { |
2774 | const uchar *b1 = s1, *b2 = s2; |
2775 | uchar c1, c2; |
2776 | size_t i; |
2777 | for (i = 0; i < n; i++) { |
2778 | c1 = lc(b1[i]); |
2779 | c2 = lc(b2[i]); |
2780 | if (c1 < c2) return -1; |
2781 | if (c1 > c2) return 1; |
2782 | } |
2783 | return 0; |
2784 | } |
2785 | |
2786 | BUILTIN(builtin_str_ci_eq) { |
2787 | STR2 |
2788 | if (a_len != b_len) return SC_FALSE; |
2789 | return boolean(memcmp_ci(a_buf, b_buf, a_len) == 0); |
2790 | } |
2791 | |
2792 | #define STRCMP_CI STR2 \ |
2793 | int cmp = memcmp_ci(a_buf, b_buf, (a_len < b_len) ? a_len : b_len); |
2794 | |
2795 | BUILTIN(builtin_str_ci_lt) { |
2796 | STRCMP_CI return boolean(cmp < 0 || (cmp == 0 && a_len < b_len)); |
2797 | } |
2798 | BUILTIN(builtin_str_ci_gt) { |
2799 | STRCMP_CI return boolean(cmp > 0 || (cmp == 0 && a_len > b_len)); |
2800 | } |
2801 | BUILTIN(builtin_str_ci_le) { |
2802 | STRCMP_CI return boolean(cmp < 0 || (cmp == 0 && a_len <= b_len)); |
2803 | } |
2804 | BUILTIN(builtin_str_ci_ge) { |
2805 | STRCMP_CI return boolean(cmp > 0 || (cmp == 0 && a_len >= b_len)); |
2806 | } |
2807 | |
2808 | BUILTIN(builtin_substr) { |
2809 | value len = string_len(R_EXPR = require_string(extract_arg(&args))), |
2810 | start = extract_arg(&args), end = final_arg(args), |
2811 | start_unsigned = safe_fixnum_val(start), |
2812 | end_unsigned = safe_fixnum_val(end); |
2813 | if (start_unsigned > len) sc_error1("start out of bounds:", start); |
2814 | if (end_unsigned > len) sc_error1("end out of bounds:", end); |
2815 | if (end_unsigned < start_unsigned) sc_error("end less than start"); |
2816 | len = end_unsigned - start_unsigned; |
2817 | R_RESULT = make_string_uninit(len); |
2818 | memcpy(string_buf(R_RESULT), string_buf(R_EXPR)+start_unsigned, len); |
2819 | return R_RESULT; |
2820 | } |
2821 | |
2822 | BUILTIN(builtin_str_append) { |
2823 | value p, s, len = 0; |
2824 | uchar *buf; |
2825 | R_ARGS = args; |
2826 | for (p = R_ARGS; p != SC_NULL; p = cdr(p)) { |
2827 | len += string_len(require_string(car(p))); |
2828 | if (len > EXT_LENGTH_MAX) sc_error("length too large for string"); |
2829 | } |
2830 | R_RESULT = make_string_uninit(len); |
2831 | buf = string_buf(R_RESULT); |
2832 | for (p = R_ARGS; p != SC_NULL; p = cdr(p)) { |
2833 | s = car(p); |
2834 | len = string_len(s); |
2835 | memcpy(buf, string_buf(s), len); |
2836 | buf += len; |
2837 | } |
2838 | return R_RESULT; |
2839 | } |
2840 | |
2841 | BUILTIN(builtin_list_to_str) { |
2842 | long len, i; |
2843 | value s; |
2844 | uchar *buf; |
2845 | R_ARGS = final_arg(args); |
2846 | len = safe_list_length(R_ARGS); |
2847 | if (len < 0) sc_error("not a list"); |
2848 | s = make_string_uninit(len); |
2849 | buf = string_buf(s); |
2850 | for (i = 0; i < len; i++) { |
2851 | buf[i] = safe_char_val(car(R_ARGS)); |
2852 | R_ARGS = cdr(R_ARGS); |
2853 | } |
2854 | return s; |
2855 | } |
2856 | |
2857 | BUILTIN(builtin_str_copy) { |
2858 | R_EXPR = require_string(final_arg(args)); |
2859 | return string_copy(); |
2860 | } |
2861 | |
2862 | BUILTIN(builtin_str_fill) { |
2863 | value s = require_mutable_string(extract_arg(&args)); |
2864 | memset(string_buf(s), safe_char_val(final_arg(args)), string_len(s)); |
2865 | return SC_NULL; |
2866 | } |
2867 | |
2868 | /* 6.3.6 Vectors */ |
2869 | |
2870 | BUILTIN(builtin_is_vector) { return boolean(is_vector(final_arg(args))); } |
2871 | |
2872 | BUILTIN(builtin_make_vector) { |
2873 | long len = safe_fixnum_val(extract_arg(&args)); |
2874 | R_EXPR = (args == SC_NULL) ? SC_NULL : final_arg(args); |
2875 | return make_vector(len); |
2876 | } |
2877 | |
2878 | BUILTIN(builtin_vec_length) { |
2879 | value vec = require_vector(final_arg(args)); |
2880 | return fixnum(vector_len(vec)); |
2881 | } |
2882 | |
2883 | BUILTIN(builtin_vec_ref) { |
2884 | value vec = require_vector(extract_arg(&args)); |
2885 | value k = final_arg(args); |
2886 | value k_unsigned = safe_fixnum_val(k); |
2887 | if (k_unsigned >= vector_len(vec)) sc_error1("out of bounds:", k); |
2888 | /* We don't need to also check for negative k: as value is an unsigned |
2889 | * type, the assignment from long causes a negative to be seen as a |
2890 | * positive greater than the longest allowed vector length. |
2891 | * XXX: are there weird machines where this isn't true? */ |
2892 | return vector_ref(vec, k_unsigned); |
2893 | } |
2894 | |
2895 | BUILTIN(builtin_vec_set) { |
2896 | value vec = require_mutable_vector(extract_arg(&args)); |
2897 | value k = extract_arg(&args); |
2898 | value obj = final_arg(args); |
2899 | value k_unsigned = safe_fixnum_val(k); |
2900 | if (k_unsigned >= vector_len(vec)) sc_error1("out of bounds:", k); |
2901 | vector_set(vec, k_unsigned, obj); |
2902 | return SC_NULL; |
2903 | } |
2904 | |
2905 | BUILTIN(builtin_list_to_vec) { |
2906 | long len; |
2907 | value vec, *p; |
2908 | R_ARGS = final_arg(args); |
2909 | len = safe_list_length(R_ARGS); |
2910 | if (len < 0) sc_error("not a list"); |
2911 | vec = make_vector_uninit(len); |
2912 | p = heap + untag(vec) + 1; |
2913 | for (; len; --len, ++p, R_ARGS = cdr(R_ARGS)) *p = car(R_ARGS); |
2914 | return vec; |
2915 | } |
2916 | |
2917 | BUILTIN(builtin_vec_fill) { |
2918 | value vec = require_mutable_vector(extract_arg(&args)); |
2919 | value fill = final_arg(args); |
2920 | value len = vector_len(vec), i; |
2921 | for (i = 0; i < len; i++) vector_set(vec, i, fill); |
2922 | return SC_NULL; |
2923 | } |
2924 | |
2925 | /* 6.4 Control features */ |
2926 | |
2927 | BUILTIN(builtin_is_procedure) { return boolean(is_procedure(final_arg(args))); } |
2928 | |
2929 | BUILTIN(builtin_force) { |
2930 | R_EXPR = final_arg(args); |
2931 | r_flag = f_force; |
2932 | return SC_NULL; |
2933 | } |
2934 | |
2935 | BUILTIN(builtin_call_cc) { |
2936 | R_PROC = require_procedure(final_arg(args)); |
2937 | R_CAR = current_continuation(); |
2938 | R_CDR = SC_NULL; |
2939 | R_ARGS = cons(); |
2940 | r_flag = f_apply; |
2941 | return SC_NULL; |
2942 | } |
2943 | |
2944 | BUILTIN(builtin_values) RETURN_VALUES(args) |
2945 | |
2946 | BUILTIN(builtin_call_with_values) { |
2947 | R_PROC = extract_arg(&args); |
2948 | R_ARGS = final_arg(args); |
2949 | r_flag = f_call_with_values; |
2950 | return SC_NULL; |
2951 | } |
2952 | |
2953 | /* 6.5 Eval */ |
2954 | |
2955 | BUILTIN(builtin_eval) { |
2956 | R_EXPR = extract_arg(&args); |
2957 | value e = final_arg(args); |
2958 | switch (e) { |
2959 | case SC_NULL_ENV: |
2960 | R_ENV = SC_NULL; break; |
2961 | case SC_REPORT_ENV: |
2962 | R_ENV = r5rs_env; break; |
2963 | case SC_GSCM_ENV: |
2964 | R_ENV = gscm_env; break; |
2965 | case SC_INTERACT_ENV: |
2966 | R_ENV = interaction_env; break; |
2967 | case SC_TOPLEVEL_ENV: |
2968 | R_ENV = toplevel_env; break; |
2969 | default: |
2970 | sc_error1("not an environment specifier:", e); |
2971 | } |
2972 | r_flag = f_compile; |
2973 | return SC_NULL; |
2974 | } |
2975 | |
2976 | BUILTIN(builtin_report_env) { |
2977 | if (safe_fixnum_val(final_arg(args)) != 5) |
2978 | sc_error("unsupported version"); |
2979 | return SC_REPORT_ENV; |
2980 | } |
2981 | BUILTIN(builtin_null_env) { |
2982 | if (safe_fixnum_val(final_arg(args)) != 5) |
2983 | sc_error("unsupported version"); |
2984 | return SC_NULL_ENV; |
2985 | } |
2986 | BUILTIN(builtin_interaction_env) { |
2987 | no_args(args); |
2988 | return SC_INTERACT_ENV; |
2989 | } |
2990 | |
2991 | /* 6.6.1 Ports */ |
2992 | |
2993 | BUILTIN(builtin_is_port) { |
2994 | return boolean(is_port(final_arg(args))); |
2995 | } |
2996 | BUILTIN(builtin_is_in_port) { |
2997 | return boolean(is_input_port(final_arg(args))); |
2998 | } |
2999 | BUILTIN(builtin_is_out_port) { |
3000 | return boolean(is_output_port(final_arg(args))); |
3001 | } |
3002 | |
3003 | BUILTIN(builtin_current_in_port) { no_args(args); return r_input_port; } |
3004 | BUILTIN(builtin_current_out_port) { no_args(args); return r_output_port; } |
3005 | |
3006 | BUILTIN(builtin_open_in_file) { |
3007 | int fd; |
3008 | R_EXPR = require_string(final_arg(args)); |
3009 | fd = open_cloexec(c_string_buf(string_append_null()), O_RDONLY); |
3010 | if (fd == -1) sc_perror1(R_EXPR); |
3011 | return make_port(fd, 0, DEFAULT_R_BUF); |
3012 | } |
3013 | |
3014 | BUILTIN(builtin_open_out_file) { |
3015 | int fd, flags = O_WRONLY | O_CREAT; |
3016 | value if_exists; |
3017 | R_EXPR = require_string(extract_arg(&args)); |
3018 | if (args == SC_NULL) if_exists = s_truncate; |
3019 | else if_exists = final_arg(args); |
3020 | |
3021 | if (if_exists == s_truncate) flags |= O_TRUNC; |
3022 | else if (if_exists == s_overwrite) ; |
3023 | else if (if_exists == s_append) flags |= O_APPEND; |
3024 | else sc_error("invalid if-exists option"); |
3025 | |
3026 | fd = open_cloexec(c_string_buf(string_append_null()), flags); |
3027 | if (fd == -1) sc_perror1(R_EXPR); |
3028 | return make_port(fd, 1, DEFAULT_W_BUF); |
3029 | } |
3030 | |
3031 | BUILTIN(builtin_close_in_port) { |
3032 | close_port(require_input_port(final_arg(args))); |
3033 | return SC_NULL; |
3034 | } |
3035 | |
3036 | BUILTIN(builtin_close_out_port) { |
3037 | close_port(require_output_port(final_arg(args))); |
3038 | return SC_NULL; |
3039 | } |
3040 | |
3041 | /* 6.6.2 Input */ |
3042 | |
3043 | BUILTIN(builtin_read_char) { return read_char(opt_final_in_port_arg(args)); } |
3044 | |
3045 | BUILTIN(builtin_peek_char) { return peek_char(opt_final_in_port_arg(args)); } |
3046 | |
3047 | BUILTIN(builtin_is_eof) { return boolean(final_arg(args) == SC_EOF); } |
3048 | |
3049 | BUILTIN(builtin_is_char_ready) { |
3050 | return input_port_ready(opt_final_in_port_arg(args)); |
3051 | } |
3052 | |
3053 | /* 6.6.3 Output */ |
3054 | |
3055 | BUILTIN(builtin_write_char) { |
3056 | uchar c = safe_char_val(extract_arg(&args)); |
3057 | R_PORT = opt_final_out_port_arg(args); |
3058 | write_char(c); |
3059 | return SC_NULL; |
3060 | } |
3061 | |
3062 | /* Gales Scheme extensions */ |
3063 | |
3064 | BUILTIN(builtin_gscm_env) { no_args(args); return SC_GSCM_ENV; } |
3065 | |
3066 | BUILTIN(builtin_is_immutable) { return boolean(!is_mutable(final_arg(args))); } |
3067 | |
3068 | BUILTIN(builtin_cons_immutable) { |
3069 | R_CAR = extract_arg(&args); |
3070 | R_CDR = final_arg(args); |
3071 | return cons_immutable(); |
3072 | } |
3073 | |
3074 | BUILTIN(builtin_str_copy_immutable) { |
3075 | R_EXPR = require_string(final_arg(args)); |
3076 | return string_copy_immutable(); |
3077 | } |
3078 | |
3079 | BUILTIN(builtin_vec_copy_immutable) { |
3080 | value len; |
3081 | R_EXPR = require_vector(final_arg(args)); |
3082 | len = vector_len(R_EXPR); |
3083 | R_RESULT = make_immutable_vector(len); |
3084 | memcpy(heap+untag(R_RESULT)+1, heap+untag(R_EXPR)+1, len*sizeof(value)); |
3085 | return R_RESULT; |
3086 | } |
3087 | |
3088 | BUILTIN(builtin_flush_out_port) { |
3089 | value port = require_output_port(args == SC_NULL ? r_output_port : |
3090 | extract_arg(&args)), *p = heap+untag(port); |
3091 | int fd = fixnum_val(p[PORT_FD]); |
3092 | if (fd == -1) sc_error("output port closed"); |
3093 | flush_if_needed(port); |
3094 | if (args != SC_NULL) { |
3095 | value opt = final_arg(args); |
3096 | if (opt == s_sync) { if (fsync(fd)) goto sync_err; } |
3097 | else if (opt == s_data_sync) { if (fdatasync(fd)) goto sync_err; } |
3098 | else sc_error1("invalid option:", opt); |
3099 | } |
3100 | return SC_NULL; |
3101 | sync_err: |
3102 | if (errno == EINVAL) sc_error("synchronization not possible"); |
3103 | else { |
3104 | /* As in flush_output_port: no good way to recover from output errors, |
3105 | * but the kernel won't necessarily continue returning errors, so close |
3106 | * the port. In practice, the mistake of retrying a failed fsync has |
3107 | * caused data loss in PostgreSQL (broken durability guarantee). */ |
3108 | int saved = errno; set_port_closed(p); errno = saved; |
3109 | sc_perror(); |
3110 | } |
3111 | } |
3112 | |
3113 | BUILTIN(builtin_gc) { |
3114 | no_args(args); |
3115 | sc_gc(); |
3116 | return fixnum(free_ptr); |
3117 | } |
3118 | |
3119 | BUILTIN(builtin_is_fixnum) { return boolean(is_fixnum(final_arg(args))); } |
3120 | |
3121 | BUILTIN(builtin_fx_eq) { |
3122 | value a = require_fixnum(extract_arg(&args)); |
3123 | return boolean(a == require_fixnum(final_arg(args))); |
3124 | } |
3125 | |
3126 | BUILTIN(builtin_fx_lt) { |
3127 | long a = safe_fixnum_val(extract_arg(&args)); |
3128 | return boolean(a < safe_fixnum_val(final_arg(args))); |
3129 | } |
3130 | |
3131 | BUILTIN(builtin_fx_le) { |
3132 | long a = safe_fixnum_val(extract_arg(&args)); |
3133 | return boolean(a <= safe_fixnum_val(final_arg(args))); |
3134 | } |
3135 | |
3136 | BUILTIN(builtin_fx_lt_unsigned) { |
3137 | value a = require_fixnum(extract_arg(&args)); |
3138 | return boolean(a < require_fixnum(final_arg(args))); |
3139 | } |
3140 | |
3141 | BUILTIN(builtin_fx_le_unsigned) { |
3142 | value a = require_fixnum(extract_arg(&args)); |
3143 | return boolean(a <= require_fixnum(final_arg(args))); |
3144 | } |
3145 | |
3146 | /* inputs left tagged: valid for wrapping and bitwise ops */ |
3147 | #define FXFOLD(op, init) { \ |
3148 | ulong acc = init; \ |
3149 | for (; args != SC_NULL; args = cdr(args)) \ |
3150 | acc = acc op require_fixnum(car(args)); \ |
3151 | return fixnum(acc); \ |
3152 | } |
3153 | |
3154 | BUILTIN(builtin_fx_add_wrap) FXFOLD(+, 0) |
3155 | |
3156 | BUILTIN(builtin_fx_add_carry) { |
3157 | long acc = untag_signed(require_fixnum(extract_arg(&args))); |
3158 | acc += untag_signed(require_fixnum(extract_arg(&args))); |
3159 | if (args != SC_NULL) acc += untag_signed(require_fixnum(final_arg(args))); |
3160 | R_CDR = SC_NULL; R_CAR = fixnum(acc >> VAL_BITS); /* high word (carry) */ |
3161 | R_CDR = cons(); R_CAR = fixnum(acc); /* low word */ |
3162 | RETURN_VALUES(cons()); |
3163 | } |
3164 | |
3165 | BUILTIN(builtin_fx_add_carry_unsigned) { |
3166 | ulong acc = untag(require_fixnum(extract_arg(&args))); |
3167 | acc += untag(require_fixnum(extract_arg(&args))); |
3168 | if (args != SC_NULL) acc += untag(require_fixnum(final_arg(args))); |
3169 | R_CDR = SC_NULL; R_CAR = fixnum(acc >> VAL_BITS); /* high word (carry) */ |
3170 | R_CDR = cons(); R_CAR = fixnum(acc); /* low word */ |
3171 | RETURN_VALUES(cons()); |
3172 | } |
3173 | |
3174 | BUILTIN(builtin_fx_sub_wrap) { |
3175 | ulong acc = require_fixnum(extract_arg(&args)); |
3176 | if (args == SC_NULL) return fixnum(-acc); |
3177 | do { |
3178 | acc -= require_fixnum(car(args)); |
3179 | args = cdr(args); |
3180 | } while (args != SC_NULL); |
3181 | return fixnum(acc); |
3182 | } |
3183 | |
3184 | BUILTIN(builtin_fx_sub_borrow_unsigned) { |
3185 | ulong acc = untag(require_fixnum(extract_arg(&args))); |
3186 | acc -= untag(require_fixnum(extract_arg(&args))); |
3187 | if (args != SC_NULL) acc -= untag(require_fixnum(final_arg(args))); |
3188 | R_CDR = SC_NULL; R_CAR = fixnum(-(((long)acc) >> VAL_BITS)); |
3189 | R_CDR = cons(); R_CAR = fixnum(acc); |
3190 | RETURN_VALUES(cons()); |
3191 | } |
3192 | |
3193 | BUILTIN(builtin_fx_mul_wrap) FXFOLD(*, 1) |
3194 | |
3195 | BUILTIN(builtin_fx_mul_carry) { |
3196 | ulong a = untag_signed(require_fixnum(extract_arg(&args))); |
3197 | ulong b = untag_signed(require_fixnum(final_arg(args))); |
3198 | sc_wide_mul_signed(&a, &b); |
3199 | R_CDR = SC_NULL; R_CAR = fixnum(b << TAG_BITS | tag(a)); /* high word */ |
3200 | R_CDR = cons(); R_CAR = fixnum(a); /* low word */ |
3201 | RETURN_VALUES(cons()); |
3202 | } |
3203 | |
3204 | BUILTIN(builtin_fx_mul_carry_unsigned) { |
3205 | ulong a = untag(require_fixnum(extract_arg(&args))); |
3206 | ulong b = untag(require_fixnum(final_arg(args))); |
3207 | sc_wide_mul(&a, &b); |
3208 | R_CDR = SC_NULL; R_CAR = fixnum(b << TAG_BITS | tag(a)); /* high word */ |
3209 | R_CDR = cons(); R_CAR = fixnum(a); /* low word */ |
3210 | RETURN_VALUES(cons()); |
3211 | } |
3212 | |
3213 | BUILTIN(builtin_fxnot) { |
3214 | return fixnum(~require_fixnum(final_arg(args))); |
3215 | } |
3216 | |
3217 | BUILTIN(builtin_fxand) FXFOLD(&, -1) |
3218 | BUILTIN(builtin_fxior) FXFOLD(|, 0) |
3219 | BUILTIN(builtin_fxxor) FXFOLD(^, 0) |
3220 | |
3221 | BUILTIN(builtin_fxif) { |
3222 | ulong mask = require_fixnum(extract_arg(&args)); |
3223 | ulong a = require_fixnum(extract_arg(&args)); |
3224 | ulong b = require_fixnum(final_arg(args)); |
3225 | return fixnum(b ^ (mask & (a ^ b))); |
3226 | /* equivalent to (mask & a) | (~mask & b) */ |
3227 | } |
3228 | |
3229 | BUILTIN(builtin_fxmaj) { |
3230 | ulong a = require_fixnum(extract_arg(&args)); |
3231 | ulong b = require_fixnum(extract_arg(&args)); |
3232 | ulong c = require_fixnum(final_arg(args)); |
3233 | return fixnum((a & (b | c)) | (b & c)); |
3234 | /* equivalent to (a & b) | (a & c) | (b & c) */ |
3235 | } |
3236 | |
3237 | BUILTIN(builtin_fxshift) { |
3238 | long a = untag_signed(require_fixnum(extract_arg(&args))); |
3239 | long bits = untag_signed(require_fixnum(final_arg(args))); |
3240 | if (bits < 0) { |
3241 | if (bits <= -VAL_BITS) bits = -VAL_BITS+1; |
3242 | a >>= -bits; |
3243 | } |
3244 | else { |
3245 | if (bits >= VAL_BITS) a = 0; |
3246 | else a <<= bits; |
3247 | } |
3248 | return fixnum(a); |
3249 | } |
3250 | |
3251 | BUILTIN(builtin_fxshift_unsigned) { |
3252 | ulong a = require_fixnum(extract_arg(&args)); |
3253 | long bits = untag_signed(require_fixnum(final_arg(args))); |
3254 | if (bits < 0) { |
3255 | if (bits <= -VAL_BITS) a = 0; |
3256 | else a = untag(a) >> -bits; |
3257 | } |
3258 | else { |
3259 | if (bits >= VAL_BITS) a = 0; |
3260 | else a <<= bits; |
3261 | } |
3262 | return fixnum(a); |
3263 | } |
3264 | |
3265 | BUILTIN(builtin_fxlength_unsigned) { |
3266 | /* TODO check existing interface alternatives */ |
3267 | return fixnum(sc_bit_length(untag(require_fixnum(final_arg(args))))); |
3268 | } |
3269 | |
3270 | /** (open-subprocess PROGRAM . ARGS) -> (values PID IN-PORT OUT-PORT) |
3271 | * |
3272 | * Executes PROGRAM in a Unix subprocess with the given arguments, returning |
3273 | * its process ID along with input and output ports piped to its standard |
3274 | * output and input streams respectively. Does not redirect standard error. By |
3275 | * convention, the first ARG should be the executable filename. |
3276 | * |
3277 | * This is intended to be fast and hygienic: it does not invoke the system |
3278 | * shell, perform a PATH search, pass through environment variables, or leak |
3279 | * file descriptors associated with ports previously opened in Scheme. |
3280 | * |
3281 | * Signals an error if a system-defined limit is reached, per fork(2) (or any |
3282 | * argument is not a string). |
3283 | * |
3284 | * The type of the returned PID is not specified, but must be composed of |
3285 | * standard types with unambiguous external representation. |
3286 | * |
3287 | * See also: wait-subprocess */ |
3288 | BUILTIN(builtin_open_subprocess) { |
3289 | value n_args = 0, i; |
3290 | char *path, **argv, *envp[] = {NULL}; |
3291 | pid_t pid; |
3292 | int out_pipe[2], in_pipe[2]; |
3293 | |
3294 | require_args(args); |
3295 | r1 = args; |
3296 | /* begin allocation: null-terminated strings and argv */ |
3297 | for (r2 = r1; r2 != SC_NULL; r2 = cdr(r2)) { |
3298 | R_EXPR = require_string(car(r2)); |
3299 | R_EXPR = string_append_null(); |
3300 | set_car(r2, R_EXPR); |
3301 | n_args++; |
3302 | } |
3303 | n_args--; /* program path not counted as argument */ |
3304 | /* Caution: allocating C blob on the Scheme heap. Must not be reachable |
3305 | * from the roots, which in turn excludes further allocation while it's in |
3306 | * use. */ |
3307 | argv = (void*)&heap[sc_malloc(n_args+1)]; |
3308 | /* end allocation */ |
3309 | path = c_string_buf(car(r1)); |
3310 | r1 = cdr(r1); /* program args */ |
3311 | for (i = 0; i < n_args; i++) { |
3312 | argv[i] = c_string_buf(car(r1)); |
3313 | r1 = cdr(r1); |
3314 | } |
3315 | argv[i] = NULL; |
3316 | |
3317 | if (pipe_cloexec(out_pipe)) goto err1; |
3318 | if (pipe_cloexec(in_pipe)) goto err2; |
3319 | /* Use vfork so child creation can be fast, and possible on non-overcommit |
3320 | * systems, even when parent is large. Any signal handlers must not corrupt |
3321 | * the parent if invoked in the child. See http://ewontfix.com/7/. */ |
3322 | if ((pid = vfork()) == -1) goto err3; |
3323 | if (!pid) { /* child */ |
3324 | while (dup2(out_pipe[0], 0) == -1) if (errno != EINTR) _exit(errno); |
3325 | while (dup2(in_pipe[1], 1) == -1) if (errno != EINTR) _exit(errno); |
3326 | execve(path, argv, envp); |
3327 | _exit(errno); |
3328 | } |
3329 | blind_close(out_pipe[0]); |
3330 | blind_close(in_pipe[1]); |
3331 | |
3332 | /* resume allocation */ |
3333 | R_CDR = SC_NULL; R_CAR = make_port(out_pipe[1], 1, DEFAULT_W_BUF); |
3334 | R_CDR = cons(); R_CAR = make_port(in_pipe[0], 0, DEFAULT_R_BUF); |
3335 | R_CDR = cons(); R_CAR = string(fmt_ulong_dec(pid)); |
3336 | /* ^ pid_t can't be guaranteed to fit in a fixnum, so stringify. I can't |
3337 | * quite decipher POSIX here but it seems safe to assume it fits in a long |
3338 | * and is positive on success. */ |
3339 | RETURN_VALUES(cons()); |
3340 | |
3341 | err3: |
3342 | blind_close(in_pipe[0]); |
3343 | blind_close(in_pipe[1]); |
3344 | err2: |
3345 | blind_close(out_pipe[0]); |
3346 | blind_close(out_pipe[1]); |
3347 | err1: |
3348 | sc_perror(); |
3349 | } |
3350 | |
3351 | /** (wait-subprocess [PID]) -> STATUS |
3352 | * |
3353 | * Blocks until a subprocess has terminated, releases the associated resources, |
3354 | * and returns either the nonnegative integer exit status for normal exit or |
3355 | * the negative signal number for termination by signal. |
3356 | * |
3357 | * PID identifies the process to wait for; it must compare "equal?" to a PID |
3358 | * previously returned by open-subprocess for which status has not yet been |
3359 | * retrieved. If omitted, any subprocess is waited for. */ |
3360 | BUILTIN(builtin_wait_subprocess) { |
3361 | int status; |
3362 | pid_t pid; |
3363 | if (args == SC_NULL) pid = -1; |
3364 | else { |
3365 | /* dedicated parser for stringified PIDs (see above), yuck */ |
3366 | value s = require_string(final_arg(args)); |
3367 | value len = string_len(s), i; |
3368 | const uchar *b = string_buf(s); |
3369 | ulong acc = 0; |
3370 | if (!len) goto invalid; |
3371 | for (i = 0; i < len; i++) { |
3372 | uchar digit = b[i] - '0'; |
3373 | if (digit > 9) goto invalid; |
3374 | if (acc > ULONG_MAX/10) goto invalid; |
3375 | acc *= 10; |
3376 | if (acc + digit < acc) goto invalid; |
3377 | acc += digit; |
3378 | } |
3379 | pid = acc; |
3380 | if ((ulong)pid != acc || pid < 0) goto invalid; |
3381 | goto start; |
3382 | invalid: |
3383 | sc_error1("invalid PID:", s); |
3384 | } |
3385 | start: |
3386 | if (waitpid(pid, &status, 0) == -1) { |
3387 | if (errno == EINTR) goto start; |
3388 | sc_perror(); |
3389 | } |
3390 | if (WIFEXITED(status)) return fixnum(WEXITSTATUS(status)); |
3391 | if (WIFSIGNALED(status)) return fixnum(-WTERMSIG(status)); |
3392 | sc_error("unknown status type"); /* shouldn't happen */ |
3393 | } |
3394 | |
3395 | BUILTIN(builtin_read_token) { |
3396 | R_PORT = opt_final_in_port_arg(args); |
3397 | switch (read_token()) { |
3398 | case tok_eof: return SC_EOF; |
3399 | case tok_literal: R_CAR = s_literal; break; |
3400 | case tok_open_paren: R_CAR = s_open_paren; break; |
3401 | case tok_close_paren: R_CAR = s_close_paren; break; |
3402 | case tok_dot: R_CAR = s_dot; break; |
3403 | case tok_open_vector: R_CAR = s_open_vector; break; |
3404 | case tok_identifier: R_CAR = s_identifier; break; |
3405 | case tok_named_char: R_CAR = s_named_char; break; |
3406 | case tok_abbrev: R_CAR = s_abbrev; break; |
3407 | case tok_number: R_CAR = s_number; break; |
3408 | } |
3409 | R_CDR = R_LEXEME; |
3410 | return cons(); |
3411 | } |
3412 | |
3413 | BUILTIN(builtin_write_string) { |
3414 | value s = extract_arg(&args); |
3415 | R_PORT = opt_final_out_port_arg(args); |
3416 | write_str(require_stringlike(s)); |
3417 | return SC_NULL; |
3418 | } |
3419 | |
3420 | BUILTIN(builtin_write_string_quoted) { |
3421 | value s = extract_arg(&args); |
3422 | R_PORT = opt_final_out_port_arg(args); |
3423 | write_str_quoted(require_stringlike(s)); |
3424 | return SC_NULL; |
3425 | } |
3426 | |
3427 | /* Private builtins exposed to the toplevel and compiler only */ |
3428 | |
3429 | #define assert_args(n) (assert(list_length(args) == (n))) |
3430 | |
3431 | /* Debug access to the privileged environment */ |
3432 | BUILTIN(builtin_toplevel_env) { no_args(args); return SC_TOPLEVEL_ENV; } |
3433 | |
3434 | /* (define-r5rs symbol obj) |
3435 | * |
3436 | * Binds a variable in the otherwise immutable (scheme-report-environment 5) |
3437 | * as well as the interaction environment. */ |
3438 | BUILTIN(builtin_define_r5rs) { |
3439 | R_CAR = R_VARNAME = require_symbol(extract_arg(&args)); |
3440 | R_CDR = R_EXPR = final_arg(args); |
3441 | assert(global_frame_lookup(R_CAR, car(r5rs_env)) == SC_FALSE); |
3442 | assert(global_frame_lookup(R_CAR, car(interaction_env)) == SC_FALSE); |
3443 | R_ENV = r5rs_env; |
3444 | extend_global_env(); |
3445 | |
3446 | R_CAR = R_VARNAME; |
3447 | R_CDR = R_EXPR; |
3448 | R_ENV = interaction_env; |
3449 | extend_global_env(); |
3450 | return SC_NULL; |
3451 | } |
3452 | |
3453 | /* (define-gscm symbol obj) |
3454 | * |
3455 | * Binds a variable in the otherwise immutable (gales-scheme-environment) as |
3456 | * well as the interaction environment. */ |
3457 | BUILTIN(builtin_define_gscm) { |
3458 | value binding; |
3459 | R_VARNAME = require_symbol(extract_arg(&args)); |
3460 | R_EXPR = final_arg(args); |
3461 | assert(global_frame_lookup(R_VARNAME, car(r5rs_env)) == SC_FALSE); |
3462 | |
3463 | /* need to be able to upgrade ERROR on startup */ |
3464 | binding = global_frame_lookup(R_VARNAME, car(gscm_env)); |
3465 | if (binding == SC_FALSE) { |
3466 | R_CAR = R_VARNAME; |
3467 | R_CDR = R_EXPR; |
3468 | R_ENV = gscm_env; |
3469 | extend_global_env(); |
3470 | } |
3471 | else set_cdr(binding, R_EXPR); |
3472 | |
3473 | binding = global_frame_lookup(R_VARNAME, car(interaction_env)); |
3474 | if (binding == SC_FALSE) { |
3475 | R_CAR = R_VARNAME; |
3476 | R_CDR = R_EXPR; |
3477 | R_ENV = interaction_env; |
3478 | extend_global_env(); |
3479 | } |
3480 | else set_cdr(binding, R_EXPR); |
3481 | return SC_NULL; |
3482 | } |
3483 | |
3484 | BUILTIN(builtin_set_in_port) { |
3485 | r_input_port = require_input_port(final_arg(args)); |
3486 | return SC_NULL; |
3487 | } |
3488 | |
3489 | BUILTIN(builtin_set_out_port) { |
3490 | r_output_port = require_output_port(final_arg(args)); |
3491 | return SC_NULL; |
3492 | } |
3493 | |
3494 | BUILTIN(builtin_push_winding) { |
3495 | err_context = "dynamic-wind"; |
3496 | R_CAR = args; |
3497 | require_procedure(extract_arg(&args)); |
3498 | set_cdr(R_CAR, require_procedure(final_arg(args))); |
3499 | R_CDR = r_spool; |
3500 | r_spool = cons(); |
3501 | return SC_NULL; |
3502 | } |
3503 | |
3504 | BUILTIN(builtin_variable_ref) { |
3505 | R_CAR = car(args); |
3506 | assert(cdr(args) == SC_NULL); |
3507 | return make_variable_ref(); |
3508 | } |
3509 | |
3510 | BUILTIN(builtin_apply_unchecked) { |
3511 | assert_args(2); |
3512 | R_PROC = car(args); |
3513 | R_ARGS = cadr(args); |
3514 | r_flag = f_apply; |
3515 | return SC_NULL; |
3516 | } |
3517 | |
3518 | BUILTIN(builtin_car_unchecked) { assert_args(1); return car(car(args)); } |
3519 | BUILTIN(builtin_cdr_unchecked) { assert_args(1); return cdr(car(args)); } |
3520 | BUILTIN(builtin_set_car_unchecked) { |
3521 | assert_args(2); set_car(car(args), cadr(args)); return SC_NULL; |
3522 | } |
3523 | BUILTIN(builtin_set_cdr_unchecked) { |
3524 | assert_args(2); set_cdr(car(args), cadr(args)); return SC_NULL; |
3525 | } |
3526 | |
3527 | BUILTIN(builtin_str_ref_unchecked) { |
3528 | assert_args(2); return character( |
3529 | string_buf(car(args))[fixnum_val(cadr(args))]); |
3530 | } |
3531 | BUILTIN(builtin_vec_ref_unchecked) { |
3532 | assert_args(2); return vector_ref(car(args), fixnum_val(cadr(args))); |
3533 | } |
3534 | |
3535 | BUILTIN(builtin_fx_add_unchecked) { |
3536 | assert_args(2); return fixnum(unsigned_fixnum_val(car(args)) + |
3537 | unsigned_fixnum_val(cadr(args))); |
3538 | } |
3539 | BUILTIN(builtin_fx_sub_unchecked) { |
3540 | assert_args(2); return fixnum(unsigned_fixnum_val(car(args)) - |
3541 | unsigned_fixnum_val(cadr(args))); |
3542 | } |
3543 | BUILTIN(builtin_fx_eq_unchecked) { |
3544 | assert_args(2); assert(is_fixnum(car(args)) && is_fixnum(cadr(args))); |
3545 | return boolean(car(args) == cadr(args)); |
3546 | } |
3547 | BUILTIN(builtin_fx_lt_unchecked) { |
3548 | assert_args(2); return boolean(fixnum_val(car(args)) < |
3549 | fixnum_val(cadr(args))); |
3550 | } |
3551 | BUILTIN(builtin_fx_le_unchecked) { |
3552 | assert_args(2); return boolean(fixnum_val(car(args)) <= |
3553 | fixnum_val(cadr(args))); |
3554 | } |
3555 | BUILTIN(builtin_fx_neg_unchecked) { |
3556 | assert_args(1); return fixnum(-fixnum_val(car(args))); |
3557 | } |
3558 | BUILTIN(builtin_is_fx_neg_unchecked) { |
3559 | assert_args(1); return boolean(fixnum_val(car(args)) < 0); |
3560 | } |
3561 | |
3562 | BUILTIN(builtin_fx_div_unsigned_unchecked) { |
3563 | /* unsigned as / and % are implementation-defined on negatives */ |
3564 | ulong a, b, q; |
3565 | assert_args(2); |
3566 | a = unsigned_fixnum_val(car(args)); |
3567 | b = unsigned_fixnum_val(cadr(args)); |
3568 | assert(b != 0); |
3569 | /* the compiler had better recognize this as one division... */ |
3570 | q = a/b; |
3571 | a = a%b; |
3572 | R_CDR = SC_NULL; R_CAR = fixnum(a); |
3573 | R_CDR = cons(); R_CAR = fixnum(q); |
3574 | RETURN_VALUES(cons()); |
3575 | } |
3576 | |
3577 | BUILTIN(builtin_fx_div_ext_unsigned_unchecked) { |
3578 | /* unsigned as / and % are implementation-defined on negatives */ |
3579 | ulong a_lo, a_hi, b; |
3580 | assert_args(3); |
3581 | a_lo = unsigned_fixnum_val(car(args)); args = cdr(args); |
3582 | a_hi = unsigned_fixnum_val(car(args)); args = cdr(args); |
3583 | b = unsigned_fixnum_val(car(args)); |
3584 | assert(b > a_hi); /* so quotient fits in fixnum */ |
3585 | a_lo |= a_hi << VAL_BITS; |
3586 | a_hi >>= TAG_BITS; |
3587 | sc_div_extended(&a_lo, &a_hi, b); |
3588 | R_CDR = SC_NULL; R_CAR = fixnum(a_lo); /* remainder */ |
3589 | R_CDR = cons(); R_CAR = fixnum(a_hi); /* quotient */ |
3590 | RETURN_VALUES(cons()); |
3591 | } |
3592 | |
3593 | BUILTIN(builtin_fixnum_to_dec_unchecked) { |
3594 | assert_args(1); return string(fmt_fixnum_dec(fixnum_val(car(args)))); |
3595 | } |
3596 | BUILTIN(builtin_fixnum_to_hex_unchecked) { |
3597 | assert_args(1); return string(fmt_fixnum_hex(fixnum_val(car(args)))); |
3598 | } |
3599 | BUILTIN(builtin_fixnum_to_oct_unchecked) { |
3600 | assert_args(1); return string(fmt_fixnum_oct(fixnum_val(car(args)))); |
3601 | } |
3602 | BUILTIN(builtin_fixnum_to_bin_unchecked) { |
3603 | assert_args(1); return string(fmt_fixnum_bin(fixnum_val(car(args)))); |
3604 | } |
3605 | BUILTIN(builtin_fixnum_to_bin_unsigned_unchecked) { |
3606 | assert_args(1); |
3607 | return string(fmt_ulong_bin(unsigned_fixnum_val(car(args)))); |
3608 | } |
3609 | BUILTIN(builtin_flonum_to_dec_unchecked) { |
3610 | assert_args(1); return string(fmt_flonum_dec(flonum_val(car(args)))); |
3611 | } |
3612 | |
3613 | /* Minimal error builtin to be replaced on startup, e.g. in case of compile |
3614 | * errors in the toplevel */ |
3615 | BUILTIN(builtin_error) { |
3616 | value msg = require_string(extract_arg(&args)); |
3617 | R_PORT = stdout_port; |
3618 | write_cstr("ERROR [startup]: "); |
3619 | write_str(msg); |
3620 | if (args != SC_NULL) { |
3621 | write_char(' '); |
3622 | R_EXPR = car(args); |
3623 | shallow_print(); |
3624 | } |
3625 | newline(); |
3626 | sc_exit(1); |
3627 | } |
3628 | |
3629 | BUILTIN(builtin_set_err_cont) { |
3630 | value h = final_arg(args); |
3631 | if (!is_continuation(h)) sc_error("not a continuation"); |
3632 | r_error_cont = h; |
3633 | return SC_NULL; |
3634 | } |
3635 | |
3636 | BUILTIN(builtin_socket_ports) { |
3637 | make_socket_ports(safe_fixnum_val(final_arg(args)), |
3638 | DEFAULT_R_BUF, DEFAULT_W_BUF); |
3639 | R_CDR = SC_NULL; R_CAR = r1; |
3640 | R_CDR = cons(); R_CAR = r0; |
3641 | RETURN_VALUES(cons()); |
3642 | } |
3643 | |
3644 | static union { |
3645 | struct sockaddr sa; |
3646 | struct sockaddr_in sin; |
3647 | struct sockaddr_un sun; |
3648 | } sa; |
3649 | |
3650 | static socklen_t sa_len; |
3651 | |
3652 | /* Fill sa/sa_len from a Scheme IPv4 address structure */ |
3653 | static void build_sockaddr_in(value addr) { |
3654 | value ip = require_vector(safe_car(addr)), |
3655 | port = safe_fixnum_val(safe_car(cdr(addr))), i, byte; |
3656 | uchar *port_buf = (uchar *)&sa.sin.sin_port, |
3657 | *addr_buf = (uchar *)&sa.sin.sin_addr; |
3658 | if (port > 65535) sc_error1("port number out of range:", car(cdr(addr))); |
3659 | memset(&sa.sin, 0, sizeof sa.sin); |
3660 | sa.sin.sin_family = AF_INET; |
3661 | port_buf[0] = port >> 8; |
3662 | port_buf[1] = port & 0xFF; |
3663 | if (vector_len(ip) != 4) sc_error("bad address length"); |
3664 | for (i = 0; i < 4; ++i) { |
3665 | byte = safe_fixnum_val(vector_ref(ip, i)); |
3666 | if (byte > 255) |
3667 | sc_error1("address byte out of range:", vector_ref(ip, i)); |
3668 | addr_buf[i] = byte; |
3669 | } |
3670 | sa_len = sizeof sa.sin; |
3671 | } |
3672 | |
3673 | /* Fill sa/sa_len from a Scheme Unix-domain address structure (string) */ |
3674 | static void build_sockaddr_un(value addr) { |
3675 | value path = require_string(addr), len = string_len(path), i; |
3676 | uchar *buf = string_buf(path); |
3677 | if (len > sizeof sa.sun.sun_path) sc_error("oversize pathname"); |
3678 | /* initial NUL allowed for Linux abstract sockets */ |
3679 | if (len && buf[0]) |
3680 | for (i = 1; i < len; i++) |
3681 | if (!buf[i]) sc_error("NUL byte in pathname"); |
3682 | memset(&sa.sun, 0, sizeof sa.sun); |
3683 | sa.sun.sun_family = AF_UNIX; |
3684 | memcpy(&sa.sun.sun_path, string_buf(path), len); |
3685 | sa_len = offsetof(struct sockaddr_un, sun_path) + len; |
3686 | } |
3687 | |
3688 | /* Construct immutable Scheme address structure from a struct sockaddr_* in |
3689 | * sa/sa_len. Side effects: R_CAR R_CDR */ |
3690 | static value parse_sockaddr(void) { |
3691 | if (sa.sa.sa_family == AF_INET) { |
3692 | int i; |
3693 | uchar *port_buf = (uchar *)&sa.sin.sin_port, |
3694 | *addr_buf = (uchar *)&sa.sin.sin_addr; |
3695 | R_CDR = SC_NULL; |
3696 | R_CAR = fixnum((port_buf[0] << 8) + port_buf[1]); |
3697 | R_CDR = cons_immutable(); |
3698 | R_CAR = make_immutable_vector(4); |
3699 | for (i = 0; i < 4; ++i) vector_set(R_CAR, i, fixnum(addr_buf[i])); |
3700 | return cons_immutable(); |
3701 | } |
3702 | else if (sa.sa.sa_family == AF_UNIX) { |
3703 | value path, path_len; |
3704 | if (sa_len > sizeof sa.sun) sc_error("oversize pathname?!"); |
3705 | /* XXX Linuxism; the data returned for unnamed sockets is unspecified |
3706 | * in the standards */ |
3707 | if (sa_len == sizeof(sa_family_t)) return SC_FALSE; |
3708 | /* Possible somewhere? */ |
3709 | if (sa_len <= offsetof(struct sockaddr_un, sun_path)) return SC_FALSE; |
3710 | path_len = sa_len - offsetof(struct sockaddr_un, sun_path); |
3711 | /* Some implementations are so rude as to append a trailing NUL and |
3712 | * include it in the length. But a singular NUL is a valid abstract |
3713 | * socket name on Linux. */ |
3714 | if (path_len > 1 && sa.sun.sun_path[0] && !sa.sun.sun_path[path_len-1]) |
3715 | --path_len; |
3716 | path = make_immutable_string(path_len); |
3717 | memcpy(string_buf(path), sa.sun.sun_path, path_len); |
3718 | return path; |
3719 | } |
3720 | sc_error("unknown address family"); |
3721 | } |
3722 | |
3723 | static value unbound_socket(int domain, int type) { |
3724 | return fixnum(chkp(socket(domain, type, 0))); |
3725 | } |
3726 | |
3727 | static value bound_socket(int domain, int type, int reuse) { |
3728 | int fd = chkp(socket(domain, type, 0)); |
3729 | if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof reuse) || |
3730 | bind(fd, &sa.sa, sa_len)) { |
3731 | blind_close(fd); |
3732 | sc_perror(); |
3733 | } |
3734 | return fixnum(fd); |
3735 | } |
3736 | |
3737 | BUILTIN(builtin_inet_stream_sock) { |
3738 | if (args != SC_NULL) { |
3739 | build_sockaddr_in(final_arg(args)); |
3740 | return bound_socket(AF_INET, SOCK_STREAM, 0); |
3741 | } |
3742 | return unbound_socket(AF_INET, SOCK_STREAM); |
3743 | } |
3744 | |
3745 | BUILTIN(builtin_inet_dgram_sock) { |
3746 | if (args != SC_NULL) { |
3747 | build_sockaddr_in(final_arg(args)); |
3748 | return bound_socket(AF_INET, SOCK_DGRAM, 0); |
3749 | } |
3750 | return unbound_socket(AF_INET, SOCK_DGRAM); |
3751 | } |
3752 | |
3753 | BUILTIN(builtin_unix_stream_sock) { |
3754 | if (args != SC_NULL) { |
3755 | build_sockaddr_un(final_arg(args)); |
3756 | return bound_socket(AF_UNIX, SOCK_STREAM, 0); |
3757 | } |
3758 | return unbound_socket(AF_UNIX, SOCK_STREAM); |
3759 | } |
3760 | |
3761 | BUILTIN(builtin_unix_dgram_sock) { |
3762 | if (args != SC_NULL) { |
3763 | build_sockaddr_un(final_arg(args)); |
3764 | return bound_socket(AF_UNIX, SOCK_DGRAM, 0); |
3765 | } |
3766 | return unbound_socket(AF_UNIX, SOCK_DGRAM); |
3767 | } |
3768 | |
3769 | BUILTIN(builtin_getsockname) { |
3770 | uint fd = safe_fixnum_val(final_arg(args)); |
3771 | sa_len = sizeof sa; |
3772 | chkp(getsockname(fd, &sa.sa, &sa_len)); |
3773 | return parse_sockaddr(); |
3774 | } |
3775 | |
3776 | BUILTIN(builtin_getpeername) { |
3777 | uint fd = safe_fixnum_val(final_arg(args)); |
3778 | sa_len = sizeof sa; |
3779 | chkp(getpeername(fd, &sa.sa, &sa_len)); |
3780 | return parse_sockaddr(); |
3781 | } |
3782 | |
3783 | BUILTIN(builtin_connect_inet) { |
3784 | uint fd = safe_fixnum_val(extract_arg(&args)); |
3785 | build_sockaddr_in(final_arg(args)); |
3786 | chkp(connect(fd, &sa.sa, sa_len)); |
3787 | return SC_NULL; |
3788 | } |
3789 | |
3790 | BUILTIN(builtin_connect_unix) { |
3791 | uint fd = safe_fixnum_val(extract_arg(&args)); |
3792 | build_sockaddr_un(final_arg(args)); |
3793 | chkp(connect(fd, &sa.sa, sa_len)); |
3794 | return SC_NULL; |
3795 | } |
3796 | |
3797 | BUILTIN(builtin_listen) { |
3798 | uint fd = safe_fixnum_val(extract_arg(&args)); |
3799 | long backlog = safe_fixnum_val(final_arg(args)); |
3800 | if (backlog < 0) sc_error("negative backlog"); |
3801 | if (backlog > INT_MAX) backlog = INT_MAX; |
3802 | chkp(listen(fd, backlog)); |
3803 | return SC_NULL; |
3804 | } |
3805 | |
3806 | BUILTIN(builtin_accept) { |
3807 | uint fd = safe_fixnum_val(final_arg(args)); |
3808 | return fixnum(chkp(accept(fd, 0, 0))); |
3809 | } |
3810 | |
3811 | BUILTIN(builtin_close) { |
3812 | chkp(close(safe_fixnum_val(final_arg(args)))); |
3813 | return SC_NULL; |
3814 | } |
3815 | |
3816 | BUILTIN(builtin_is_flonum) { return boolean(is_flonum(final_arg(args))); } |
3817 | |
3818 | /* NB: "if the value being converted is in the range of values that can be |
3819 | * represented but cannot be represented exactly, the result is either the |
3820 | * nearest higher or nearest lower value, chosen in an implementation-defined |
3821 | * manner." -C89 */ |
3822 | BUILTIN(builtin_flonum_unchecked) { |
3823 | assert_args(1); return flonum(fixnum_val(car(args))); |
3824 | } |
3825 | BUILTIN(builtin_flonum_unsigned_unchecked) { |
3826 | assert_args(1); return flonum(unsigned_fixnum_val(car(args))); |
3827 | } |
3828 | |
3829 | BUILTIN(builtin_flo_eq_unchecked) { |
3830 | assert_args(2); |
3831 | return boolean(flonum_val(car(args)) == flonum_val(cadr(args))); |
3832 | } |
3833 | BUILTIN(builtin_flo_lt_unchecked) { |
3834 | assert_args(2); |
3835 | return boolean(flonum_val(car(args)) < flonum_val(cadr(args))); |
3836 | } |
3837 | BUILTIN(builtin_flo_le_unchecked) { |
3838 | assert_args(2); |
3839 | return boolean(flonum_val(car(args)) <= flonum_val(cadr(args))); |
3840 | } |
3841 | BUILTIN(builtin_flo_neg_unchecked) { |
3842 | assert_args(1); return flonum(-flonum_val(car(args))); |
3843 | } |
3844 | BUILTIN(builtin_is_flo_neg_unchecked) { |
3845 | assert_args(1); return boolean(flonum_val(car(args)) < 0); |
3846 | } |
3847 | |
3848 | #define FLONUM_OP2(op) { \ |
3849 | assert_args(2); \ |
3850 | return flonum(flonum_val(car(args)) op flonum_val(cadr(args))); \ |
3851 | } |
3852 | |
3853 | BUILTIN(builtin_flo_add_unchecked) FLONUM_OP2(+) |
3854 | BUILTIN(builtin_flo_sub_unchecked) FLONUM_OP2(-) |
3855 | BUILTIN(builtin_flo_mul_unchecked) FLONUM_OP2(*) |
3856 | BUILTIN(builtin_flo_div_unchecked) FLONUM_OP2(/) |
3857 | |
3858 | BUILTIN(builtin_flo_quotient_unchecked) { |
3859 | assert_args(2); |
3860 | return flonum(trunc(flonum_val(car(args)) / flonum_val(cadr(args)))); |
3861 | } |
3862 | |
3863 | BUILTIN(builtin_flo_remainder_unchecked) { |
3864 | double a, b; |
3865 | assert_args(2); |
3866 | a = flonum_val(car(args)); |
3867 | b = flonum_val(cadr(args)); |
3868 | return flonum(a < 0 ? -fmod(-a, fabs(b)) : fmod(a, fabs(b))); |
3869 | } |
3870 | |
3871 | BUILTIN(builtin_frac_exp_unchecked) { |
3872 | int e; |
3873 | double frac; |
3874 | assert_args(1); |
3875 | frac = frexp(flonum_val(car(args)), &e); |
3876 | R_CDR = SC_NULL; R_CAR = fixnum(e); |
3877 | R_CDR = cons(); R_CAR = flonum(frac); |
3878 | RETURN_VALUES(cons()); |
3879 | } |
3880 | |
3881 | BUILTIN(builtin_load_exp_unchecked) { |
3882 | assert_args(2); |
3883 | return flonum(ldexp(flonum_val(car(args)), fixnum_val(cadr(args)))); |
3884 | } |
3885 | |
3886 | BUILTIN(builtin_is_inf_unchecked) { |
3887 | double d; |
3888 | assert_args(1); |
3889 | d = flonum_val(car(args)); |
3890 | return boolean(d == HUGE_VAL || d == -HUGE_VAL); |
3891 | } |
3892 | |
3893 | BUILTIN(builtin_flo_to_fix_unchecked) { |
3894 | double d; |
3895 | assert_args(1); |
3896 | d = flonum_val(car(args)); |
3897 | assert(fabs(d) <= (double)(1L << VAL_BITS)); |
3898 | /* ^ Catches overflow of double to long conversion, which is UB, though |
3899 | * not of long to fixnum (how tight the check can be made is not yet clear |
3900 | * to me.) */ |
3901 | return fixnum(d); |
3902 | } |
3903 | |
3904 | #define MATH_FUNC(f) { \ |
3905 | assert_args(1); return flonum(f(flonum_val(car(args)))); \ |
3906 | } |
3907 | BUILTIN(builtin_floor) MATH_FUNC(floor) |
3908 | BUILTIN(builtin_ceiling) MATH_FUNC(ceil) |
3909 | BUILTIN(builtin_truncate) MATH_FUNC(trunc) |
3910 | BUILTIN(builtin_round) MATH_FUNC(nearbyint) |
3911 | BUILTIN(builtin_exp) MATH_FUNC(exp) |
3912 | BUILTIN(builtin_log) MATH_FUNC(log) |
3913 | BUILTIN(builtin_sin) MATH_FUNC(sin) |
3914 | BUILTIN(builtin_cos) MATH_FUNC(cos) |
3915 | BUILTIN(builtin_tan) MATH_FUNC(tan) |
3916 | BUILTIN(builtin_asin) MATH_FUNC(asin) |
3917 | BUILTIN(builtin_acos) MATH_FUNC(acos) |
3918 | BUILTIN(builtin_atan) MATH_FUNC(atan) |
3919 | BUILTIN(builtin_atan2) { |
3920 | assert_args(2); |
3921 | return flonum(atan2(flonum_val(car(args)), flonum_val(cadr(args)))); |
3922 | } |
3923 | BUILTIN(builtin_sqrt) MATH_FUNC(sqrt) |
3924 | |
3925 | BUILTIN(builtin_rev_list_to_vec_unchecked) { |
3926 | assert_args(1); |
3927 | R_EXPR = car(args); |
3928 | return rev_list_to_vec(); |
3929 | } |
3930 | |
3931 | BUILTIN(builtin_is_builtin) { |
3932 | return boolean(is_builtin(final_arg(args))); |
3933 | } |
3934 | BUILTIN(builtin_builtin_name) { |
3935 | value b = final_arg(args); |
3936 | if (!is_builtin(b)) sc_error("not a builtin"); |
3937 | return string(builtin_name(b)); |
3938 | } |
3939 | BUILTIN(builtin_is_promise) { |
3940 | return boolean(is_promise(final_arg(args))); |
3941 | } |
3942 | BUILTIN(builtin_is_continuation) { |
3943 | return boolean(is_continuation(final_arg(args))); |
3944 | } |
3945 | |
3946 | BUILTIN(builtin_make_bignum) { |
3947 | assert_args(1); |
3948 | /* Returning uninitialized is safe for the garbage collector: bignums are |
3949 | * not scanned internally, though the words do keep their fixnum tags. Of |
3950 | * course, used memory is still being exposed; the privileged bignum |
3951 | * library is responsible for fully initializing or truncating. */ |
3952 | return make_bignum_uninit(fixnum_val(car(args)), 0); |
3953 | } |
3954 | BUILTIN(builtin_is_bignum) { |
3955 | assert_args(1); return boolean(is_bignum(car(args))); |
3956 | } |
3957 | BUILTIN(builtin_is_bignum_negative) { |
3958 | assert_args(1); return boolean(is_bignum_negative(car(args))); |
3959 | } |
3960 | BUILTIN(builtin_bignum_set_negative) { |
3961 | assert_args(1); return bignum_set_negative(car(args)); |
3962 | } |
3963 | BUILTIN(builtin_bignum_ref) { |
3964 | assert_args(2); return bignum_ref(car(args), fixnum_val(cadr(args))); |
3965 | } |
3966 | BUILTIN(builtin_bignum_set) { |
3967 | value bn; |
3968 | assert_args(3); |
3969 | bn = car(args); args = cdr(args); |
3970 | bignum_set(bn, fixnum_val(car(args)), cadr(args)); |
3971 | return SC_NULL; |
3972 | } |
3973 | BUILTIN(builtin_bignum_length) { |
3974 | assert_args(1); return fixnum(bignum_len(car(args))); |
3975 | } |
3976 | BUILTIN(builtin_bignum_truncate) { |
3977 | assert_args(2); return bignum_truncate(car(args), fixnum_val(cadr(args))); |
3978 | } |
3979 | |
3980 | /* Construct bignum from signed fixnum, not demoting. */ |
3981 | BUILTIN(builtin_bignum) { |
3982 | value bn, word, word_sign_bit, word_sign_ext; |
3983 | assert_args(1); |
3984 | /* branch-free conversion from two's complement to sign-magnitude */ |
3985 | word = fixnum_val(car(args)); |
3986 | word_sign_bit = word >> ((8*sizeof word)-1); |
3987 | word_sign_ext = ((long)word) >> ((8*sizeof word)-1); |
3988 | word = (word ^ word_sign_ext) + word_sign_bit; |
3989 | bn = make_bignum_uninit(1, word_sign_bit); |
3990 | bignum_set(bn, 0, fixnum(word)); |
3991 | return bn; |
3992 | } |
3993 | |
3994 | /* Construct bignum from unsigned fixnum, not demoting. */ |
3995 | BUILTIN(builtin_bignum_unsigned) { |
3996 | value bn, word; |
3997 | assert_args(1); |
3998 | word = car(args); |
3999 | bn = make_bignum_uninit(1, 0); |
4000 | bignum_set(bn, 0, word); |
4001 | return bn; |
4002 | } |
4003 | |
4004 | /* Construct bignum from 2-word signed quantity, normalizing and demoting to |
4005 | * fixnum when possible. */ |
4006 | BUILTIN(builtin_bignum2) { |
4007 | value bn; |
4008 | long lo, hi; |
4009 | int neg = 0; |
4010 | assert_args(2); |
4011 | lo = fixnum_val(car(args)); |
4012 | hi = fixnum_val(cadr(args)); |
4013 | /* in signed fixnum range if high word is sign extension of low */ |
4014 | if (lo >> (VAL_BITS - 1) == hi) return fixnum(lo); |
4015 | if (hi < 0) { |
4016 | /* convert from two's complement to sign-magnitude */ |
4017 | neg = 1; |
4018 | /* capture carry bit in the tag by setting it to all ones prior to |
4019 | * complement */ |
4020 | lo = -(lo | (-1L << VAL_BITS)); |
4021 | hi = ~(ulong)hi + (((ulong)lo) >> VAL_BITS); |
4022 | } |
4023 | if (hi == 0) { |
4024 | /* need to drop high word to normalize */ |
4025 | bn = make_bignum_uninit(1, neg); |
4026 | bignum_set(bn, 0, fixnum(lo)); |
4027 | } |
4028 | else { |
4029 | /* both words significant */ |
4030 | bn = make_bignum_uninit(2, neg); |
4031 | bignum_set(bn, 0, fixnum(lo)); |
4032 | bignum_set(bn, 1, fixnum(hi)); |
4033 | } |
4034 | return bn; |
4035 | } |
4036 | |
4037 | |
4038 | /**************** |
4039 | * Initialization |
4040 | */ |
4041 | |
4042 | /* Construct a builtin and define it in the top frame of R_ENV. |
4043 | * Side effects: R_CAR R_CDR */ |
4044 | static void add_builtin(const char *name, builtin_func_t func) { |
4045 | R_CAR = symbol(name); |
4046 | R_CDR = builtin(name, func); |
4047 | assert(global_frame_lookup(R_CAR, car(R_ENV)) == SC_FALSE); |
4048 | extend_global_env(); |
4049 | } |
4050 | |
4051 | /* Define a variable in the top frame of R_ENV. |
4052 | * Side effects: R_EXPR R_CAR R_CDR */ |
4053 | static void add_variable(const char *name, value val) { |
4054 | R_EXPR = val; |
4055 | R_CAR = symbol(name); |
4056 | R_CDR = R_EXPR; |
4057 | assert(global_frame_lookup(R_CAR, car(R_ENV)) == SC_FALSE); |
4058 | extend_global_env(); |
4059 | } |
4060 | |
4061 | /* Side effects: R_RESULT */ |
4062 | static value open_lib_file(const char *filename) { |
4063 | int fd = open_cloexec(filename, O_RDONLY); |
4064 | if (fd == -1) fatal1(filename, strerror(errno)); |
4065 | return make_port(fd, 0, DEFAULT_R_BUF); |
4066 | } |
4067 | |
4068 | uint sc_hugepages; |
4069 | |
4070 | void sc_init(value heap_alloc) { |
4071 | int mflags; |
4072 | assert(sizeof(value) == __SIZEOF_POINTER__); |
4073 | assert(sizeof(value) == sizeof(ulong)); |
4074 | |
4075 | mflags = MAP_PRIVATE | MAP_ANON; |
4076 | if (sc_hugepages) { |
4077 | #ifdef MAP_HUGETLB |
4078 | mflags |= MAP_HUGETLB; |
4079 | #else |
4080 | fatal("huge pages not supported"); |
4081 | #endif |
4082 | } |
4083 | heap = mmap(NULL, heap_alloc, PROT_READ | PROT_WRITE, mflags, -1, 0); |
4084 | if (heap == MAP_FAILED) fatal1("failed to map heap", strerror(errno)); |
4085 | heap_size = heap_alloc / sizeof(value) / 2; |
4086 | new_heap = heap + heap_size; |
4087 | |
4088 | gc_root(&r0); |
4089 | gc_root(&r1); |
4090 | gc_root(&r2); |
4091 | gc_root(&r3); |
4092 | gc_root(&r4); |
4093 | gc_root(&r5); |
4094 | gc_root(&r6); |
4095 | gc_root(&r_stack); |
4096 | gc_root(&r_spool); |
4097 | gc_root(&r_error_cont); |
4098 | gc_root(&r_signal_handler); |
4099 | gc_root(&r_compiler); |
4100 | gc_root(&r_compiler_expr); |
4101 | gc_root(&r_input_port); |
4102 | gc_root(&r_output_port); |
4103 | gc_root(&r_dump); |
4104 | gc_root(&stdin_port); |
4105 | gc_root(&stdout_port); |
4106 | gc_root(&symbols); |
4107 | gc_root(&s_lambda); |
4108 | gc_root(&s_quote); |
4109 | gc_root(&s_quasiquote); |
4110 | gc_root(&s_unquote); |
4111 | gc_root(&s_unquote_splicing); |
4112 | gc_root(&s_if); |
4113 | gc_root(&s_set); |
4114 | gc_root(&s_begin); |
4115 | gc_root(&s_letrec); |
4116 | gc_root(&s_define); |
4117 | gc_root(&s_delay); |
4118 | gc_root(&s_literal); |
4119 | gc_root(&s_open_paren); |
4120 | gc_root(&s_close_paren); |
4121 | gc_root(&s_dot); |
4122 | gc_root(&s_open_vector); |
4123 | gc_root(&s_identifier); |
4124 | gc_root(&s_named_char); |
4125 | gc_root(&s_abbrev); |
4126 | gc_root(&s_number); |
4127 | gc_root(&s_truncate); |
4128 | gc_root(&s_overwrite); |
4129 | gc_root(&s_append); |
4130 | gc_root(&s_sync); |
4131 | gc_root(&s_data_sync); |
4132 | gc_root(&r5rs_env); |
4133 | gc_root(&gscm_env); |
4134 | gc_root(&interaction_env); |
4135 | gc_root(&toplevel_env); |
4136 | |
4137 | r_input_port = stdin_port = make_port(0, 0, DEFAULT_R_BUF); |
4138 | r_output_port = stdout_port = make_port(1, 1, DEFAULT_W_BUF); |
4139 | stdout_ready = 1; |
4140 | fixnum_zero = fixnum(0); |
4141 | fixnum_one = fixnum(1); |
4142 | |
4143 | s_lambda = symbol("lambda"); |
4144 | s_quote = symbol("quote"); |
4145 | s_quasiquote = symbol("quasiquote"); |
4146 | s_unquote = symbol("unquote"); |
4147 | s_unquote_splicing = symbol("unquote-splicing"); |
4148 | s_if = symbol("if"); |
4149 | s_set = symbol("set!"); |
4150 | s_begin = symbol("begin"); |
4151 | s_letrec = symbol("letrec"); |
4152 | s_define = symbol("define"); |
4153 | s_delay = symbol("delay"); |
4154 | s_literal = symbol("literal"); |
4155 | s_open_paren = symbol("open-paren"); |
4156 | s_close_paren = symbol("close-paren"); |
4157 | s_dot = symbol("dot"); |
4158 | s_open_vector = symbol("open-vector"); |
4159 | s_identifier = symbol("identifier"); |
4160 | s_named_char = symbol("named-char"); |
4161 | s_abbrev = symbol("abbrev"); |
4162 | s_number = symbol("number"); |
4163 | s_truncate = symbol("truncate"); |
4164 | s_overwrite = symbol("overwrite"); |
4165 | s_append = symbol("append"); |
4166 | s_sync = symbol("sync"); |
4167 | s_data_sync = symbol("data-sync"); |
4168 | |
4169 | R_CAR = R_CDR = SC_NULL; |
4170 | R_ENV = r5rs_env = cons(); |
4171 | add_builtin("eq?", builtin_is_eq); |
4172 | add_builtin("number?", builtin_is_number); |
4173 | add_builtin("complex?", builtin_is_number); |
4174 | add_builtin("real?", builtin_is_number); |
4175 | add_builtin("rational?", builtin_is_number); |
4176 | add_builtin("integer?", builtin_is_integer); |
4177 | add_builtin("exact?", builtin_is_exact); |
4178 | add_builtin("inexact?", builtin_is_inexact); |
4179 | add_builtin("not", builtin_not); |
4180 | add_builtin("boolean?", builtin_is_boolean); |
4181 | add_builtin("pair?", builtin_is_pair); |
4182 | add_builtin("cons", builtin_cons); |
4183 | add_builtin("car", builtin_car); |
4184 | add_builtin("cdr", builtin_cdr); |
4185 | add_builtin("caar", builtin_caar); |
4186 | add_builtin("cadr", builtin_cadr); |
4187 | add_builtin("cdar", builtin_cdar); |
4188 | add_builtin("cddr", builtin_cddr); |
4189 | add_builtin("caaar", builtin_caaar); |
4190 | add_builtin("caadr", builtin_caadr); |
4191 | add_builtin("cadar", builtin_cadar); |
4192 | add_builtin("caddr", builtin_caddr); |
4193 | add_builtin("cdaar", builtin_cdaar); |
4194 | add_builtin("cdadr", builtin_cdadr); |
4195 | add_builtin("cddar", builtin_cddar); |
4196 | add_builtin("cdddr", builtin_cdddr); |
4197 | add_builtin("caaaar", builtin_caaaar); |
4198 | add_builtin("caaadr", builtin_caaadr); |
4199 | add_builtin("caadar", builtin_caadar); |
4200 | add_builtin("caaddr", builtin_caaddr); |
4201 | add_builtin("cadaar", builtin_cadaar); |
4202 | add_builtin("cadadr", builtin_cadadr); |
4203 | add_builtin("caddar", builtin_caddar); |
4204 | add_builtin("cadddr", builtin_cadddr); |
4205 | add_builtin("cdaaar", builtin_cdaaar); |
4206 | add_builtin("cdaadr", builtin_cdaadr); |
4207 | add_builtin("cdadar", builtin_cdadar); |
4208 | add_builtin("cdaddr", builtin_cdaddr); |
4209 | add_builtin("cddaar", builtin_cddaar); |
4210 | add_builtin("cddadr", builtin_cddadr); |
4211 | add_builtin("cdddar", builtin_cdddar); |
4212 | add_builtin("cddddr", builtin_cddddr); |
4213 | add_builtin("set-car!", builtin_set_car); |
4214 | add_builtin("set-cdr!", builtin_set_cdr); |
4215 | add_builtin("null?", builtin_is_null); |
4216 | add_builtin("list?", builtin_is_list); |
4217 | add_builtin("length", builtin_length); |
4218 | add_builtin("symbol?", builtin_is_symbol); |
4219 | add_builtin("symbol->string", builtin_sym_to_str); |
4220 | add_builtin("string->symbol", builtin_str_to_sym); |
4221 | add_builtin("char?", builtin_is_char); |
4222 | add_builtin("char=?", builtin_char_eq); |
4223 | add_builtin("char<?", builtin_char_lt); |
4224 | add_builtin("char>?", builtin_char_gt); |
4225 | add_builtin("char<=?", builtin_char_le); |
4226 | add_builtin("char>=?", builtin_char_ge); |
4227 | add_builtin("char-ci=?", builtin_char_ci_eq); |
4228 | add_builtin("char-ci<?", builtin_char_ci_lt); |
4229 | add_builtin("char-ci>?", builtin_char_ci_gt); |
4230 | add_builtin("char-ci<=?", builtin_char_ci_le); |
4231 | add_builtin("char-ci>=?", builtin_char_ci_ge); |
4232 | add_builtin("char-alphabetic?", builtin_char_is_alpha); |
4233 | add_builtin("char-numeric?", builtin_char_is_num); |
4234 | add_builtin("char-whitespace?", builtin_char_is_white); |
4235 | add_builtin("char-upper-case?", builtin_char_is_upper); |
4236 | add_builtin("char-lower-case?", builtin_char_is_lower); |
4237 | add_builtin("char->integer", builtin_char_to_int); |
4238 | add_builtin("integer->char", builtin_int_to_char); |
4239 | add_builtin("char-upcase", builtin_char_upcase); |
4240 | add_builtin("char-downcase", builtin_char_downcase); |
4241 | add_builtin("string?", builtin_is_str); |
4242 | add_builtin("make-string", builtin_make_str); |
4243 | add_builtin("string-length",builtin_str_length); |
4244 | add_builtin("string-ref", builtin_str_ref); |
4245 | add_builtin("string-set!", builtin_str_set); |
4246 | add_builtin("string=?", builtin_str_eq); |
4247 | add_builtin("string<?", builtin_str_lt); |
4248 | add_builtin("string>?", builtin_str_gt); |
4249 | add_builtin("string<=?", builtin_str_le); |
4250 | add_builtin("string>=?", builtin_str_ge); |
4251 | add_builtin("string-ci=?", builtin_str_ci_eq); |
4252 | add_builtin("string-ci<?", builtin_str_ci_lt); |
4253 | add_builtin("string-ci>?", builtin_str_ci_gt); |
4254 | add_builtin("string-ci<=?", builtin_str_ci_le); |
4255 | add_builtin("string-ci>=?", builtin_str_ci_ge); |
4256 | add_builtin("substring", builtin_substr); |
4257 | add_builtin("string-append",builtin_str_append); |
4258 | add_builtin("list->string", builtin_list_to_str); |
4259 | add_builtin("string-copy", builtin_str_copy); |
4260 | add_builtin("string-fill!", builtin_str_fill); |
4261 | add_builtin("vector?", builtin_is_vector); |
4262 | add_builtin("make-vector", builtin_make_vector); |
4263 | add_builtin("vector-length",builtin_vec_length); |
4264 | add_builtin("vector-ref", builtin_vec_ref); |
4265 | add_builtin("vector-set!", builtin_vec_set); |
4266 | add_builtin("list->vector", builtin_list_to_vec); |
4267 | add_builtin("vector-fill!", builtin_vec_fill); |
4268 | add_builtin("procedure?", builtin_is_procedure); |
4269 | add_builtin("force", builtin_force); |
4270 | add_builtin("call-with-current-continuation", builtin_call_cc); |
4271 | add_builtin("call/cc", builtin_call_cc); |
4272 | add_builtin("values", builtin_values); |
4273 | add_builtin("call-with-values", builtin_call_with_values); |
4274 | add_builtin("eval", builtin_eval); |
4275 | add_builtin("scheme-report-environment", builtin_report_env); |
4276 | add_builtin("null-environment", builtin_null_env); |
4277 | add_builtin("interaction-environment", builtin_interaction_env); |
4278 | add_builtin("port?", builtin_is_port); |
4279 | add_builtin("input-port?", builtin_is_in_port); |
4280 | add_builtin("output-port?", builtin_is_out_port); |
4281 | add_builtin("current-input-port", builtin_current_in_port); |
4282 | add_builtin("current-output-port", builtin_current_out_port); |
4283 | add_builtin("open-input-file", builtin_open_in_file); |
4284 | add_builtin("open-output-file", builtin_open_out_file); |
4285 | add_builtin("close-input-port", builtin_close_in_port); |
4286 | add_builtin("close-output-port", builtin_close_out_port); |
4287 | add_builtin("read-char", builtin_read_char); |
4288 | add_builtin("peek-char", builtin_peek_char); |
4289 | add_builtin("eof-object?", builtin_is_eof); |
4290 | add_builtin("char-ready?", builtin_is_char_ready); |
4291 | add_builtin("write-char", builtin_write_char); |
4292 | |
4293 | /* Immutable environment for extensions */ |
4294 | R_CAR = SC_NULL; R_CDR = r5rs_env; |
4295 | R_ENV = gscm_env = cons(); |
4296 | add_builtin("gales-scheme-environment", builtin_gscm_env); |
4297 | add_builtin("immutable?", builtin_is_immutable); |
4298 | add_builtin("cons/immutable", builtin_cons_immutable); |
4299 | add_builtin("string-copy/immutable", builtin_str_copy_immutable); |
4300 | add_builtin("vector-copy/immutable", builtin_vec_copy_immutable); |
4301 | add_builtin("flush-output-port", builtin_flush_out_port); |
4302 | add_builtin("error", builtin_error); |
4303 | add_builtin("gc", builtin_gc); |
4304 | add_variable("*fixnum-width*", fixnum(VAL_BITS)); |
4305 | add_variable("*greatest-fixnum*", fixnum(FIXNUM_MAX)); |
4306 | add_variable("*least-fixnum*", fixnum(FIXNUM_MIN)); |
4307 | add_builtin("fixnum?", builtin_is_fixnum); |
4308 | add_builtin("fx=", builtin_fx_eq); |
4309 | add_builtin("fx<", builtin_fx_lt); |
4310 | add_builtin("fx<=", builtin_fx_le); |
4311 | add_builtin("fx</unsigned", builtin_fx_lt_unsigned); |
4312 | add_builtin("fx<=/unsigned", builtin_fx_le_unsigned); |
4313 | add_builtin("fx+/wrap", builtin_fx_add_wrap); |
4314 | add_builtin("fx+/carry", builtin_fx_add_carry); |
4315 | add_builtin("fx+/carry-unsigned", builtin_fx_add_carry_unsigned); |
4316 | add_builtin("fx-/wrap", builtin_fx_sub_wrap); |
4317 | add_builtin("fx-/borrow-unsigned", builtin_fx_sub_borrow_unsigned); |
4318 | add_builtin("fx*/wrap", builtin_fx_mul_wrap); |
4319 | add_builtin("fx*/carry", builtin_fx_mul_carry); |
4320 | add_builtin("fx*/carry-unsigned", builtin_fx_mul_carry_unsigned); |
4321 | add_builtin("fxnot", builtin_fxnot); |
4322 | add_builtin("fxand", builtin_fxand); |
4323 | add_builtin("fxior", builtin_fxior); |
4324 | add_builtin("fxxor", builtin_fxxor); |
4325 | add_builtin("fxif", builtin_fxif); |
4326 | add_builtin("fxmaj", builtin_fxmaj); |
4327 | add_builtin("fxshift", builtin_fxshift); |
4328 | add_builtin("fxshift/unsigned", builtin_fxshift_unsigned); |
4329 | add_builtin("fxlength/unsigned", builtin_fxlength_unsigned); |
4330 | add_builtin("open-subprocess", builtin_open_subprocess); |
4331 | add_builtin("wait-subprocess", builtin_wait_subprocess); |
4332 | add_builtin("read-token", builtin_read_token); |
4333 | add_builtin("write-string", builtin_write_string); |
4334 | add_builtin("write-string/quoted", builtin_write_string_quoted); |
4335 | |
4336 | /* The interaction environment is a mutable copy of the Scheme report |
4337 | * environment plus extensions */ |
4338 | R_EXPR = car(r5rs_env); |
4339 | R_CAR = copy_global_frame(); R_CDR = SC_NULL; |
4340 | interaction_env = cons(); |
4341 | /* XXX there's probably no reason for these to be separate frames */ |
4342 | R_EXPR = car(gscm_env); |
4343 | R_CAR = copy_global_frame(); R_CDR = interaction_env; |
4344 | interaction_env = cons(); |
4345 | |
4346 | /* Privileged environment for the compiler and toplevel code */ |
4347 | R_CAR = SC_NULL; R_CDR = gscm_env; |
4348 | R_ENV = toplevel_env = cons(); |
4349 | add_builtin("toplevel-environment", builtin_toplevel_env); |
4350 | add_variable("*max-parameters*", fixnum(EXT_LENGTH_MAX >> 1)); |
4351 | /* ^ sign-encoded arity must fit in procedure header; frame index must fit |
4352 | * in variable ref header */ |
4353 | add_builtin("define-r5rs", builtin_define_r5rs); |
4354 | add_builtin("define-gscm", builtin_define_gscm); |
4355 | add_builtin("set-input-port!", builtin_set_in_port); |
4356 | add_builtin("set-output-port!", builtin_set_out_port); |
4357 | add_builtin("push-winding!", builtin_push_winding); |
4358 | add_builtin("variable-ref", builtin_variable_ref); |
4359 | add_builtin("apply/unchecked", builtin_apply_unchecked); |
4360 | add_builtin("car/unchecked", builtin_car_unchecked); |
4361 | add_builtin("cdr/unchecked", builtin_cdr_unchecked); |
4362 | add_builtin("set-car/unchecked!", builtin_set_car_unchecked); |
4363 | add_builtin("set-cdr/unchecked!", builtin_set_cdr_unchecked); |
4364 | add_builtin("string-ref/unchecked", builtin_str_ref_unchecked); |
4365 | add_builtin("vector-ref/unchecked", builtin_vec_ref_unchecked); |
4366 | add_builtin("fx+/unchecked", builtin_fx_add_unchecked); |
4367 | add_builtin("fx-/unchecked", builtin_fx_sub_unchecked); |
4368 | add_builtin("fx=/unchecked", builtin_fx_eq_unchecked); |
4369 | add_builtin("fx</unchecked", builtin_fx_lt_unchecked); |
4370 | add_builtin("fx<=/unchecked", builtin_fx_le_unchecked); |
4371 | add_builtin("fxneg/unchecked", builtin_fx_neg_unchecked); |
4372 | add_builtin("fxnegative/unchecked?", builtin_is_fx_neg_unchecked); |
4373 | add_builtin("fxdiv/unsigned/unchecked", builtin_fx_div_unsigned_unchecked); |
4374 | add_builtin("fxdiv/ext/unsigned/unchecked", |
4375 | builtin_fx_div_ext_unsigned_unchecked); |
4376 | add_builtin("fixnum->dec/unchecked", builtin_fixnum_to_dec_unchecked); |
4377 | add_builtin("fixnum->hex/unchecked", builtin_fixnum_to_hex_unchecked); |
4378 | add_builtin("fixnum->oct/unchecked", builtin_fixnum_to_oct_unchecked); |
4379 | add_builtin("fixnum->bin/unchecked", builtin_fixnum_to_bin_unchecked); |
4380 | add_builtin("fixnum->bin/unsigned/unchecked", |
4381 | builtin_fixnum_to_bin_unsigned_unchecked); |
4382 | add_builtin("flonum->dec/unchecked", builtin_flonum_to_dec_unchecked); |
4383 | add_builtin("set-error-continuation!", builtin_set_err_cont); |
4384 | add_builtin("inet-stream-socket", builtin_inet_stream_sock); |
4385 | add_builtin("inet-dgram-socket", builtin_inet_dgram_sock); |
4386 | add_builtin("unix-stream-socket", builtin_unix_stream_sock); |
4387 | add_builtin("unix-dgram-socket", builtin_unix_dgram_sock); |
4388 | add_builtin("socket-ports", builtin_socket_ports); |
4389 | add_builtin("getsockname", builtin_getsockname); |
4390 | add_builtin("getpeername", builtin_getpeername); |
4391 | add_builtin("connect-inet", builtin_connect_inet); |
4392 | add_builtin("connect-unix", builtin_connect_unix); |
4393 | add_builtin("listen", builtin_listen); |
4394 | add_builtin("accept", builtin_accept); |
4395 | add_builtin("close", builtin_close); |
4396 | add_builtin("flonum?", builtin_is_flonum); |
4397 | add_builtin("flonum/unchecked", builtin_flonum_unchecked); |
4398 | add_builtin("flonum/unsigned/unchecked", builtin_flonum_unsigned_unchecked); |
4399 | add_builtin("flo=/unchecked", builtin_flo_eq_unchecked); |
4400 | add_builtin("flo</unchecked", builtin_flo_lt_unchecked); |
4401 | add_builtin("flo<=/unchecked", builtin_flo_le_unchecked); |
4402 | add_builtin("floneg/unchecked", builtin_flo_neg_unchecked); |
4403 | add_builtin("flonegative/unchecked?", builtin_is_flo_neg_unchecked); |
4404 | add_builtin("flo+/unchecked", builtin_flo_add_unchecked); |
4405 | add_builtin("flo-/unchecked", builtin_flo_sub_unchecked); |
4406 | add_builtin("flo*/unchecked", builtin_flo_mul_unchecked); |
4407 | add_builtin("flodiv/unchecked", builtin_flo_div_unchecked); |
4408 | add_builtin("floquotient/unchecked", builtin_flo_quotient_unchecked); |
4409 | add_builtin("floremainder/unchecked", builtin_flo_remainder_unchecked); |
4410 | add_builtin("fraction/exponent/unchecked", builtin_frac_exp_unchecked); |
4411 | add_builtin("load-exponent/unchecked", builtin_load_exp_unchecked); |
4412 | add_builtin("inf/unchecked?", builtin_is_inf_unchecked); |
4413 | add_builtin("flonum->fixnum/unchecked", builtin_flo_to_fix_unchecked); |
4414 | add_builtin("floor/unchecked", builtin_floor); |
4415 | add_builtin("ceiling/unchecked", builtin_ceiling); |
4416 | add_builtin("truncate/unchecked", builtin_truncate); |
4417 | add_builtin("round/unchecked", builtin_round); |
4418 | add_builtin("exp/unchecked", builtin_exp); |
4419 | add_builtin("log/unchecked", builtin_log); |
4420 | add_builtin("sin/unchecked", builtin_sin); |
4421 | add_builtin("cos/unchecked", builtin_cos); |
4422 | add_builtin("tan/unchecked", builtin_tan); |
4423 | add_builtin("asin/unchecked", builtin_asin); |
4424 | add_builtin("acos/unchecked", builtin_acos); |
4425 | add_builtin("atan/unchecked", builtin_atan); |
4426 | add_builtin("atan2/unchecked", builtin_atan2); |
4427 | add_builtin("sqrt/unchecked", builtin_sqrt); |
4428 | add_builtin("reverse-list->vector/unchecked", builtin_rev_list_to_vec_unchecked); |
4429 | add_builtin("builtin?", builtin_is_builtin); |
4430 | add_builtin("builtin-name", builtin_builtin_name); |
4431 | add_builtin("promise?", builtin_is_promise); |
4432 | add_builtin("continuation?", builtin_is_continuation); |
4433 | add_builtin("make-bignum", builtin_make_bignum); |
4434 | add_builtin("bignum?", builtin_is_bignum); |
4435 | add_builtin("bignum-negative?", builtin_is_bignum_negative); |
4436 | add_builtin("bignum-set-negative!", builtin_bignum_set_negative); |
4437 | add_builtin("bignum-ref", builtin_bignum_ref); |
4438 | add_builtin("bignum-set!", builtin_bignum_set); |
4439 | add_builtin("bignum-length", builtin_bignum_length); |
4440 | add_builtin("bignum", builtin_bignum); |
4441 | add_builtin("bignum/unsigned", builtin_bignum_unsigned); |
4442 | add_builtin("bignum2", builtin_bignum2); |
4443 | add_builtin("bignum-truncate!", builtin_bignum_truncate); |
4444 | |
4445 | R_PORT = open_lib_file(GSCMLIB "/compiler.scm"); |
4446 | err_context = "compiler"; |
4447 | r_compiler_expr = sc_read(); |
4448 | if (r_compiler_expr == SC_EOF) fatal("EOF reading compiler code"); |
4449 | close_port(R_PORT); |
4450 | R_EXPR = r_compiler_expr; |
4451 | R_ENV = toplevel_env; |
4452 | evaluator(); |
4453 | r_compiler = R_RESULT; |
4454 | /* Self-compile, for the speed benefit of variable refs */ |
4455 | R_EXPR = r_compiler_expr; |
4456 | R_ENV = toplevel_env; |
4457 | r_compiler_expr = SC_NULL; |
4458 | evaluator(); |
4459 | r_compiler = R_RESULT; |
4460 | } |
4461 | |
4462 | int sc_toplevel(int argc, char **argv) { |
4463 | int i; |
4464 | R_CDR = SC_NULL; |
4465 | for (i=argc-1; i>=0; --i) { |
4466 | R_CAR = string(argv[i]); |
4467 | R_CDR = cons(); |
4468 | } |
4469 | R_ENV = interaction_env; |
4470 | add_variable("*args*", R_CDR); |
4471 | |
4472 | R_PORT = open_lib_file(GSCMLIB "/toplevel.scm"); |
4473 | err_context = "toplevel"; |
4474 | R_EXPR = sc_read(); |
4475 | if (R_EXPR == SC_EOF) fatal("EOF reading toplevel code"); |
4476 | close_port(R_PORT); |
4477 | R_ENV = toplevel_env; |
4478 | evaluator(); |
4479 | flush_all(); |
4480 | return fixnum_val(R_RESULT); |
4481 | } |