Context Navigation

library.scm @ 14898

Last change on this file since 14898 was 14898, checked in by felix winkelmann, 12 years ago
user-interrupt condition object had missing slot for kinds
File size: 154.2 KB

Line
1	;;;; library.scm - R5RS library for the CHICKEN compiler
2	;
3	; Copyright (c) 2000-2007, Felix L. Winkelmann
4	; Copyright (c) 2008-2009, The Chicken Team
5	; All rights reserved.
6	;
7	; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8	; conditions are met:
9	;
10	; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11	; disclaimer.
12	; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13	; disclaimer in the documentation and/or other materials provided with the distribution.
14	; Neither the name of the author nor the names of its contributors may be used to endorse or promote
15	; products derived from this software without specific prior written permission.
16	;
17	; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18	; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19	; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20	; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21	; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22	; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23	; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24	; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25	; POSSIBILITY OF SUCH DAMAGE.
26
27
28	(declare
29	(unit library)
30	(disable-interrupts)
31	(disable-warning var redef)
32	(usual-integrations)
33	(hide ##sys#dynamic-unwind ##sys#find-symbol
34	##sys#grow-vector ##sys#default-parameter-vector
35	print-length-limit current-print-length setter-tag read-marks
36	##sys#print-exit
37	##sys#format-here-doc-warning)
38	(foreign-declare #<<EOF
39	#include <string.h>
40	#include <ctype.h>
41	#include <errno.h>
42	#include <time.h>
43	#include <float.h>
44
45	#ifdef HAVE_SYSEXITS_H
46	# include <sysexits.h>
47	#endif
48
49	#if !defined(_MSC_VER)
50	# include <unistd.h>
51	#endif
52
53	#ifndef EX_SOFTWARE
54	# define EX_SOFTWARE 70
55	#endif
56
57	#ifndef C_BUILD_TAG
58	# define C_BUILD_TAG ""
59	#endif
60
61	#define C_close_file(p) (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
62	#define C_f64peek(b, i) (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
63	#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))
64	#define C_peek_c_string(b, i, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(b, C_unfix(i)), C_unfix(len)), C_SCHEME_UNDEFINED)
65	#define C_free_mptr(p, i) (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)
66	#define C_free_sptr(p, i) (C_free((void )(((C_char *)C_block_item(p, 0))[ C_unfix(i) ])), C_SCHEME_UNDEFINED)
67
68	#define C_direct_continuation(dummy) t1
69
70	#define C_get_current_seconds(dummy) (C_temporary_flonum = time(NULL), C_SCHEME_UNDEFINED)
71	#define C_peek_c_string_at(ptr, i) ((C_char )(((C_char *)ptr)[ i ]))
72
73	static C_word fast_read_line_from_file(C_word str, C_word port, C_word size) {
74	int n = C_unfix(size);
75	int i;
76	int c;
77	char *buf = C_c_string(str);
78	C_FILEPTR fp = C_port_file(port);
79
80	if ((c = C_getc(fp)) == EOF)
81	return C_SCHEME_END_OF_FILE;
82
83	C_ungetc(c, fp);
84
85	for (i = 0; i < n; i++) {
86	c = C_getc(fp);
87	switch (c) {
88	case '\r': if ((c = C_getc(fp)) != '\n') C_ungetc(c, fp);
89	case EOF: clearerr(fp);
90	case '\n': return C_fix(i);
91	}
92	buf[i] = c;
93	}
94	return C_SCHEME_FALSE;
95	}
96
97	static C_word
98	fast_read_string_from_file (C_word dest, C_word port, C_word len, C_word pos)
99	{
100	int n = C_unfix (len);
101	char * buf = ((char *)C_data_pointer (dest) + C_unfix (pos));
102	C_FILEPTR fp = C_port_file (port);
103
104	size_t m = fread (buf, sizeof (char), n, fp);
105
106	if (m < n) {
107	if (feof (fp)) {
108	clearerr (fp);
109	if (0 == m)
110	return C_SCHEME_END_OF_FILE;
111	} else if (ferror (fp)) {
112	if (0 == m) {
113	return C_SCHEME_FALSE;
114	} else {
115	clearerr (fp);
116	}
117	}
118	}
119
120	return C_fix (m);
121	}
122	EOF
123	) )
124
125	(cond-expand
126	[paranoia]
127	[else
128	(declare
129	(no-bound-checks)
130	(no-procedure-checks-for-usual-bindings)
131	(bound-to-procedure
132	##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-port* ##sys#check-string ##sys#substring ##sys#check-port-mode
133	##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair
134	##sys#error-not-a-proper-list ##sys#error ##sys#warn ##sys#signal-hook
135	##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round
136	##sys#check-number ##sys#cons-flonum ##sys#check-integer ##sys#check-special
137	##sys#flonum-fraction ##sys#make-port ##sys#print
138	##sys#check-structure ##sys#make-structure ##sys#procedure->string
139	##sys#gcd ##sys#lcm ##sys#ensure-heap-reserve ##sys#check-list
140	##sys#enable-interrupts ##sys#disable-interrupts ##sys#->feature-id
141	##sys#fudge ##sys#user-read-hook ##sys#check-range ##sys#read
142	##sys#string->symbol ##sys#symbol->string ##sys#dynamic-unwind ##sys#pathname-resolution
143	##sys#platform-fixup-pathname ##sys#expand-home-path ##sys#string-append ##sys#symbol->qualified-string
144	##sys#error-handler ##sys#signal ##sys#abort ##sys#port-data
145	##sys#reset-handler ##sys#exit-handler ##sys#dynamic-wind ##sys#port-line
146	##sys#grow-vector ##sys#run-pending-finalizers ##sys#peek-char-0 ##sys#read-char-0
147	##sys#read-char/port ##sys#write-char/port
148	##sys#schedule ##sys#make-thread ##sys#print-to-string ##sys#scan-buffer-line
149	##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer ##sys#user-print-hook
150	##sys#current-exception-handler ##sys#default-exception-handler ##sys#abandon-mutexes ##sys#make-mutex
151	##sys#port-has-file-pointer? ##sys#infix-list-hook char-name ##sys#open-file-port make-parameter
152	##sys#intern-symbol ##sys#make-string ##sys#number? software-type build-platform
153	open-output-string get-output-string print-call-chain ##sys#symbol-has-toplevel-binding? repl
154	argv condition-property-accessor ##sys#decorate-lambda ##sys#become! ##sys#lambda-decoration
155	getter-with-setter ##sys#lambda-info ##sys#lambda-info->string open-input-string ##sys#gc
156	##sys#memory-info ##sys#make-c-string ##sys#find-symbol-table display
157	newline string-append ##sys#with-print-length-limit write print vector-fill! ##sys#context-switch
158	##sys#set-finalizer! open-output-string get-output-string read ##sys#make-pointer
159	##sys#pointer->address number->string ##sys#flush-output ##sys#break-entry ##sys#step
160	##sys#apply-values ##sys#get-call-chain ##sys#really-print-call-chain
161	string->keyword keyword? string->keyword getenv ##sys#number->string ##sys#copy-bytes
162	call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
163	##sys#reverse-list->string reverse ##sys#inexact? list? string ##sys#char->utf8-string
164	##sys#unicode-surrogate? ##sys#surrogates->codepoint ##sys#write-char/port
165	##sys#update-errno ##sys#file-info close-output-port close-input-port ##sys#peek-unsigned-integer
166	continuation-graft char-downcase string-copy remainder floor ##sys#exact? list->string
167	##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#list ##sys#apply ##sys#make-vector
168	##sys#write-char ##sys#force-finalizers ##sys#cleanup-before-exit ##sys#write-char-0
169	##sys#default-read-info-hook ##sys#read-error) ) ] )
170
171
172	(include "version.scm")
173	(include "banner.scm")
174
175
176	(define-constant namespace-max-id-len 31)
177	(define-constant char-name-table-size 37)
178	(define-constant output-string-initial-size 256)
179	(define-constant read-line-buffer-initial-size 1024)
180	(define-constant default-parameter-vector-size 16)
181	(define-constant maximal-string-length #x00ffffff)
182
183	(define-foreign-variable +build-tag+ c-string "C_BUILD_TAG")
184
185
186	;;; System routines:
187
188	(define (exit . code) (apply (##sys#exit-handler) code))
189	(define (reset) ((##sys#reset-handler)))
190
191	(define (##sys#error . args)
192	(if (pair? args)
193	(apply ##sys#signal-hook #:error args)
194	(##sys#signal-hook #:error #f)))
195
196	(define ##sys#warnings-enabled #t)
197
198	(define (##sys#warn msg . args)
199	(when ##sys#warnings-enabled
200	(apply ##sys#signal-hook #:warning msg args) ) )
201
202	(define (enable-warnings . bool)
203	(if (pair? bool)
204	(set! ##sys#warnings-enabled (car bool))
205	##sys#warnings-enabled) )
206
207	(define error ##sys#error)
208	(define warning ##sys#warn)
209
210	(define-foreign-variable main_argc int "C_main_argc")
211	(define-foreign-variable main_argv c-pointer "C_main_argv")
212	(define-foreign-variable strerror c-string "strerror(errno)")
213
214	(define (set-gc-report! flag) (##core#inline "C_set_gc_report" flag))
215	(define ##sys#gc (##core#primitive "C_gc"))
216	(define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y))
217	(define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y))
218	(define ##sys#allocate-vector (##core#primitive "C_allocate_vector"))
219	(define argv (##core#primitive "C_get_argv"))
220	(define (argc+argv) (##sys#values main_argc main_argv))
221	(define ##sys#make-structure (##core#primitive "C_make_structure"))
222	(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))
223	(define (##sys#fudge fudge-factor) (##core#inline "C_fudge" fudge-factor))
224	(define ##sys#call-host (##core#primitive "C_return_to_host"))
225	(define return-to-host ##sys#call-host)
226	(define ##sys#file-info (##core#primitive "C_file_info"))
227	(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
228	(define ##sys#memory-info (##core#primitive "C_get_memory_info"))
229	(define (current-milliseconds) (##sys#fudge 16))
230	(define (current-gc-milliseconds) (##sys#fudge 31))
231	(define cpu-time (##core#primitive "C_cpu_time"))
232	(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
233	(define get-environment-variable (##core#primitive "C_get_environment_variable"))
234	(define getenv get-environment-variable)
235	(define (##sys#start-timer) (##core#inline "C_start_timer"))
236	(define ##sys#stop-timer (##core#primitive "C_stop_timer"))
237	(define (##sys#immediate? x) (not (##core#inline "C_blockp" x)))
238	(define (##sys#message str) (##core#inline "C_message" str))
239	(define (##sys#byte x i) (##core#inline "C_subbyte" x i))
240	(define (##sys#setbyte x i n) (##core#inline "C_setbyte" x i n))
241	(define (##sys#void) (##core#undefined))
242	(define void ##sys#void)
243	(define ##sys#undefined-value (##core#undefined))
244	(define (##sys#halt) (##core#inline "C_halt" #f))
245	(define (##sys#flo2fix n) (##core#inline "C_quickflonumtruncate" n))
246	(define ##sys#become! (##core#primitive "C_become"))
247	(define (##sys#block-ref x i) (##core#inline "C_i_block_ref" x i))
248	(define ##sys#apply-values (##core#primitive "C_apply_values"))
249	(define ##sys#copy-closure (##core#primitive "C_copy_closure"))
250	(define ##sys#apply-argument-limit (##sys#fudge 34))
251
252	(define (##sys#block-set! x i y)
253	(cond-expand
254	[(not unsafe)
255	(when (or (not (##core#inline "C_blockp" x))
256	(and (##core#inline "C_specialp" x) (fx= i 0))
257	(##core#inline "C_byteblockp" x) )
258	(##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )
259	(##sys#check-range i 0 (##sys#size x) '##sys#block-set!) ]
260	[else] )
261	(##sys#setslot x i y) )
262
263	(define (current-seconds)
264	(##core#inline "C_get_current_seconds" #f)
265	(##sys#cons-flonum) )
266
267	(define (##sys#check-structure x y . loc)
268	(if (pair? loc)
269	(##core#inline "C_i_check_structure_2" x y (car loc))
270	(##core#inline "C_i_check_structure" x y) ) )
271
272	(define (##sys#check-blob x . loc)
273	(if (pair? loc)
274	(##core#inline "C_i_check_bytevector_2" x (car loc))
275	(##core#inline "C_i_check_bytevector" x) ) )
276
277	(define ##sys#check-byte-vector ##sys#check-blob)
278
279	(define (##sys#check-pair x . loc)
280	(if (pair? loc)
281	(##core#inline "C_i_check_pair_2" x (car loc))
282	(##core#inline "C_i_check_pair" x) ) )
283
284	(define (##sys#check-list x . loc)
285	(if (pair? loc)
286	(##core#inline "C_i_check_list_2" x (car loc))
287	(##core#inline "C_i_check_list" x) ) )
288
289	(define (##sys#check-string x . loc)
290	(if (pair? loc)
291	(##core#inline "C_i_check_string_2" x (car loc))
292	(##core#inline "C_i_check_string" x) ) )
293
294	(define (##sys#check-number x . loc)
295	(if (pair? loc)
296	(##core#inline "C_i_check_number_2" x (car loc))
297	(##core#inline "C_i_check_number" x) ) )
298
299	(define (##sys#check-exact x . loc)
300	(if (pair? loc)
301	(##core#inline "C_i_check_exact_2" x (car loc))
302	(##core#inline "C_i_check_exact" x) ) )
303
304	(define (##sys#check-inexact x . loc)
305	(if (pair? loc)
306	(##core#inline "C_i_check_inexact_2" x (car loc))
307	(##core#inline "C_i_check_inexact" x) ) )
308
309	(define (##sys#check-symbol x . loc)
310	(if (pair? loc)
311	(##core#inline "C_i_check_symbol_2" x (car loc))
312	(##core#inline "C_i_check_symbol" x) ) )
313
314	(define (##sys#check-vector x . loc)
315	(if (pair? loc)
316	(##core#inline "C_i_check_vector_2" x (car loc))
317	(##core#inline "C_i_check_vector" x) ) )
318
319	(define (##sys#check-char x . loc)
320	(if (pair? loc)
321	(##core#inline "C_i_check_char_2" x (car loc))
322	(##core#inline "C_i_check_char" x) ) )
323
324	(define (##sys#check-integer x . loc)
325	(unless (##core#inline "C_i_integerp" x)
326	(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
327	(and (pair? loc) (car loc)) x) ) )
328
329	(define (##sys#check-range i from to . loc)
330	(##sys#check-exact i loc)
331	(unless (and (fx<= from i) (fx< i to))
332	(##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
333	(and (pair? loc) (car loc)) i from to) ) )
334
335	(define (##sys#check-special ptr . loc)
336	(unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
337	(##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "bad argument type - not a pointer-like object" ptr) ) )
338
339	(define (##sys#check-closure x . loc)
340	(if (pair? loc)
341	(##core#inline "C_i_check_closure_2" x (car loc))
342	(##core#inline "C_i_check_closure" x) ) )
343
344	(include "unsafe-declarations.scm")
345
346	(define (##sys#force promise)
347	(if (##sys#structure? promise 'promise)
348	((##sys#slot promise 1))
349	promise) )
350
351	(define force ##sys#force)
352
353	(define (system cmd)
354	(##sys#check-string cmd 'system)
355	(let ((r (##core#inline "C_execute_shell_command" cmd)))
356	(cond ((fx< r 0)
357	(##sys#update-errno)
358	(##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd) )
359	(else r) ) ) )
360
361
362	;;; Dynamic Load
363
364	(define ##sys#dload (##core#primitive "C_dload"))
365	(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
366
367	;; Dynamic Unload not available on all platforms and to be used with caution!
368	(define (##sys#dunload name)
369	(and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
370	(##sys#gc #t)
371	#t ) )
372
373
374	;;; Operations on booleans:
375
376	(define (not x) (##core#inline "C_i_not" x))
377	(define (boolean? x) (##core#inline "C_booleanp" x))
378
379
380	;;; Equivalence predicates:
381
382	(define (eq? x y) (##core#inline "C_eqp" x y))
383	(define (eqv? x y) (##core#inline "C_i_eqvp" x y))
384	(define (equal? x y) (##core#inline "C_i_equalp" x y))
385
386
387	;;; Pairs and lists:
388
389	(define (pair? x) (##core#inline "C_i_pairp" x))
390	(define (cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y))
391	(define (car x) (##core#inline "C_i_car" x))
392	(define (cdr x) (##core#inline "C_i_cdr" x))
393
394	(define (set-car! x y) (##core#inline "C_i_set_car" x y))
395	(define (set-cdr! x y) (##core#inline "C_i_set_cdr" x y))
396	(define (cadr x) (##core#inline "C_i_cadr" x))
397	(define (caddr x) (##core#inline "C_i_caddr" x))
398	(define (cadddr x) (##core#inline "C_i_cadddr" x))
399	(define (cddddr x) (##core#inline "C_i_cddddr" x))
400
401	(define (caar x) (car (car x)))
402	(define (cdar x) (cdr (car x)))
403	(define (cddr x) (cdr (cdr x)))
404	(define (caaar x) (car (car (car x))))
405	(define (caadr x) (car (##core#inline "C_i_cadr" x)))
406	(define (cadar x) (##core#inline "C_i_cadr" (car x)))
407	(define (cdaar x) (cdr (car (car x))))
408	(define (cdadr x) (cdr (##core#inline "C_i_cadr" x)))
409	(define (cddar x) (cdr (cdr (car x))))
410	(define (cdddr x) (cdr (cdr (cdr x))))
411	(define (caaaar x) (car (car (car (car x)))))
412	(define (caaadr x) (car (car (##core#inline "C_i_cadr" x))))
413	(define (caadar x) (car (##core#inline "C_i_cadr" (car x))))
414	(define (caaddr x) (car (##core#inline "C_i_caddr" x)))
415	(define (cadaar x) (##core#inline "C_i_cadr" (car (car x))))
416	(define (cadadr x) (##core#inline "C_i_cadr" (##core#inline "C_i_cadr" x)))
417	(define (caddar x) (##core#inline "C_i_caddr" (car x)))
418	(define (cdaaar x) (cdr (car (car (car x)))))
419	(define (cdaadr x) (cdr (car (##core#inline "C_i_cadr" x))))
420	(define (cdadar x) (cdr (##core#inline "C_i_cadr" (car x))))
421	(define (cdaddr x) (cdr (##core#inline "C_i_caddr" x)))
422	(define (cddaar x) (cdr (cdr (car (car x)))))
423	(define (cddadr x) (cdr (cdr (##core#inline "C_i_cadr" x))))
424	(define (cdddar x) (cdr (cdr (cdr (car x)))))
425
426	(define (null? x) (eq? x '()))
427	(define (list . lst) lst)
428	(define (length lst) (##core#inline "C_i_length" lst))
429	(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i))
430	(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i))
431
432	(define (##sys#delq x lst)
433	(let loop ([lst lst])
434	(cond ((null? lst) lst)
435	((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
436	(else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
437
438	(define (##sys#error-not-a-proper-list arg . loc)
439	(##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) (and (pair? loc) (car loc)) arg) )
440
441	(define ##sys#not-a-proper-list-error ##sys#error-not-a-proper-list) ;DEPRECATED
442
443	(define (append . lsts)
444	(if (eq? lsts '())
445	lsts
446	(let loop ((lsts lsts))
447	(if (eq? (##sys#slot lsts 1) '())
448	(##sys#slot lsts 0)
449	(let copy ((node (##sys#slot lsts 0)))
450	(cond-expand
451	[unsafe
452	(if (eq? node '())
453	(loop (##sys#slot lsts 1))
454	(cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
455	[else
456	(cond ((eq? node '()) (loop (##sys#slot lsts 1)))
457	((pair? node)
458	(cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
459	(else (##sys#error-not-a-proper-list (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
460
461	(define (reverse lst0)
462	(let loop ((lst lst0) (rest '()))
463	(cond-expand
464	[unsafe
465	(if (eq? lst '())
466	rest
467	(loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) ) ]
468	[else
469	(cond ((eq? lst '()) rest)
470	((pair? lst)
471	(loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
472	(else (##sys#error-not-a-proper-list lst0 'reverse)) ) ] ) ) )
473
474	(define (memq x lst) (##core#inline "C_i_memq" x lst))
475	(define (memv x lst) (##core#inline "C_i_memv" x lst))
476	(define (member x lst) (##core#inline "C_i_member" x lst))
477	(define (assq x lst) (##core#inline "C_i_assq" x lst))
478	(define (assv x lst) (##core#inline "C_i_assv" x lst))
479	(define (assoc x lst) (##core#inline "C_i_assoc" x lst))
480
481	(define (list? x) (##core#inline "C_i_listp" x))
482
483
484	;;; Strings:
485
486	(define (string? x) (##core#inline "C_i_stringp" x))
487	(define (string-length s) (##core#inline "C_i_string_length" s))
488	(define (string-ref s i) (##core#inline "C_i_string_ref" s i))
489	(define (string-set! s i c) (##core#inline "C_i_string_set" s i c))
490
491	(define-inline (%make-string size fill)
492	(##sys#allocate-vector size #t fill #f) )
493
494	(define (##sys#make-string size #!optional (fill #\space))
495	(%make-string size fill))
496
497	(define (make-string size . fill)
498	(##sys#check-exact size 'make-string)
499	#+(not unsafe)
500	(when (fx< size 0)
501	(##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
502	(%make-string size
503	(if (null? fill)
504	#\space
505	(let ((c (car fill)))
506	(##sys#check-char c 'make-string)
507	c ) ) ) )
508
509	(define ##sys#string->list
510	(lambda (s)
511	(##sys#check-string s 'string->list)
512	(let ((len (##core#inline "C_block_size" s)))
513	(let loop ((i 0))
514	(if (fx>= i len)
515	'()
516	(cons (##core#inline "C_subchar" s i)
517	(loop (fx+ i 1)) ) ) ) ) ) )
518
519	(define string->list ##sys#string->list)
520
521	(define (##sys#list->string lst0)
522	(cond-expand
523	[unsafe
524	(let* ([len (length lst0)]
525	[s (##sys#make-string len)] )
526	(do ([i 0 (fx+ i 1)]
527	[lst lst0 (##sys#slot lst 1)] )
528	((fx>= i len) s)
529	(##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
530	[else
531	(if (not (list? lst0))
532	(##sys#error-not-a-proper-list lst0 'list->string)
533	(let* ([len (length lst0)]
534	[s (##sys#make-string len)] )
535	(do ([i 0 (fx+ i 1)]
536	[lst lst0 (##sys#slot lst 1)] )
537	((fx>= i len) s)
538	(let ([c (##sys#slot lst 0)])
539	(##sys#check-char c 'list->string)
540	(##core#inline "C_setsubchar" s i c) ) ) ) )]
541	))
542
543	(define list->string ##sys#list->string)
544
545	;;; By Sven Hartrumpf:
546
547	(define (##sys#reverse-list->string l)
548	(cond-expand
549	[unsafe
550	(let* ((n (length l))
551	(s (##sys#make-string n)))
552	(let iter ((l2 l) (n2 (fx- n 1)))
553	(cond ((fx>= n2 0)
554	(##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
555	(iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
556	s ) ]
557	[else
558	(if (list? l)
559	(let* ((n (length l))
560	(s (##sys#make-string n)))
561	(let iter ((l2 l) (n2 (fx- n 1)))
562	(cond ((fx>= n2 0)
563	(let ((c (##sys#slot l2 0)))
564	(##sys#check-char c 'reverse-list->string)
565	(##core#inline "C_setsubchar" s n2 c) )
566	(iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
567	s )
568	(##sys#error-not-a-proper-list l 'reverse-list->string) ) ]
569	) )
570
571	(define reverse-list->string ##sys#reverse-list->string)
572
573	(define (string-fill! s c)
574	(##sys#check-string s 'string-fill!)
575	(##sys#check-char c 'string-fill!)
576	(##core#inline "C_set_memory" s c (##sys#size s))
577	(##core#undefined) )
578
579	(define string-copy
580	(lambda (s)
581	(##sys#check-string s 'string-copy)
582	(let* ([len (##sys#size s)]
583	[s2 (##sys#make-string len)] )
584	(##core#inline "C_copy_memory" s2 s len)
585	s2) ) )
586
587	(define (substring s start . end)
588	(##sys#check-string s 'substring)
589	(##sys#check-exact start 'substring)
590	(let ([end (if (pair? end)
591	(let ([end (car end)])
592	(##sys#check-exact end 'substring)
593	end)
594	(##sys#size s) ) ] )
595	(cond-expand
596	[unsafe (##sys#substring s start end)]
597	[else
598	(let ([len (##sys#size s)])
599	(if (and (fx<= start end)
600	(fx>= start 0)
601	(fx<= end len) )
602	(##sys#substring s start end)
603	(##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) 'substring start end) ) ) ] ) ) )
604
605	(define (##sys#substring s start end)
606	(let ([s2 (##sys#make-string (fx- end start))])
607	(##core#inline "C_substring_copy" s s2 start end 0)
608	s2 ) )
609
610	(define (string=? x y)
611	(cond-expand [unsafe (##core#inline "C_u_i_string_equal_p" x y)]
612	[else (##core#inline "C_i_string_equal_p" x y)] ) )
613
614	(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y))
615
616	(letrec ((compare
617	(lambda (s1 s2 loc k)
618	(##sys#check-string s1 loc)
619	(##sys#check-string s2 loc)
620	(let ((len1 (##core#inline "C_block_size" s1))
621	(len2 (##core#inline "C_block_size" s2)) )
622	(k len1 len2
623	(##core#inline "C_string_compare"
624	s1
625	s2
626	(if (fx< len1 len2)
627	len1
628	len2) ) ) ) ) ) )
629	(set! string<? (lambda (s1 s2)
630	(compare
631	s1 s2 'string<?
632	(lambda (len1 len2 cmp)
633	(or (fx< cmp 0)
634	(and (fx< len1 len2)
635	(eq? cmp 0) ) ) ) ) ) )
636	(set! string>? (lambda (s1 s2)
637	(compare
638	s1 s2 'string>?
639	(lambda (len1 len2 cmp)
640	(or (fx> cmp 0)
641	(and (fx< len2 len1)
642	(eq? cmp 0) ) ) ) ) ) )
643	(set! string<=? (lambda (s1 s2)
644	(compare
645	s1 s2 'string<=?
646	(lambda (len1 len2 cmp)
647	(if (eq? cmp 0)
648	(fx<= len1 len2)
649	(fx< cmp 0) ) ) ) ) )
650	(set! string>=? (lambda (s1 s2)
651	(compare
652	s1 s2 'string>=?
653	(lambda (len1 len2 cmp)
654	(if (eq? cmp 0)
655	(fx>= len1 len2)
656	(fx> cmp 0) ) ) ) ) ) )
657
658	(letrec ((compare
659	(lambda (s1 s2 loc k)
660	(##sys#check-string s1 loc)
661	(##sys#check-string s2 loc)
662	(let ((len1 (##core#inline "C_block_size" s1))
663	(len2 (##core#inline "C_block_size" s2)) )
664	(k len1 len2
665	(##core#inline "C_string_compare_case_insensitive"
666	s1
667	s2
668	(if (fx< len1 len2)
669	len1
670	len2) ) ) ) ) ) )
671	(set! string-ci<? (lambda (s1 s2)
672	(compare
673	s1 s2 'string-ci<?
674	(lambda (len1 len2 cmp)
675	(or (fx< cmp 0)
676	(and (fx< len1 len2)
677	(eq? cmp 0) ) ) ) ) ) )
678	(set! string-ci>? (lambda (s1 s2)
679	(compare
680	s1 s2 'string-ci>?
681	(lambda (len1 len2 cmp)
682	(or (fx> cmp 0)
683	(and (fx< len2 len1)
684	(eq? cmp 0) ) ) ) ) ) )
685	(set! string-ci<=? (lambda (s1 s2)
686	(compare
687	s1 s2 'string-ci<=?
688	(lambda (len1 len2 cmp)
689	(if (eq? cmp 0)
690	(fx>= len1 len2)
691	(fx< cmp 0) ) ) ) ) )
692	(set! string-ci>=? (lambda (s1 s2)
693	(compare
694	s1 s2 'string-ci>=?
695	(lambda (len1 len2 cmp)
696	(if (eq? cmp 0)
697	(fx<= len1 len2)
698	(fx> cmp 0) ) ) ) ) ) )
699
700	(define (##sys#string-append x y)
701	(let* ([s1 (##sys#size x)]
702	[s2 (##sys#size y)]
703	[z (##sys#make-string (fx+ s1 s2))] )
704	(##core#inline "C_substring_copy" x z 0 s1 0)
705	(##core#inline "C_substring_copy" y z 0 s2 s1)
706	z) )
707
708	(define (string-append . all)
709	(let ([snew #f])
710	(let loop ([strs all] [n 0])
711	(if (eq? strs '())
712	(set! snew (##sys#make-string n))
713	(let ([s (##sys#slot strs 0)])
714	(##sys#check-string s 'string-append)
715	(let ([len (##sys#size s)])
716	(loop (##sys#slot strs 1) (fx+ n len))
717	(##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )
718	snew ) )
719
720	(define string
721	(let ([list->string list->string])
722	(lambda chars (list->string chars)) ) )
723
724	(define (##sys#fragments->string total fs)
725	(let ([dest (##sys#make-string total)])
726	(let loop ([fs fs] [pos 0])
727	(if (null? fs)
728	dest
729	(let* ([f (##sys#slot fs 0)]
730	[flen (##sys#size f)] )
731	(##core#inline "C_substring_copy" f dest 0 flen pos)
732	(loop (##sys#slot fs 1) (fx+ pos flen)) ) ) ) ) )
733
734
735	;;; Numeric routines:
736
737	(define most-positive-fixnum (foreign-value "C_MOST_POSITIVE_FIXNUM" int))
738	(define most-negative-fixnum (foreign-value "C_MOST_NEGATIVE_FIXNUM" int))
739	(define fixnum-bits (foreign-value "(C_WORD_SIZE - 1)" int))
740	(define fixnum-precision (foreign-value "(C_WORD_SIZE - (1 + 1))" int))
741
742	(define (fixnum? x) (##core#inline "C_fixnump" x))
743	(define (fx+ x y) (##core#inline "C_fixnum_plus" x y))
744	(define (fx- x y) (##core#inline "C_fixnum_difference" x y))
745	(define (fx* x y) (##core#inline "C_fixnum_times" x y))
746	(define (fx= x y) (eq? x y))
747	(define (fx> x y) (##core#inline "C_fixnum_greaterp" x y))
748	(define (fx< x y) (##core#inline "C_fixnum_lessp" x y))
749	(define (fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
750	(define (fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
751	(define (fxmin x y) (##core#inline "C_i_fixnum_min" x y))
752	(define (fxmax x y) (##core#inline "C_i_fixnum_max" x y))
753	(define (fxneg x) (##core#inline "C_fixnum_negate" x))
754	(define (fxand x y) (##core#inline "C_fixnum_and" x y))
755	(define (fxior x y) (##core#inline "C_fixnum_or" x y))
756	(define (fxxor x y) (##core#inline "C_fixnum_xor" x y))
757	(define (fxnot x) (##core#inline "C_fixnum_not" x))
758	(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
759	(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
760
761	(define-inline (fx-check-divison-by-zero x y loc)
762	(when (eq? 0 y)
763	(##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) loc x y) ) )
764
765	(define (fx/ x y)
766	(cond-expand
767	[unsafe (##core#inline "C_fixnum_divide" x y)]
768	[else
769	(fx-check-divison-by-zero x y 'fx/)
770	(##core#inline "C_fixnum_divide" x y) ] ) )
771
772	(define (fxmod x y)
773	(cond-expand
774	[unsafe (##core#inline "C_fixnum_modulo" x y)]
775	[else
776	(fx-check-divison-by-zero x y 'fxmod)
777	(##core#inline "C_fixnum_modulo" x y) ] ) )
778
779	(define maximum-flonum (foreign-value "DBL_MAX" double))
780	(define minimum-flonum (foreign-value "DBL_MIN" double))
781	(define flonum-radix (foreign-value "FLT_RADIX" int))
782	(define flonum-epsilon (foreign-value "DBL_EPSILON" double))
783	(define flonum-precision (foreign-value "DBL_MANT_DIG" int))
784	(define flonum-decimal-precision (foreign-value "DBL_DIG" int))
785	(define flonum-maximum-exponent (foreign-value "DBL_MAX_EXP" int))
786	(define flonum-minimum-exponent (foreign-value "DBL_MIN_EXP" int))
787	(define flonum-maximum-decimal-exponent (foreign-value "DBL_MAX_10_EXP" int))
788	(define flonum-minimum-decimal-exponent (foreign-value "DBL_MIN_10_EXP" int))
789
790	(define (flonum? x) (##core#inline "C_i_flonump" x))
791
792	(define (finite? x)
793	(##sys#check-number x 'finite?)
794	(##core#inline "C_i_finitep" x) )
795
796	(define-inline (fp-check-flonum x loc)
797	(unless (flonum? x)
798	(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )
799
800	(define-inline (fp-check-flonums x y loc)
801	(unless (and (flonum? x) (flonum? y))
802	(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )
803
804	(define (fp+ x y)
805	(cond-expand
806	[unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)]
807	[else
808	(fp-check-flonums x y 'fp+)
809	(##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) ] ) )
810
811	(define (fp- x y)
812	(cond-expand
813	[unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)]
814	[else
815	(fp-check-flonums x y 'fp-)
816	(##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) ] ) )
817
818	(define (fp* x y)
819	(cond-expand
820	[unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)]
821	[else
822	(fp-check-flonums x y 'fp*)
823	(##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
824
825	(define (fp/ x y)
826	(cond-expand
827	[unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
828	[else
829	(fp-check-flonums x y 'fp/)
830	(##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
831
832	(define (fp= x y)
833	(cond-expand
834	[unsafe (##core#inline "C_flonum_equalp" x y)]
835	[else
836	(fp-check-flonums x y 'fp=)
837	(##core#inline "C_flonum_equalp" x y) ] ) )
838
839	(define (fp> x y)
840	(cond-expand
841	[unsafe (##core#inline "C_flonum_greaterp" x y)]
842	[else
843	(fp-check-flonums x y 'fp>)
844	(##core#inline "C_flonum_greaterp" x y) ] ) )
845
846	(define (fp< x y)
847	(cond-expand
848	[unsafe (##core#inline "C_flonum_lessp" x y)]
849	[else
850	(fp-check-flonums x y 'fp<)
851	(##core#inline "C_flonum_lessp" x y) ] ) )
852
853	(define (fp>= x y)
854	(cond-expand
855	[unsafe (##core#inline "C_flonum_greater_or_equal_p" x y)]
856	[else
857	(fp-check-flonums x y 'fp>=)
858	(##core#inline "C_flonum_greater_or_equal_p" x y) ] ) )
859
860	(define (fp<= x y)
861	(cond-expand
862	[unsafe (##core#inline "C_flonum_less_or_equal_p" x y)]
863	[else
864	(fp-check-flonums x y 'fp<=)
865	(##core#inline "C_flonum_less_or_equal_p" x y) ] ) )
866
867	(define (fpneg x)
868	(cond-expand
869	[unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)]
870	[else
871	(fp-check-flonum x 'fpneg)
872	(##core#inline_allocate ("C_a_i_flonum_negate" 4) x) ] ) )
873
874	(define (fpmax x y)
875	(cond-expand
876	[unsafe (##core#inline "C_i_flonum_max" x y)]
877	[else
878	(fp-check-flonums x y 'fpmax)
879	(##core#inline "C_i_flonum_max" x y) ] ) )
880
881	(define (fpmin x y)
882	(cond-expand
883	[unsafe (##core#inline "C_i_flonum_min" x y)]
884	[else
885	(fp-check-flonums x y 'fpmin)
886	(##core#inline "C_i_flonum_min" x y) ] ) )
887
888	(define * (##core#primitive "C_times"))
889	(define - (##core#primitive "C_minus"))
890	(define + (##core#primitive "C_plus"))
891	(define / (##core#primitive "C_divide"))
892	(define = (##core#primitive "C_nequalp"))
893	(define > (##core#primitive "C_greaterp"))
894	(define < (##core#primitive "C_lessp"))
895	(define >= (##core#primitive "C_greater_or_equal_p"))
896	(define <= (##core#primitive "C_less_or_equal_p"))
897
898	(define add1 (lambda (n) (+ n 1)))
899	(define sub1 (lambda (n) (- n 1)))
900
901	(define ##sys#floor (##core#primitive "C_flonum_floor"))
902	(define ##sys#ceiling (##core#primitive "C_flonum_ceiling"))
903	(define ##sys#truncate (##core#primitive "C_flonum_truncate"))
904	(define ##sys#round (##core#primitive "C_flonum_round"))
905	(define quotient (##core#primitive "C_quotient"))
906	(define ##sys#cons-flonum (##core#primitive "C_cons_flonum"))
907	(define (##sys#number? x) (##core#inline "C_i_numberp" x))
908	(define number? ##sys#number?)
909	(define complex? number?)
910	(define real? number?)
911	(define rational? number?)
912	(define ##sys#flonum-fraction (##core#primitive "C_flonum_fraction"))
913	(define (##sys#integer? x) (##core#inline "C_i_integerp" x))
914	(define integer? ##sys#integer?)
915	(define (##sys#exact? x) (##core#inline "C_i_exactp" x))
916	(define (##sys#inexact? x) (##core#inline "C_i_inexactp" x))
917	(define exact? ##sys#exact?)
918	(define inexact? ##sys#inexact?)
919	(define expt (##core#primitive "C_expt"))
920	(define (##sys#fits-in-int? n) (##core#inline "C_fits_in_int_p" n))
921	(define (##sys#fits-in-unsigned-int? n) (##core#inline "C_fits_in_unsigned_int_p" n))
922	(define (##sys#flonum-in-fixnum-range? n) (##core#inline "C_flonum_in_fixnum_range_p" n))
923	(define (##sys#double->number n) (##core#inline "C_double_to_number" n))
924	(define (zero? n) (##core#inline "C_i_zerop" n))
925	(define (positive? n) (##core#inline "C_i_positivep" n))
926	(define (negative? n) (##core#inline "C_i_negativep" n))
927	(define (abs n) (##core#inline_allocate ("C_a_i_abs" 4) n)) ; 4 => words-per-flonum
928
929	(define (angle n)
930	(##sys#check-number n 'angle)
931	(if (< n 0) (fp* 2.0 (acos 0.0)) 0.0) )
932
933	(define (real-part n)
934	(##sys#check-number n 'real-part)
935	n)
936
937	(define (imag-part n)
938	(##sys#check-number n 'imag-part)
939	0)
940
941	(define (numerator n)
942	(##sys#check-number n 'numerator)
943	(if (##core#inline "C_i_integerp" n)
944	n
945	(##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )
946
947	(define (denominator n)
948	(##sys#check-number n 'denominator)
949	(if (##core#inline "C_i_integerp" n)
950	1
951	(##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )
952
953	(define magnitude abs)
954
955	(define (signum n)
956	(cond ((> n 0) (if (##sys#exact? n) 1 1.0))
957	((< n 0) (if (##sys#exact? n) -1 -1.0))
958	(else (if (##sys#exact? n) 0 0.0) ) ) )
959
960	(define ##sys#exact->inexact (##core#primitive "C_exact_to_inexact"))
961	(define exact->inexact ##sys#exact->inexact)
962	(define (##sys#inexact->exact n) (##core#inline "C_i_inexact_to_exact" n))
963	(define inexact->exact ##sys#inexact->exact)
964
965	(define (floor x)
966	(##sys#check-number x 'floor)
967	(if (##core#inline "C_fixnump" x)
968	x
969	(##sys#floor x) ) )
970
971	(define (ceiling x)
972	(##sys#check-number x 'ceiling)
973	(if (##core#inline "C_fixnump" x)
974	x
975	(##sys#ceiling x) ) )
976
977	(define (truncate x)
978	(##sys#check-number x 'truncate)
979	(if (##core#inline "C_fixnump" x)
980	x
981	(##sys#truncate x) ) )
982
983	(define (round x)
984	(##sys#check-number x 'round)
985	(if (##core#inline "C_fixnump" x)
986	x
987	(##sys#round x) ) )
988
989	(define remainder
990	(lambda (x y) (- x (* (quotient x y) y))) )
991
992	(define modulo
993	(let ([floor floor])
994	(lambda (x y)
995	(let ((div (/ x y)))
996	(- x (* (if (integer? div)
997	div
998	(let* ([fd (floor div)]
999	[fdx (##core#inline "C_quickflonumtruncate" fd)] )
1000	(if (= fd fdx)
1001	fdx
1002	fd) ) )
1003	y) ) ) ) ) )
1004
1005	(define (even? n) (##core#inline "C_i_evenp" n))
1006	(define (odd? n) (##core#inline "C_i_oddp" n))
1007
1008	(define max)
1009	(define min)
1010
1011	(let ([> >]
1012	[< <] )
1013	(letrec ([maxmin
1014	(lambda (n1 ns pred)
1015	(let loop ((nbest n1) (ns ns))
1016	(if (eq? ns '())
1017	nbest
1018	(let ([ni (##sys#slot ns 0)])
1019	(loop (if (pred ni nbest)
1020	(if (and (##core#inline "C_blockp" nbest)
1021	(##core#inline "C_flonump" nbest)
1022	(not (##core#inline "C_blockp" ni)) )
1023	(exact->inexact ni)
1024	ni)
1025	nbest)
1026	(##sys#slot ns 1) ) ) ) ) ) ] )
1027
1028	(set! max (lambda (n1 . ns) (maxmin n1 ns >)))
1029	(set! min (lambda (n1 . ns) (maxmin n1 ns <))) ) )
1030
1031	(define (exp n)
1032	(##core#inline_allocate ("C_a_i_exp" 4) n) )
1033
1034	(define (log n)
1035	(##core#inline_allocate ("C_a_i_log" 4) n) )
1036
1037	(define (sin n)
1038	(##core#inline_allocate ("C_a_i_sin" 4) n) )
1039
1040	(define (cos n)
1041	(##core#inline_allocate ("C_a_i_cos" 4) n) )
1042
1043	(define (tan n)
1044	(##core#inline_allocate ("C_a_i_tan" 4) n) )
1045
1046	(define (asin n)
1047	(##core#inline_allocate ("C_a_i_asin" 4) n) )
1048
1049	(define (acos n)
1050	(##core#inline_allocate ("C_a_i_acos" 4) n) )
1051
1052	(define (sqrt n)
1053	(##core#inline_allocate ("C_a_i_sqrt" 4) n) )
1054
1055	(define (atan n1 . n2)
1056	(if (null? n2)
1057	(##core#inline_allocate ("C_a_i_atan" 4) n1)
1058	(let ([n2 (car n2)])
1059	(##core#inline_allocate ("C_a_i_atan2" 4) n1 n2) ) ) )
1060
1061	(define ##sys#gcd
1062	(let ((remainder remainder))
1063	(lambda (x y)
1064	(let loop ((x x) (y y))
1065	(if (zero? y)
1066	(abs x)
1067	(loop y (remainder x y)) ) ) ) ) )
1068
1069	(define (gcd . ns)
1070	(if (eq? ns '())
1071	0
1072	(let loop ([ns ns] [f #t])
1073	(let ([head (##sys#slot ns 0)]
1074	[next (##sys#slot ns 1)] )
1075	(cond-expand [unsafe] [else (when f (##sys#check-integer head 'gcd))])
1076	(if (null? next)
1077	(abs head)
1078	(let ([n2 (##sys#slot next 0)])
1079	(cond-expand [unsafe] [else (##sys#check-integer n2 'gcd)])
1080	(loop (cons (##sys#gcd head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
1081
1082	(define (##sys#lcm x y)
1083	(quotient (* x y) (##sys#gcd x y)) )
1084
1085	(define (lcm . ns)
1086	(if (null? ns)
1087	1
1088	(let loop ([ns ns] [f #t])
1089	(let ([head (##sys#slot ns 0)]
1090	[next (##sys#slot ns 1)] )
1091	(cond-expand [unsafe] [else (when f (##sys#check-integer head 'lcm))])
1092	(if (null? next)
1093	(abs head)
1094	(let ([n2 (##sys#slot next 0)])
1095	(cond-expand [unsafe] [else (##sys#check-integer n2 'lcm)])
1096	(loop (cons (##sys#lcm head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )
1097
1098	(define ##sys#string->number (##core#primitive "C_string_to_number"))
1099	(define string->number ##sys#string->number)
1100	(define ##sys#number->string (##core#primitive "C_number_to_string"))
1101	(define number->string ##sys#number->string)
1102
1103	(define (flonum-print-precision #!optional prec)
1104	(let ([prev (##core#inline "C_get_print_precision")])
1105	(when prec
1106	(##sys#check-exact prec 'flonum-print-precision)
1107	(##core#inline "C_set_print_precision" prec) )
1108	prev ) )
1109
1110
1111	;;; Symbols:
1112
1113	(define ##sys#make-symbol (##core#primitive "C_make_symbol"))
1114	(define (symbol? x) (##core#inline "C_i_symbolp" x))
1115	(define ##sys#snafu '##sys#fnord)
1116	(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))
1117	(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))
1118
1119	(define (##sys#string->symbol str)
1120	(##sys#check-string str)
1121	(##sys#intern-symbol str) )
1122
1123	(define ##sys#symbol->string)
1124	(define ##sys#symbol->qualified-string)
1125	(define ##sys#qualified-symbol-prefix)
1126
1127	(let ([string-append string-append]
1128	[string-copy string-copy] )
1129
1130	(define (split str len)
1131	(let ([b0 (##sys#byte str 0)]) ; we fetch the byte, wether len is 0 or not
1132	(if (and (fx> len 0) (fx< b0 len) (fx<= b0 namespace-max-id-len))
1133	(fx+ b0 1)
1134	#f) ) )
1135
1136	(set! ##sys#symbol->string
1137	(lambda (s)
1138	(let* ([str (##sys#slot s 1)]
1139	[len (##sys#size str)]
1140	[i (split str len)] )
1141	(if i (##sys#substring str i len) str) ) ) )
1142
1143	(set! ##sys#symbol->qualified-string
1144	(lambda (s)
1145	(let* ([str (##sys#slot s 1)]
1146	[len (##sys#size str)]
1147	[i (split str len)] )
1148	(if i
1149	(string-append "##" (##sys#substring str 1 i) "#" (##sys#substring str i len))
1150	str) ) ) )
1151
1152	(set! ##sys#qualified-symbol-prefix
1153	(lambda (s)
1154	(let* ([str (##sys#slot s 1)]
1155	[len (##sys#size str)]
1156	[i (split str len)] )
1157	(and i (##sys#substring str 0 i)) ) ) ) )
1158
1159	(define (##sys#qualified-symbol? s)
1160	(let ((str (##sys#slot s 1)))
1161	(and (fx> (##sys#size str) 0)
1162	(fx<= (##sys#byte str 0) namespace-max-id-len))))
1163
1164	(define ##sys#string->qualified-symbol
1165	(lambda (prefix str)
1166	(##sys#string->symbol
1167	(if prefix
1168	(##sys#string-append prefix str)
1169	str) ) ) )
1170
1171	(define (symbol->string s)
1172	(##sys#check-symbol s 'symbol->string)
1173	(string-copy (##sys#symbol->string s) ) )
1174
1175	(define string->symbol
1176	(let ([string-copy string-copy])
1177	(lambda (str)
1178	(##sys#check-string str 'string->symbol)
1179	(##sys#intern-symbol (string-copy str)) ) ) )
1180
1181	(define string->uninterned-symbol
1182	(let ([string-copy string-copy])
1183	(lambda (str)
1184	(##sys#check-string str 'string->uninterned-symbol)
1185	(##sys#make-symbol (string-copy str)) ) ) )
1186
1187	(define gensym
1188	(let ([counter -1])
1189	(lambda str-or-sym
1190	(let ([err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))])
1191	(set! counter (fx+ counter 1))
1192	(##sys#make-symbol
1193	(##sys#string-append
1194	(if (eq? str-or-sym '())
1195	"g"
1196	(let ([prefix (car str-or-sym)])
1197	(or (and (##core#inline "C_blockp" prefix)
1198	(cond [(##core#inline "C_stringp" prefix) prefix]
1199	[(##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix)]
1200	[else (err prefix)] ) )
1201	(err prefix) ) ) )
1202	(##sys#number->string counter) ) ) ) ) ) )
1203
1204
1205	;;; Keywords:
1206
1207	(define (keyword? x)
1208	(and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0))) )
1209
1210	(define string->keyword
1211	(let ([string string] )
1212	(lambda (s)
1213	(##sys#check-string s 'string->keyword)
1214	(##sys#intern-symbol (##sys#string-append (string (integer->char 0)) s)) ) ) )
1215
1216	(define keyword->string
1217	(let ([keyword? keyword?])
1218	(lambda (kw)
1219	(if (keyword? kw)
1220	(##sys#symbol->string kw)
1221	(##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )
1222
1223	(define (##sys#get-keyword key args0 . default)
1224	(##sys#check-list args0 'get-keyword)
1225	(let ([a (memq key args0)])
1226	(if a
1227	(let ([r (##sys#slot a 1)])
1228	(if (pair? r)
1229	(##sys#slot r 0)
1230	(##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
1231	(and (pair? default) ((car default))) ) ) )
1232
1233	(define get-keyword ##sys#get-keyword)
1234
1235
1236	;;; Blob:
1237
1238	(define (##sys#make-blob size)
1239	(let ([bv (##sys#allocate-vector size #t #f #t)])
1240	(##core#inline "C_string_to_bytevector" bv)
1241	bv) )
1242
1243	(define (make-blob size)
1244	(##sys#check-exact size 'make-blob)
1245	(##sys#make-blob size) )
1246
1247	(define (blob? x)
1248	(and (##core#inline "C_blockp" x)
1249	(##core#inline "C_bytevectorp" x) ) )
1250
1251	(define (blob-size bv)
1252	(##sys#check-blob bv 'blob-size)
1253	(##sys#size bv) )
1254
1255	(define (string->blob s)
1256	(##sys#check-string s 'string->blob)
1257	(let* ([n (##sys#size s)]
1258	[bv (##sys#make-blob n)] )
1259	(##core#inline "C_copy_memory" bv s n)
1260	bv) )
1261
1262	(define (blob->string bv)
1263	(##sys#check-blob bv 'blob->string)
1264	(let* ([n (##sys#size bv)]
1265	[s (##sys#make-string n)] )
1266	(##core#inline "C_copy_memory" s bv n)
1267	s) )
1268
1269	(define (blob=? b1 b2)
1270	(##sys#check-blob b1 'blob=?)
1271	(##sys#check-blob b2 'blob=?)
1272	(let ((n (##sys#size b1)))
1273	(and (eq? (##sys#size b2) n)
1274	(zero? (##core#inline "C_string_compare" b1 b2 n)))))
1275
1276
1277	;;; Vectors:
1278
1279	(define (vector? x) (##core#inline "C_i_vectorp" x))
1280	(define (vector-length v) (##core#inline "C_i_vector_length" v))
1281	(define (vector-ref v i) (##core#inline "C_i_vector_ref" v i))
1282	(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x))
1283
1284	(define (##sys#make-vector size . fill)
1285	(##sys#check-exact size 'make-vector)
1286	(cond-expand [unsafe] [else (when (fx< size 0) (##sys#error 'make-vector "size is negative" size))])
1287	(##sys#allocate-vector
1288	size #f
1289	(if (null? fill)
1290	(##core#undefined)
1291	(car fill) )
1292	#f) )
1293
1294	(define make-vector ##sys#make-vector)
1295
1296	(define (list->vector lst0)
1297	(cond-expand
1298	[unsafe
1299	(let* ([len (length lst0)]
1300	[v (##sys#make-vector len)] )
1301	(let loop ([lst lst0]
1302	[i 0])
1303	(if (null? lst)
1304	v
1305	(begin
1306	(##sys#setslot v i (##sys#slot lst 0))
1307	(loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
1308	[else
1309	(if (not (list? lst0))
1310	(##sys#error-not-a-proper-list lst0 'list->vector)
1311	(let* ([len (length lst0)]
1312	[v (##sys#make-vector len)] )
1313	(let loop ([lst lst0]
1314	[i 0])
1315	(if (null? lst)
1316	v
1317	(begin
1318	(##sys#setslot v i (##sys#slot lst 0))
1319	(loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
1320	))
1321
1322	(define (vector->list v)
1323	(##sys#check-vector v 'vector->list)
1324	(let ((len (##core#inline "C_block_size" v)))
1325	(let loop ((i 0))
1326	(if (fx>= i len)
1327	'()
1328	(cons (##sys#slot v i)
1329	(loop (fx+ i 1)) ) ) ) ) )
1330
1331	(define (vector . xs)
1332	(##sys#list->vector xs) )
1333
1334	(define (vector-fill! v x)
1335	(##sys#check-vector v 'vector-fill!)
1336	(let ((len (##core#inline "C_block_size" v)))
1337	(do ((i 0 (fx+ i 1)))
1338	((fx>= i len))
1339	(##sys#setslot v i x) ) ) )
1340
1341	(define (vector-copy! from to . n)
1342	(##sys#check-vector from 'vector-copy!)
1343	(##sys#check-vector to 'vector-copy!)
1344	(let* ([len-from (##sys#size from)]
1345	[len-to (##sys#size to)]
1346	[n (if (pair? n) (car n) (fxmin len-to len-from))] )
1347	(##sys#check-exact n 'vector-copy!)
1348	(cond-expand
1349	[(not unsafe)
1350	(when (or (fx> n len-to) (fx> n len-from))
1351	(##sys#signal-hook
1352	#:bounds-error 'vector-copy!
1353	"cannot copy vector - count exceeds length" from to n) ) ]
1354	[else] )
1355	(do ([i 0 (fx+ i 1)])
1356	((fx>= i n))
1357	(##sys#setslot to i (##sys#slot from i)) ) ) )
1358
1359	(define (vector-resize v n #!optional init)
1360	(##sys#check-vector v 'vector-resize)
1361	(##sys#check-exact n 'vector-resize)
1362	(##sys#grow-vector v n init) )
1363
1364	(define (##sys#grow-vector v n init)
1365	(let ([v2 (##sys#make-vector n init)]
1366	[len (##sys#size v)] )
1367	(do ([i 0 (fx+ i 1)])
1368	((fx>= i len) v2)
1369	(##sys#setslot v2 i (##sys#slot v i)) ) ) )
1370
1371
1372	;;; Characters:
1373
1374	(define (char? x) (##core#inline "C_charp" x))
1375
1376	(define (char->integer c)
1377	(##sys#check-char c 'char->integer)
1378	(##core#inline "C_fix" (##core#inline "C_character_code" c)) )
1379
1380	(define (integer->char n)
1381	(##sys#check-exact n 'integer->char)
1382	(##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
1383
1384	(define (char=? c1 c2)
1385	(##sys#check-char c1 'char=?)
1386	(##sys#check-char c2 'char=?)
1387	(eq? c1 c2) )
1388
1389	(define (char>? c1 c2)
1390	(##sys#check-char c1 'char>?)
1391	(##sys#check-char c2 'char>?)
1392	(fx> c1 c2) )
1393
1394	(define (char<? c1 c2)
1395	(##sys#check-char c1 'char<?)
1396	(##sys#check-char c2 'char<?)
1397	(fx< c1 c2) )
1398
1399	(define (char>=? c1 c2)
1400	(##sys#check-char c1 'char>=?)
1401	(##sys#check-char c2 'char>=?)
1402	(fx>= c1 c2) )
1403
1404	(define (char<=? c1 c2)
1405	(##sys#check-char c1 'char<=?)
1406	(##sys#check-char c2 'char<=?)
1407	(fx<= c1 c2) )
1408
1409	(define (char-upcase c)
1410	(##sys#check-char c 'char-upcase)
1411	(##core#inline "C_u_i_char_upcase" c))
1412
1413	(define (char-downcase c)
1414	(##sys#check-char c 'char-downcase)
1415	(##core#inline "C_u_i_char_downcase" c))
1416
1417	(define char-ci=?)
1418	(define char-ci>?)
1419	(define char-ci<?)
1420	(define char-ci>=?)
1421	(define char-ci<=?)
1422
1423	(let ((char-downcase char-downcase))
1424	(set! char-ci=? (lambda (x y) (eq? (char-downcase x) (char-downcase y))))
1425	(set! char-ci>? (lambda (x y) (fx> (char-downcase x) (char-downcase y))))
1426	(set! char-ci<? (lambda (x y) (fx< (char-downcase x) (char-downcase y))))
1427	(set! char-ci>=? (lambda (x y) (fx>= (char-downcase x) (char-downcase y))))
1428	(set! char-ci<=? (lambda (x y) (fx<= (char-downcase x) (char-downcase y)))) )
1429
1430	(define (char-upper-case? c)
1431	(##sys#check-char c 'char-upper-case?)
1432	(##core#inline "C_u_i_char_upper_casep" c) )
1433
1434	(define (char-lower-case? c)
1435	(##sys#check-char c 'char-lower-case?)
1436	(##core#inline "C_u_i_char_lower_casep" c) )
1437
1438	(define (char-numeric? c)
1439	(##sys#check-char c 'char-numeric?)
1440	(##core#inline "C_u_i_char_numericp" c) )
1441
1442	(define (char-whitespace? c)
1443	(##sys#check-char c 'char-whitespace?)
1444	(##core#inline "C_u_i_char_whitespacep" c) )
1445
1446	(define (char-alphabetic? c)
1447	(##sys#check-char c 'char-alphabetic?)
1448	(##core#inline "C_u_i_char_alphabeticp" c) )
1449
1450	(define char-name
1451	(let ([chars-to-names (make-vector char-name-table-size '())]
1452	[names-to-chars '()] )
1453	(define (lookup-char c)
1454	(let* ([code (char->integer c)]
1455	[key (##core#inline "C_fixnum_modulo" code char-name-table-size)] )
1456	(let loop ([b (##sys#slot chars-to-names key)])
1457	(and (pair? b)
1458	(let ([a (##sys#slot b 0)])
1459	(if (eq? (##sys#slot a 0) c)
1460	a
1461	(loop (##sys#slot b 1)) ) ) ) ) ) )
1462	(lambda (x . y)
1463	(let ([chr (if (pair? y) (car y) #f)])
1464	(cond [(char? x)
1465	(and-let* ([a (lookup-char x)])
1466	(##sys#slot a 1) ) ]
1467	[chr
1468	(##sys#check-symbol x 'char-name)
1469	(##sys#check-char chr 'char-name)
1470	(when (fx< (##sys#size (##sys#slot x 1)) 2)
1471	(##sys#signal-hook #:type-error 'char-name "invalid character name" x) )
1472	(let ([a (lookup-char chr)])
1473	(if a
1474	(let ([b (assq x names-to-chars)])
1475	(##sys#setslot a 1 x)
1476	(if b
1477	(##sys#setislot b 1 chr)
1478	(set! names-to-chars (cons (cons x chr) names-to-chars)) ) )
1479	(let ([key (##core#inline "C_fixnum_modulo" (char->integer chr) char-name-table-size)])
1480	(set! names-to-chars (cons (cons x chr) names-to-chars))
1481	(##sys#setslot
1482	chars-to-names key
1483	(cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ]
1484	[else
1485	(##sys#check-symbol x 'char-name)
1486	(and-let* ([a (assq x names-to-chars)])
1487	(##sys#slot a 1) ) ] ) ) ) ) )
1488
1489	(char-name 'space #\space)
1490	(char-name 'tab #\tab)
1491	(char-name 'linefeed #\linefeed)
1492	(char-name 'newline #\newline)
1493	(char-name 'vtab (integer->char 11))
1494	(char-name 'delete (integer->char 127))
1495	(char-name 'esc (integer->char 27))
1496	(char-name 'alarm (integer->char 7))
1497	(char-name 'nul (integer->char 0))
1498	(char-name 'return #\return)
1499	(char-name 'page (integer->char 12))
1500	(char-name 'backspace (integer->char 8))
1501
1502
1503	;;; Procedures:
1504
1505	(define (procedure? x) (##core#inline "C_i_closurep" x))
1506	(define apply (##core#primitive "C_apply"))
1507	(define ##sys#call-with-current-continuation (##core#primitive "C_call_cc"))
1508	(define (##sys#call-with-direct-continuation k) (##core#app k (##core#inline "C_direct_continuation" #f)))
1509	(define ##sys#call-with-cthulhu (##core#primitive "C_call_with_cthulhu"))
1510	(define (##sys#direct-return dk x) (##core#inline "C_direct_return" dk x))
1511	(define values (##core#primitive "C_values"))
1512	(define ##sys#call-with-values (##core#primitive "C_call_with_values"))
1513	(define call-with-values ##sys#call-with-values)
1514
1515	(define (##sys#for-each p lst0)
1516	(let loop ((lst lst0))
1517	(cond-expand
1518	[unsafe
1519	(if (eq? lst '())
1520	(##core#undefined)
1521	(begin
1522	(p (##sys#slot lst 0))
1523	(loop (##sys#slot lst 1)) ) ) ]
1524	[else
1525	(cond ((eq? lst '()) (##core#undefined))
1526	((pair? lst)
1527	(p (##sys#slot lst 0))
1528	(loop (##sys#slot lst 1)) )
1529	(else (##sys#error-not-a-proper-list lst0 'for-each)) ) ] ) ) )
1530
1531	(define (##sys#map p lst0)
1532	(let loop ((lst lst0))
1533	(cond-expand
1534	[unsafe
1535	(if (eq? lst '())
1536	lst
1537	(cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) ) ]
1538	[else
1539	(cond ((eq? lst '()) lst)
1540	((pair? lst)
1541	(cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )
1542	(else (##sys#error-not-a-proper-list lst0 'map)) ) ] ) ) )
1543
1544	(define for-each)
1545	(define map)
1546
1547	(let ([car car]
1548	[cdr cdr] )
1549	(letrec ((mapsafe
1550	(lambda (p lsts start loc)
1551	(if (eq? lsts '())
1552	lsts
1553	(let ((item (##sys#slot lsts 0)))
1554	(cond ((eq? item '())
1555	(cond-expand [unsafe (##core#undefined)]
1556	[else (check lsts start loc)] ) )
1557	((pair? item)
1558	(cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
1559	(else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
1560	(check
1561	(lambda (lsts start loc)
1562	(if (or (not start)
1563	(let loop ((lsts lsts))
1564	(and (not (eq? lsts '()))
1565	(not (eq? (##sys#slot lsts 0) '()))
1566	(loop (##sys#slot lsts 1)) ) ) )
1567	(##sys#error loc "lists are not of same length" lsts) ) ) ) )
1568
1569	(set! for-each
1570	(lambda (fn lst1 . lsts)
1571	(if (null? lsts)
1572	(##sys#for-each fn lst1)
1573	(let loop ((all (cons lst1 lsts)))
1574	(let ((first (##sys#slot all 0)))
1575	(cond ((pair? first)
1576	(apply fn (mapsafe car all #t 'for-each))
1577	(loop (mapsafe cdr all #t 'for-each)) )
1578	(else (check all #t 'for-each)) ) ) ) ) ) )
1579
1580	(set! map
1581	(lambda (fn lst1 . lsts)
1582	(if (null? lsts)
1583	(##sys#map fn lst1)
1584	(let loop ((all (cons lst1 lsts)))
1585	(let ((first (##sys#slot all 0)))
1586	(cond ((pair? first)
1587	(cons (apply fn (mapsafe car all #t 'map))
1588	(loop (mapsafe cdr all #t 'map)) ) )
1589	(else (check (##core#inline "C_i_cdr" all) #t 'map)
1590	'() ) ) ) ) ) ) ) ) )
1591
1592
1593	;;; dynamic-wind:
1594	;
1595	; (taken more or less directly from SLIB)
1596	;
1597	; This implementation is relatively costly: we have to shadow call/cc
1598	; with a new version that unwinds suspended thunks, but for this to
1599	; happen the return-values of the escaping procedure have to be saved
1600	; temporarily in a list. Since call/cc is very efficient under this
1601	; implementation, and because allocation of memory that is to be
1602	; garbage soon has also quite low overhead, the performance-penalty
1603	; might be acceptable (ctak needs about 4 times longer).
1604
1605	(define ##sys#dynamic-winds '())
1606
1607	(define (dynamic-wind before thunk after)
1608	(before)
1609	(set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
1610	(##sys#call-with-values
1611	thunk
1612	(lambda results
1613	(set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
1614	(after)
1615	(apply ##sys#values results) ) ) )
1616
1617	(define ##sys#dynamic-wind dynamic-wind)
1618
1619	(define (call-with-current-continuation proc)
1620	(let ((winds ##sys#dynamic-winds))
1621	(##sys#call-with-current-continuation
1622	(lambda (cont)
1623	(proc
1624	(lambda results
1625	(unless (eq? ##sys#dynamic-winds winds)
1626	(##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
1627	(apply cont results) ) ) ) ) ) )
1628
1629	(define call/cc call-with-current-continuation)
1630
1631	(define (##sys#dynamic-unwind winds n)
1632	(cond [(eq? ##sys#dynamic-winds winds)]
1633	[(fx< n 0)
1634	(##sys#dynamic-unwind (##sys#slot winds 1) (fx+ n 1))
1635	((##sys#slot (##sys#slot winds 0) 0))
1636	(set! ##sys#dynamic-winds winds) ]
1637	[else
1638	(let ([after (##sys#slot (##sys#slot ##sys#dynamic-winds 0) 1)])
1639	(set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
1640	(after)
1641	(##sys#dynamic-unwind winds (fx- n 1)) ) ] ) )
1642
1643	(define (continuation-capture proc)
1644	(let ([winds ##sys#dynamic-winds]
1645	[k (##core#inline "C_direct_continuation" #f)] )
1646	(proc (##sys#make-structure 'continuation k winds))) )
1647
1648	(define (continuation? x)
1649	(##sys#structure? x 'continuation) )
1650
1651	(define ##sys#continuation-graft (##core#primitive "C_continuation_graft"))
1652
1653	(define (continuation-graft k thunk)
1654	(##sys#check-structure k 'continuation 'continuation-graft)
1655	(let ([winds (##sys#slot k 2)])
1656	(unless (eq? ##sys#dynamic-winds winds)
1657	(##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
1658	(##sys#continuation-graft k thunk) ) )
1659
1660	(define continuation-return
1661	(let ([continuation-graft continuation-graft])
1662	(lambda (k . vals)
1663	(##sys#check-structure k 'continuation 'continuation-return)
1664	(continuation-graft k (lambda () (apply values vals))) ) ) )
1665
1666
1667	;;; Ports:
1668
1669	(define (port? x) (##core#inline "C_i_portp" x))
1670
1671	(define-inline (%port? x)
1672	(and (##core#inline "C_blockp" x)
1673	(##core#inline "C_portp" x)) )
1674
1675	(define (input-port? x)
1676	(and (%port? x)
1677	(##sys#slot x 1) ) )
1678
1679	(define (output-port? x)
1680	(and (%port? x)
1681	(not (##sys#slot x 1)) ) )
1682
1683	;;; Port layout:
1684	;
1685	; 0: FP (special)
1686	; 1: input/output (bool)
1687	; 2: class (vector of procedures)
1688	; 3: name (string)
1689	; 4: row (fixnum)
1690	; 5: col (fixnum)
1691	; 6: EOF (bool)
1692	; 7: type ('stream \| 'custom \| 'string \| 'socket)
1693	; 8: closed (bool)
1694	; 9: data
1695	; 10-15: reserved, port class specific
1696	;
1697	; Port-class:
1698	;
1699	; 0: (read-char PORT) -> CHAR \| EOF
1700	; 1: (peek-char PORT) -> CHAR \| EOF
1701	; 2: (write-char PORT CHAR)
1702	; 3: (write-string PORT STRING)
1703	; 4: (close PORT)
1704	; 5: (flush-output PORT)
1705	; 6: (char-ready? PORT) -> BOOL
1706	; 7: (read-string! PORT COUNT STRING START) -> COUNT'
1707	; 8: (read-line PORT LIMIT) -> STRING \| EOF
1708
1709	(define (##sys#make-port i/o class name type)
1710	(let ([port (##core#inline_allocate ("C_a_i_port" 17))])
1711	(##sys#setislot port 1 i/o)
1712	(##sys#setslot port 2 class)
1713	(##sys#setslot port 3 name)
1714	(##sys#setislot port 4 1)
1715	(##sys#setislot port 5 0)
1716	(##sys#setslot port 7 type)
1717	port) )
1718
1719	;;; Stream ports:
1720	; Input port slots:
1721	; 12: Static buffer for read-line, allocated on-demand
1722
1723	(define ##sys#stream-port-class
1724	(vector (lambda (p) ; read-char
1725	(##core#inline "C_read_char" p) )
1726	(lambda (p) ; peek-char
1727	(##core#inline "C_peek_char" p) )
1728	(lambda (p c) ; write-char
1729	(##core#inline "C_display_char" p c) )
1730	(lambda (p s) ; write-string
1731	(##core#inline "C_display_string" p s) )
1732	(lambda (p) ; close
1733	(##core#inline "C_close_file" p)
1734	(##sys#update-errno) )
1735	(lambda (p) ; flush-output
1736	(##core#inline "C_flush_output" p) )
1737	(lambda (p) ; char-ready?
1738	(##core#inline "C_char_ready_p" p) )
1739	(lambda (p n dest start) ; read-string!
1740	(let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
1741	(let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
1742	(cond [(or (not len) ; error returns EOF
1743	(eof-object? len)) ; EOF returns 0 bytes read
1744	act]
1745	[(fx< len rem)
1746	(loop (fx- rem len) (fx+ act len) (fx+ start len))]
1747	[else
1748	(fx+ act len) ] ) )))
1749	(lambda (p limit) ; read-line
1750	(if limit (##sys#check-exact limit 'read-line))
1751	(let ((sblen read-line-buffer-initial-size))
1752	(unless (##sys#slot p 12)
1753	(##sys#setslot p 12 (##sys#make-string sblen)))
1754	(let loop ([len sblen]
1755	[limit (or limit maximal-string-length)] ; guaranteed fixnum?
1756	[buffer (##sys#slot p 12)]
1757	[result ""]
1758	[f #f])
1759	(let ([n (##core#inline "fast_read_line_from_file" buffer p
1760	(fxmin limit len))])
1761	(cond [(eof-object? n) (if f result #!eof)]
1762	[(not n)
1763	(if (fx< limit len)
1764	(##sys#string-append result (##sys#substring buffer 0 limit))
1765	(loop (fx* len 2)
1766	(fx- limit len)
1767	(##sys#make-string (fx* len 2))
1768	(##sys#string-append result buffer)
1769	#t)) ]
1770	[f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
1771	(##sys#string-append result (##sys#substring buffer 0 n))]
1772	[else
1773	(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
1774	(##sys#substring buffer 0 n)] ) ) ) ) )
1775	) )
1776
1777	(define ##sys#open-file-port (##core#primitive "C_open_file_port"))
1778
1779	(define ##sys#standard-input (##sys#make-port #t ##sys#stream-port-class "(stdin)" 'stream))
1780	(define ##sys#standard-output (##sys#make-port #f ##sys#stream-port-class "(stdout)" 'stream))
1781	(define ##sys#standard-error (##sys#make-port #f ##sys#stream-port-class "(stderr)" 'stream))
1782
1783	(##sys#open-file-port ##sys#standard-input 0 #f)
1784	(##sys#open-file-port ##sys#standard-output 1 #f)
1785	(##sys#open-file-port ##sys#standard-error 2 #f)
1786
1787	(define (##sys#check-port x . loc)
1788	(unless (%port? x)
1789	(##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "argument is not a port" x) ) )
1790
1791	(define (##sys#check-port-mode port mode . loc)
1792	(unless (eq? mode (##sys#slot port 1))
1793	(##sys#signal-hook
1794	#:type-error (and (pair? loc) (car loc))
1795	(if mode "port is not an input port" "port is not an output-port") port) ) )
1796
1797	(define (##sys#check-port* p loc)
1798	(##sys#check-port p)
1799	(when (##sys#slot p 8)
1800	(##sys#signal-hook #:file-error loc "port already closed" p) )
1801	p )
1802
1803	(define (current-input-port . arg)
1804	(if (pair? arg)
1805	(let ([p (car arg)])
1806	(##sys#check-port p 'current-input-port)
1807	(set! ##sys#standard-input p) )
1808	##sys#standard-input) )
1809
1810	(define (current-output-port . arg)
1811	(if (pair? arg)
1812	(let ([p (car arg)])
1813	(##sys#check-port p 'current-output-port)
1814	(set! ##sys#standard-output p) )
1815	##sys#standard-output) )
1816
1817	(define (current-error-port . arg)
1818	(if (pair? arg)
1819	(let ([p (car arg)])
1820	(##sys#check-port p 'current-error-port)
1821	(set! ##sys#standard-error p) )
1822	##sys#standard-error) )
1823
1824	(define (##sys#tty-port? port)
1825	(and (not (zero? (##sys#peek-unsigned-integer port 0)))
1826	(##core#inline "C_tty_portp" port) ) )
1827
1828	(define (##sys#port-data port) (##sys#slot port 9))
1829
1830	(define ##sys#platform-fixup-pathname
1831	(let* ([bp (string->symbol ((##core#primitive "C_build_platform")))]
1832	[fixsuffix (eq? bp 'mingw32)])
1833	(lambda (name)
1834	(if fixsuffix
1835	(let ([end (fx- (##sys#size name) 1)])
1836	(if (fx>= end 0)
1837	(let ([c (##core#inline "C_subchar" name end)])
1838	(if (or (eq? c #\\) (eq? c #\/))
1839	(##sys#substring name 0 end)
1840	name) )
1841	name) )
1842	name) ) ) )
1843
1844	(define (##sys#pathname-resolution name thunk . _)
1845	(thunk (##sys#expand-home-path name)) )
1846
1847	(define ##sys#expand-home-path
1848	(let ((getenv getenv))
1849	(lambda (path)
1850	(let ((len (##sys#size path)))
1851	(if (fx> len 0)
1852	(case (##core#inline "C_subchar" path 0)
1853	((#\~)
1854	(let ((rest (##sys#substring path 1 len)))
1855	(if (and (fx> len 1) (char=? #\/ (##core#inline "C_subchar" path 1)))
1856	(##sys#string-append (or (getenv "HOME") "") rest)
1857	(##sys#string-append "/home/" rest) ) ) )
1858	((#\$)
1859	(let loop ((i 1))
1860	(if (fx>= i len)
1861	path
1862	(let ((c (##core#inline "C_subchar" path i)))
1863	(if (or (eq? c #\/) (eq? c #\\))
1864	(##sys#string-append
1865	(or (getenv (##sys#substring path 1 i)) "")
1866	(##sys#substring path i len))
1867	(loop (fx+ i 1)) ) ) ) ) )
1868	(else path) )
1869	"") ) ) ) )
1870
1871	(define open-input-file)
1872	(define open-output-file)
1873	(define close-input-port)
1874	(define close-output-port)
1875
1876	(let ()
1877
1878	(define (open name inp modes loc)
1879	(##sys#check-string name loc)
1880	(##sys#pathname-resolution
1881	name
1882	(lambda (name)
1883	(let ([fmode (if inp "r" "w")]
1884	[bmode ""] )
1885	(do ([modes modes (##sys#slot modes 1)])
1886	((null? modes))
1887	(let ([o (##sys#slot modes 0)])
1888	(case o
1889	[(#:binary) (set! bmode "b")]
1890	[(#:text) (set! bmode "")]
1891	[(#:append)
1892	(if inp
1893	(##sys#error loc "cannot use append mode with input file")
1894	(set! fmode "a") ) ]
1895	[else (##sys#error loc "invalid file option" o)] ) ) )
1896	(let ([port (##sys#make-port inp ##sys#stream-port-class name 'stream)])
1897	(unless (##sys#open-file-port port name (##sys#string-append fmode bmode))
1898	(##sys#update-errno)
1899	(##sys#signal-hook #:file-error loc (##sys#string-append "cannot open file - " strerror) name) )
1900	port) ) )
1901	#:open (not inp) modes) )
1902
1903	(define (close port loc)
1904	(##sys#check-port port loc)
1905	(unless (##sys#slot port 8) ; closed?
1906	((##sys#slot (##sys#slot port 2) 4) port) ; close
1907	(##sys#setislot port 8 #t) )
1908	(##core#undefined) )
1909
1910	(set! open-input-file (lambda (name . mode) (open name #t mode 'open-input-file)))
1911	(set! open-output-file (lambda (name . mode) (open name #f mode 'open-output-file)))
1912	(set! close-input-port (lambda (port) (close port 'close-input-port)))
1913	(set! close-output-port (lambda (port) (close port 'close-output-port))) )
1914
1915	(define call-with-input-file
1916	(let ([open-input-file open-input-file]
1917	[close-input-port close-input-port] )
1918	(lambda (name p . mode)
1919	(let ([f (apply open-input-file name mode)])
1920	(##sys#call-with-values
1921	(lambda () (p f))
1922	(lambda results
1923	(close-input-port f)
1924	(apply ##sys#values results) ) ) ) ) ) )
1925
1926	(define call-with-output-file
1927	(let ([open-output-file open-output-file]
1928	[close-output-port close-output-port] )
1929	(lambda (name p . mode)
1930	(let ([f (apply open-output-file name mode)])
1931	(##sys#call-with-values
1932	(lambda () (p f))
1933	(lambda results
1934	(close-output-port f)
1935	(apply ##sys#values results) ) ) ) ) ) )
1936
1937	(define with-input-from-file
1938	(let ((open-input-file open-input-file)
1939	(close-input-port close-input-port) )
1940	(lambda (str thunk . mode)
1941	(let ((old ##sys#standard-input)
1942	(file (apply open-input-file str mode)) )
1943	(set! ##sys#standard-input file)
1944	(##sys#call-with-values thunk
1945	(lambda results
1946	(close-input-port file)
1947	(set! ##sys#standard-input old)
1948	(apply ##sys#values results) ) ) ) ) ) )
1949
1950	(define with-output-to-file
1951	(let ((open-output-file open-output-file)
1952	(close-output-port close-output-port) )
1953	(lambda (str thunk . mode)
1954	(let ((old ##sys#standard-output)
1955	(file (apply open-output-file str mode)) )
1956	(set! ##sys#standard-output file)
1957	(##sys#call-with-values thunk
1958	(lambda results
1959	(close-output-port file)
1960	(set! ##sys#standard-output old)
1961	(apply ##sys#values results) ) ) ) ) ) )
1962
1963	(define (file-exists? name)
1964	(##sys#check-string name 'file-exists?)
1965	(##sys#pathname-resolution
1966	name
1967	(lambda (name)
1968	(and (##sys#file-info (##sys#platform-fixup-pathname name)) name) )
1969	#:exists?) )
1970
1971	(define (##sys#flush-output port)
1972	((##sys#slot (##sys#slot port 2) 5) port) ; flush-output
1973	(##core#undefined) )
1974
1975	(define (flush-output #!optional (port ##sys#standard-output))
1976	(##sys#check-port* port 'flush-output)
1977	(##sys#check-port-mode port #f 'flush-output)
1978	(##sys#flush-output port) )
1979
1980	(define (port-name #!optional (port ##sys#standard-input))
1981	(##sys#check-port port 'port-name)
1982	(##sys#slot port 3) )
1983
1984	(define (set-port-name! port name)
1985	(##sys#check-port port 'set-port-name!)
1986	(##sys#check-string name 'set-port-name!)
1987	(##sys#setslot port 3 name) )
1988
1989	(define (##sys#port-line port)
1990	(and (##sys#slot port 1)
1991	(##sys#slot port 4) ) )
1992
1993	(define (port-position #!optional (port ##sys#standard-input))
1994	(##sys#check-port port 'port-position)
1995	(if (##sys#slot port 1)
1996	(##sys#values (##sys#slot port 4) (##sys#slot port 5))
1997	(##sys#error 'port-position "cannot compute position of port" port) ) )
1998
1999	(define (delete-file filename)
2000	(##sys#check-string filename 'delete-file)
2001	(##sys#pathname-resolution
2002	filename
2003	(lambda (filename)
2004	(unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename)))
2005	(##sys#update-errno)
2006	(##sys#signal-hook
2007	#:file-error 'delete-file
2008	(##sys#string-append "cannot delete file - " strerror) filename) ) )
2009	#:delete) )
2010
2011	(define (rename-file old new)
2012	(##sys#check-string old 'rename-file)
2013	(##sys#check-string new 'rename-file)
2014	(##sys#pathname-resolution
2015	old
2016	(lambda (old)
2017	(##sys#pathname-resolution
2018	new
2019	(lambda (new)
2020	(unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old) (##sys#make-c-string new)))
2021	(##sys#update-errno)
2022	(##sys#signal-hook
2023	#:file-error 'rename-file
2024	(##sys#string-append "cannot rename file - " strerror) old new) ) ) ) )
2025	#:rename new) )
2026
2027
2028	;;; Parameters:
2029
2030	(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))
2031	(define ##sys#current-parameter-vector '#())
2032
2033	(define make-parameter
2034	(let ([count 0])
2035	(lambda (init . guard)
2036	(let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
2037	[val (guard init)]
2038	[i count] )
2039	(set! count (fx+ count 1))
2040	(when (fx>= i (##sys#size ##sys#default-parameter-vector))
2041	(set! ##sys#default-parameter-vector
2042	(##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) )
2043	(##sys#setslot ##sys#default-parameter-vector i val)
2044	(lambda arg
2045	(let ([n (##sys#size ##sys#current-parameter-vector)])
2046	(cond [(pair? arg)
2047	(when (fx>= i n)
2048	(set! ##sys#current-parameter-vector
2049	(##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
2050	(##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0)))
2051	(##core#undefined) ]
2052	[(fx>= i n)
2053	(##sys#slot ##sys#default-parameter-vector i) ]
2054	[else
2055	(let ([val (##sys#slot ##sys#current-parameter-vector i)])
2056	(if (eq? val ##sys#snafu)
2057	(##sys#slot ##sys#default-parameter-vector i)
2058	val) ) ] ) ) ) ) ) ) )
2059
2060
2061	;;; Input:
2062
2063	(define (eof-object? x) (##core#inline "C_eofp" x))
2064
2065	(define (char-ready? #!optional (port ##sys#standard-input))
2066	(##sys#check-port* port 'char-ready?)
2067	(##sys#check-port-mode port #t 'char-ready?)
2068	((##sys#slot (##sys#slot port 2) 6) port) ) ; char-ready?
2069
2070	(define (read-char #!optional (port ##sys#standard-input))
2071	(##sys#read-char/port port) )
2072
2073	(define (##sys#read-char-0 p)
2074	(let ([c (if (##sys#slot p 6)
2075	(begin
2076	(##sys#setislot p 6 #f)
2077	#!eof)
2078	((##sys#slot (##sys#slot p 2) 0) p) ) ] ) ; read-char
2079	(cond [(eq? c #\newline)
2080	(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
2081	(##sys#setislot p 5 0) ]
2082	[(not (##core#inline "C_eofp" c))
2083	(##sys#setislot p 5 (fx+ (##sys#slot p 5) 1)) ] )
2084	c) )
2085
2086	(define (##sys#read-char/port port)
2087	(##sys#check-port* port 'read-char)
2088	(##sys#check-port-mode port #t 'read-char)
2089	(##sys#read-char-0 port) )
2090
2091	(define (##sys#peek-char-0 p)
2092	(if (##sys#slot p 6)
2093	#!eof
2094	(let ([c ((##sys#slot (##sys#slot p 2) 1) p)]) ; peek-char
2095	(when (##core#inline "C_eofp" c)
2096	(##sys#setislot p 6 #t) )
2097	c) ) )
2098
2099	(define (peek-char #!optional (port ##sys#standard-input))
2100	(##sys#check-port* port 'peek-char)
2101	(##sys#check-port-mode port #t 'peek-char)
2102	(##sys#peek-char-0 port) )
2103
2104	(define (read #!optional (port ##sys#standard-input))
2105	(##sys#check-port* port 'read)
2106	(##sys#check-port-mode port #t 'read)
2107	(##sys#read port ##sys#default-read-info-hook) )
2108
2109	(define ##sys#default-read-info-hook #f)
2110	(define ##sys#read-error-with-line-number #f)
2111	(define ##sys#enable-qualifiers #t)
2112	(define (##sys#read-prompt-hook) #f) ; just here so that srfi-18 works without eval
2113	(define (##sys#infix-list-hook lst) lst)
2114
2115	(define (##sys#sharp-number-hook port n)
2116	(##sys#read-error port "invalid parameterized read syntax" n) )
2117
2118	(define case-sensitive (make-parameter #t))
2119	(define keyword-style (make-parameter #:suffix))
2120	(define parentheses-synonyms (make-parameter #t))
2121	(define symbol-escape (make-parameter #t))
2122
2123	(define current-read-table (make-parameter (##sys#make-structure 'read-table #f #f #f)))
2124
2125	(define ##sys#read-warning
2126	(let ([string-append string-append])
2127	(lambda (port msg . args)
2128	(apply
2129	##sys#warn
2130	(let ((ln (##sys#port-line port)))
2131	(if (and ##sys#read-error-with-line-number ln)
2132	(string-append msg " in line " (##sys#number->string ln))
2133	msg) )
2134	args) ) ) )
2135
2136	(define ##sys#read-error
2137	(let ([string-append string-append] )
2138	(lambda (port msg . args)
2139	(apply
2140	##sys#signal-hook
2141	#:syntax-error
2142	(let ((ln (##sys#port-line port)))
2143	(if (and ##sys#read-error-with-line-number ln)
2144	(string-append msg " in line " (##sys#number->string ln))
2145	msg) )
2146	args) ) ) )
2147
2148	(define ##sys#read
2149	(let ([reverse reverse]
2150	[list? list?]
2151	[string-append string-append]
2152	[string string]
2153	[char-name char-name]
2154	[csp case-sensitive]
2155	[ksp keyword-style]
2156	[psp parentheses-synonyms]
2157	[sep symbol-escape]
2158	[crt current-read-table]
2159	[kwprefix (string (integer->char 0))])
2160	(lambda (port infohandler)
2161	(let ([csp (csp)]
2162	[ksp (ksp)]
2163	[psp (psp)]
2164	[sep (sep)]
2165	[crt (crt)]
2166	[rat-flag #f]
2167	; set below - needs more state to make a decision
2168	(terminating-characters '(#\, #\; #$ #$ #\' #\" #\[ #\] #\{ #\}))
2169	[reserved-characters #f] )
2170
2171	(define (container c)
2172	(##sys#read-error port "unexpected list terminator" c) )
2173
2174	(define (info class data val)
2175	(if infohandler
2176	(infohandler class data val)
2177	data) )
2178
2179	(define (skip-to-eol)
2180	(let skip ((c (##sys#read-char-0 port)))
2181	(if (and (not (##core#inline "C_eofp" c)) (not (eq? #\newline c)))
2182	(skip (##sys#read-char-0 port)) ) ) )
2183
2184	(define (reserved-character c)
2185	(##sys#read-char-0 port)
2186	(##sys#read-error port "reserved character" c) )
2187
2188	(define (read-unreserved-char-0 port)
2189	(let ((c (##sys#read-char-0 port)))
2190	(if (memq c reserved-characters)
2191	(reserved-character c)
2192	c) ) )
2193
2194	(define (readrec)
2195
2196	(define (r-spaces)
2197	(let loop ([c (##sys#peek-char-0 port)])
2198	(cond ((##core#inline "C_eofp" c))
2199	((eq? #\; c)
2200	(skip-to-eol)
2201	(loop (##sys#peek-char-0 port)) )
2202	((char-whitespace? c)
2203	(##sys#read-char-0 port)
2204	(loop (##sys#peek-char-0 port)) ) ) ) )
2205
2206	(define (r-usequence u n)
2207	(let loop ([seq '()] [n n])
2208	(if (eq? n 0)
2209	(let* ([str (##sys#reverse-list->string seq)]
2210	[n (string->number str 16)])
2211	(or n
2212	(##sys#read-error port (string-append "invalid escape-sequence '\\" u str "\'")) ) )
2213	(let ([x (##sys#read-char-0 port)])
2214	(if (or (eof-object? x) (char=? #\" x))
2215	(##sys#read-error port "unterminated string constant")
2216	(loop (cons x seq) (fx- n 1)) ) ) ) ) )
2217
2218	(define (r-cons-codepoint cp lst)
2219	(let* ((s (##sys#char->utf8-string (integer->char cp)))
2220	(len (##sys#size s)))
2221	(let lp ((i 0) (lst lst))
2222	(if (fx>= i len)
2223	lst
2224	(lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
2225
2226	(define (r-string term)
2227	(if (eq? (##sys#read-char-0 port) term)
2228	(let loop ((c (##sys#read-char-0 port)) (lst '()))
2229	(cond ((##core#inline "C_eofp" c)
2230	(##sys#read-error port "unterminated string") )
2231	((eq? #\\ c)
2232	(set! c (##sys#read-char-0 port))
2233	(case c
2234	((#\t) (loop (##sys#read-char-0 port) (cons #\tab lst)))
2235	((#\r) (loop (##sys#read-char-0 port) (cons #\return lst)))
2236	((#\b) (loop (##sys#read-char-0 port) (cons #\backspace lst)))
2237	((#\n) (loop (##sys#read-char-0 port) (cons #\newline lst)))
2238	((#\a) (loop (##sys#read-char-0 port) (cons (integer->char 7) lst)))
2239	((#\v) (loop (##sys#read-char-0 port) (cons (integer->char 11) lst)))
2240	((#\f) (loop (##sys#read-char-0 port) (cons (integer->char 12) lst)))
2241	((#\x)
2242	(let ([ch (integer->char (r-usequence "x" 2))])
2243	(loop (##sys#read-char-0 port) (cons ch lst)) ) )
2244	((#\u)
2245	(let ([n (r-usequence "u" 4)])
2246	(if (##sys#unicode-surrogate? n)
2247	(if (and (eqv? #\\ (##sys#read-char-0 port))
2248	(eqv? #\u (##sys#read-char-0 port)))
2249	(let* ((m (r-usequence "u" 4))
2250	(cp (##sys#surrogates->codepoint n m)))
2251	(if cp
2252	(loop (##sys#read-char-0 port)
2253	(r-cons-codepoint cp lst))
2254	(##sys#read-error port "bad surrogate pair" n m)))
2255	(##sys#read-error port "unpaired escaped surrogate" n))
2256	(loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
2257	((#\U)
2258	(let ([n (r-usequence "U" 8)])
2259	(if (##sys#unicode-surrogate? n)
2260	(##sys#read-error port (string-append "invalid escape (surrogate)" n))
2261	(loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
2262	((#\\ #\' #\")
2263	(loop (##sys#read-char-0 port) (cons c lst)))
2264	(else
2265	(##sys#read-warning
2266	port
2267	"undefined escape sequence in string - probably forgot backslash"
2268	c)
2269	(loop (##sys#read-char-0 port) (cons c lst))) ) )
2270	((eq? term c) (##sys#reverse-list->string lst))
2271	(else (loop (##sys#read-char-0 port) (cons c lst))) ) )
2272	(##sys#read-error port (string-append "missing `" (string term) "'")) ) )
2273
2274	(define (r-list start end)
2275	(if (eq? (##sys#read-char-0 port) start)
2276	(let ([first #f]
2277	[ln0 #f]
2278	[outer-container container] )
2279	(##sys#call-with-current-continuation
2280	(lambda (return)
2281	(set! container
2282	(lambda (c)
2283	(if (eq? c end)
2284	(return #f)
2285	(##sys#read-error port "list-terminator mismatch" c end) ) ) )
2286	(let loop ([last '()])
2287	(r-spaces)
2288	(unless first (set! ln0 (##sys#port-line port)))
2289	(let ([c (##sys#peek-char-0 port)])
2290	(cond ((##core#inline "C_eofp" c)
2291	(##sys#read-error port "unterminated list") )
2292	((eq? c end)
2293	(##sys#read-char-0 port) )
2294	((eq? c #\.)
2295	(##sys#read-char-0 port)
2296	(let ([c2 (##sys#peek-char-0 port)])
2297	(cond [(or (char-whitespace? c2)
2298	(eq? c2 #\()
2299	(eq? c2 #\))
2300	(eq? c2 #\")
2301	(eq? c2 #\;) )
2302	(unless (pair? last)
2303	(##sys#read-error port "invalid use of `.'") )
2304	(r-spaces)
2305	(##sys#setslot last 1 (readrec))
2306	(r-spaces)
2307	(unless (eq? (##sys#read-char-0 port) end)
2308	(##sys#read-error port "missing list terminator" end) ) ]
2309	[else
2310	(let* ((tok (##sys#string-append "." (r-token)))
2311	(n (and (char-numeric? c2)
2312	(##sys#string->number tok)))
2313	(val (or n (resolve-symbol tok)))
2314	(node (cons val '())) )
2315	(if first
2316	(##sys#setslot last 1 node)
2317	(set! first node) )
2318	(loop node) ) ] ) ) )
2319	(else
2320	(let ([node (cons (readrec) '())])
2321	(if first
2322	(##sys#setslot last 1 node)
2323	(set! first node) )
2324	(loop node) ) ) ) ) ) ) )
2325	(set! container outer-container)
2326	(if first
2327	(info 'list-info (##sys#infix-list-hook first) ln0)
2328	'() ) )
2329	(##sys#read-error port "missing token" start) ) )
2330
2331	(define (r-vector)
2332	(let ([lst (r-list #$ #$)])
2333	(if (list? lst)
2334	(##sys#list->vector lst)
2335	(##sys#read-error port "invalid vector syntax" lst) ) ) )
2336
2337	(define (r-number radix)
2338	(set! rat-flag #f)
2339	(let ([tok (r-token)])
2340	(if (string=? tok ".")
2341	(##sys#read-error port "invalid use of `.'")
2342	(let ([val (##sys#string->number tok (or radix 10))] )
2343	(cond [val
2344	(when (and (##sys#inexact? val) rat-flag)
2345	(##sys#read-warning port "cannot represent exact fraction - coerced to flonum" tok) )
2346	val]
2347	[radix (##sys#read-error port "illegal number syntax" tok)]
2348	[else (resolve-symbol tok)] ) ) ) ) )
2349
2350	(define (r-number-with-exactness radix)
2351	(cond [(char=? #\# (##sys#peek-char-0 port))
2352	(##sys#read-char-0 port)
2353	(let ([c2 (##sys#read-char-0 port)])
2354	(cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]
2355	[(char=? c2 #\i) (##sys#exact->inexact (r-number radix))]
2356	[(char=? c2 #\e) (##sys#inexact->exact (r-number radix))]
2357	[else (##sys#read-error port "illegal number syntax - invalid exactness prefix" c2)] ) ) ]
2358	[else (r-number radix)] ) )
2359
2360	(define (r-number-with-radix)
2361	(cond [(char=? #\# (##sys#peek-char-0 port))
2362	(##sys#read-char-0 port)
2363	(let ([c2 (##sys#read-char-0 port)])
2364	(cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]
2365	[(char=? c2 #\x) (r-number 16)]
2366	[(char=? c2 #\d) (r-number 10)]
2367	[(char=? c2 #\o) (r-number 8)]
2368	[(char=? c2 #\b) (r-number 2)]
2369	[else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]
2370	[else (r-number 10)] ) )
2371
2372	(define (r-token)
2373	(let loop ([c (##sys#peek-char-0 port)] [lst '()])
2374	(cond [(or (eof-object? c)
2375	(char-whitespace? c)
2376	(memq c terminating-characters) )
2377	(##sys#reverse-list->string lst) ]
2378	[else
2379	(when (char=? c #\/) (set! rat-flag #t))
2380	(read-unreserved-char-0 port)
2381	(loop (##sys#peek-char-0 port)
2382	(cons (if csp c (char-downcase c)) lst) ) ] ) ) )
2383
2384	(define (r-digits)
2385	(let loop ((c (##sys#peek-char-0 port)) (lst '()))
2386	(cond ((or (eof-object? c) (not (char-numeric? c)))
2387	(##sys#reverse-list->string lst) )
2388	(else
2389	(##sys#read-char-0 port)
2390	(loop (##sys#peek-char-0 port) (cons c lst)) ) ) ) )
2391
2392	(define (r-next-token)
2393	(r-spaces)
2394	(r-token) )
2395
2396	(define (r-symbol)
2397	(let ((s (resolve-symbol
2398	(if (char=? (##sys#peek-char-0 port) #\\|)
2399	(r-xtoken)
2400	(r-token) ) ) ) )
2401	(info 'symbol-info s (##sys#port-line port)) ) )
2402
2403	(define (r-xtoken)
2404	(if (char=? #\\| (read-unreserved-char-0 port))
2405	(let loop ((c (##sys#read-char-0 port)) (lst '()))
2406	(cond ((eof-object? c) (##sys#read-error port "unexpected end of `\| ... \|' symbol"))
2407	((char=? c #\\)
2408	(let ((c (##sys#read-char-0 port)))
2409	(loop (##sys#read-char-0 port) (cons c lst)) ) )
2410	((char=? c #\\|)
2411	(##sys#reverse-list->string lst) )
2412	(else (loop (##sys#read-char-0 port) (cons c lst))) ) )
2413	(##sys#read-error port "missing \'\|\'") ) )
2414
2415	(define (r-char)
2416	;; Code contributed by Alex Shinn
2417	(let* ([c (##sys#peek-char-0 port)]
2418	[tk (r-token)]
2419	[len (##sys#size tk)])
2420	(cond [(fx> len 1)
2421	(cond [(and (or (char=? #\x c) (char=? #\u c) (char=? #\U c))
2422	(##sys#string->number (##sys#substring tk 1 len) 16) )
2423	=> (lambda (n) (integer->char n)) ]
2424	[(and-let* ((c0 (char->integer (##core#inline "C_subchar" tk 0)))
2425	((fx<= #xC0 c0)) ((fx<= c0 #xF7))
2426	(n0 (fxand (fxshr c0 4) 3))
2427	(n (fx+ 2 (fxand (fxior n0 (fxshr n0 1)) (fx- n0 1))))
2428	((fx= len n))
2429	(res (fx+ (fxshl (fxand c0 (fx- (fxshl 1 (fx- 8 n)) 1)) 6)
2430	(fxand (char->integer
2431	(##core#inline "C_subchar" tk 1))
2432	#b111111))))
2433	(cond ((fx>= n 3)
2434	(set! res (fx+ (fxshl res 6)
2435	(fxand
2436	(char->integer
2437	(##core#inline "C_subchar" tk 2))
2438	#b111111)))
2439	(if (fx= n 4)
2440	(set! res (fx+ (fxshl res 6)
2441	(fxand (char->integer
2442	(##core#inline "C_subchar" tk 3))
2443	#b111111))))))
2444	(integer->char res))]
2445	[(char-name (##sys#intern-symbol tk))]
2446	[else (##sys#read-error port "unknown named character" tk)] ) ]
2447	[(memq c terminating-characters) (##sys#read-char-0 port)]
2448	[else c] ) ) )
2449
2450	(define (r-comment)
2451	(let loop ((i 0))
2452	(let ((c (##sys#read-char-0 port)))
2453	(case c
2454	((#\\|) (if (eq? #\# (##sys#read-char-0 port))
2455	(if (not (eq? i 0))
2456	(loop (fx- i 1)) )
2457	(loop i) ) )
2458	((#\#) (loop (if (eq? #\\| (##sys#read-char-0 port))
2459	(fx+ i 1)
2460	i) ) )
2461	(else (if (eof-object? c)
2462	(##sys#read-error port "unterminated block-comment")
2463	(loop i) ) ) ) ) ) )
2464
2465	(define (r-ext-symbol)
2466	(let* ([p (##sys#make-string 1)]
2467	[tok (r-token)]
2468	[toklen (##sys#size tok)] )
2469	(unless ##sys#enable-qualifiers
2470	(##sys#read-error port "qualified symbol syntax is not allowed" tok) )
2471	(let loop ([i 0])
2472	(cond [(fx>= i toklen)
2473	(##sys#read-error port "invalid qualified symbol syntax" tok) ]
2474	[(fx= (##sys#byte tok i) (char->integer #\#))
2475	(when (fx> i namespace-max-id-len)
2476	(set! tok (##sys#substring tok 0 namespace-max-id-len)) )
2477	(##sys#setbyte p 0 i)
2478	(##sys#intern-symbol
2479	(string-append p (##sys#substring tok 0 i) (##sys#substring tok (fx+ i 1) toklen)) ) ]
2480	[else (loop (fx+ i 1))] ) ) ) )
2481
2482	(define (resolve-symbol tok)
2483	(let ([len (##sys#size tok)])
2484	(cond [(and (fx> len 1)
2485	(or (and (eq? ksp #:prefix)
2486	(char=? #\: (##core#inline "C_subchar" tok 0))
2487	(##sys#substring tok 1 len) )
2488	(and (eq? ksp #:suffix)
2489	(char=? #\: (##core#inline "C_subchar" tok (fx- len 1)))
2490	(##sys#substring tok 0 (fx- len 1)) ) ) )
2491	=> build-keyword] ; ugh
2492	[else (build-symbol tok)])))
2493
2494	(define (build-symbol tok)
2495	(##sys#intern-symbol tok) )
2496
2497	(define (build-keyword tok)
2498	(##sys#intern-symbol (##sys#string-append kwprefix tok)) )
2499
2500	; now have the state to make a decision.
2501	(set! reserved-characters
2502	(if psp
2503	(if sep
2504	'()
2505	'(#\[ #\] #\{ #\}) )
2506	(if sep
2507	'(#\\|)
2508	'(#\[ #\] #\{ #\} #\\|))))
2509
2510	(r-spaces)
2511	(let* ([c (##sys#peek-char-0 port)]
2512	[srst (##sys#slot crt 1)]
2513	[h (and srst (##sys#slot srst (char->integer c)) ) ] )
2514	(if h
2515	;then handled by read-table entry
2516	(h c port)
2517	;otherwise chicken extended r5rs syntax
2518	(case c
2519	((#\')
2520	(##sys#read-char-0 port)
2521	(list 'quote (readrec)) )
2522	((#\`)
2523	(##sys#read-char-0 port)
2524	(list 'quasiquote (readrec)) )
2525	((#\,)
2526	(##sys#read-char-0 port)
2527	(cond ((eq? (##sys#peek-char-0 port) #\@)
2528	(##sys#read-char-0 port)
2529	(list 'unquote-splicing (readrec)) )
2530	(else (list 'unquote (readrec))) ) )
2531	((#\#)
2532	(##sys#read-char-0 port)
2533	(let ((dchar (##sys#peek-char-0 port)))
2534	(if (char-numeric? dchar)
2535	(let* ((n (string->number (r-digits)))
2536	(dchar (##sys#peek-char-0 port))
2537	(spdrst (##sys#slot crt 3))
2538	(h (and spdrst (##sys#slot spdrst (char->integer dchar)) ) ) )
2539	;#<num> handled by parameterized # read-table entry?
2540	(cond (h (h dchar port n))
2541	;#<num>?
2542	((or (eq? dchar #\)) (char-whitespace? dchar)) (##sys#sharp-number-hook port n))
2543	(else (##sys#read-error port "invalid parameterized read syntax" dchar n) ) ) )
2544	(let* ((sdrst (##sys#slot crt 2))
2545	(h (and sdrst (##sys#slot sdrst (char->integer dchar)) ) ) )
2546	(if h
2547	;then handled by # read-table entry
2548	(h dchar port)
2549	;otherwise chicken extended r5rs syntax
2550	(case (char-downcase dchar)
2551	((#\x) (##sys#read-char-0 port) (r-number-with-exactness 16))
2552	((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10))
2553	((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8))
2554	((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2))
2555	((#\i) (##sys#read-char-0 port) (##sys#exact->inexact (r-number-with-radix)))
2556	((#\e) (##sys#read-char-0 port) (##sys#inexact->exact (r-number-with-radix)))
2557	((#\c)
2558	(##sys#read-char-0 port)
2559	(let ([c (##sys#read-char-0 port)])
2560	(fluid-let ([csp
2561	(cond [(eof-object? c)
2562	(##sys#read-error port "unexpected end of input while reading `#c...' sequence")]
2563	[(eq? c #\i) #f]
2564	[(eq? c #\s) #t]
2565	[else (##sys#read-error port "invalid case specifier in `#c...' sequence" c)] ) ] )
2566	(readrec) ) ) )
2567	((#\() (r-vector))
2568	((#\\) (##sys#read-char-0 port) (r-char))
2569	((#\\|)
2570	(##sys#read-char-0 port)
2571	(r-comment) (readrec) )
2572	((#\#)
2573	(##sys#read-char-0 port)
2574	(r-ext-symbol) )
2575	((#\;)
2576	(##sys#read-char-0 port)
2577	(readrec) (readrec) )
2578	((#\')
2579	(##sys#read-char-0 port)
2580	(list 'syntax (readrec)) )
2581	((#\`)
2582	(##sys#read-char-0 port)
2583	(list 'quasisyntax (readrec)) )
2584	((#\$)
2585	(##sys#read-char-0 port)
2586	(list 'location (readrec)) )
2587	((#\:)
2588	(##sys#read-char-0 port)
2589	(build-keyword (r-token)) )
2590	((#\%)
2591	(build-symbol (##sys#string-append "#" (r-token))) )
2592	((#\+)
2593	(##sys#read-char-0 port)
2594	(let ((tst (readrec)))
2595	(list 'cond-expand (list tst (readrec)) '(else)) ) )
2596	((#\!)
2597	(##sys#read-char-0 port)
2598	(let ((c (##sys#peek-char-0 port)))
2599	(cond ((or (char-whitespace? c) (char=? #\/ c))
2600	(skip-to-eol)
2601	(readrec) )
2602	(else
2603	(let ([tok (r-token)])
2604	(cond [(string=? "eof" tok) #!eof]
2605	[(member tok '("optional" "rest" "key"))
2606	(build-symbol (##sys#string-append "#!" tok)) ]
2607	[(string=? "current-line" tok)
2608	(##sys#slot port 4)]
2609	[(string=? "current-file" tok)
2610	(port-name port)]
2611	[else
2612	(let ((a (assq (string->symbol tok) read-marks)))
2613	(if a
2614	((##sys#slot a 1) port)
2615	(##sys#read-error port "invalid `#!' token" tok) ) ) ] ) ) ) ) ) )
2616	(else (##sys#user-read-hook dchar port)) ) ) ) ) ) )
2617	((#$ #;#$) (r-list #$ #$))
2618	((#;#$ #$) (##sys#read-char-0 port) (container c))
2619	((#\") (r-string #\"))
2620	((#\.) (r-number #f))
2621	((#\- #\+) (r-number #f))
2622	(else
2623	(cond [(eof-object? c) c]
2624	[(char-numeric? c) (r-number #f)]
2625	((memq c reserved-characters)
2626	(reserved-character c))
2627	(else
2628	(case c
2629	((#\[ #;#\]) (r-list #\[ #\]))
2630	((#\{ #;#\}) (r-list #\{ #\}))
2631	((#;#\[ #\] #;#\{ #\}) (##sys#read-char-0 port) (container c))
2632	(else (r-symbol) ) ) ) ) ) ) ) ) )
2633
2634	(readrec) ) ) ) )
2635
2636
2637	;;; This is taken from Alex Shinn's UTF8 egg:
2638
2639	(define (##sys#char->utf8-string c)
2640	(let ([i (char->integer c)])
2641	(cond [(fx<= i #x7F)
2642	(string c) ]
2643	[(fx<= i #x7FF)
2644	(string (integer->char (fxior #b11000000 (fxshr i 6)))
2645	(integer->char (fxior #b10000000 (fxand i #b111111)))) ]
2646	[(fx<= i #xFFFF)
2647	(string (integer->char (fxior #b11100000 (fxshr i 12)))
2648	(integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
2649	(integer->char (fxior #b10000000 (fxand i #b111111)))) ]
2650	[(fx<= i #x1FFFFF)
2651	(string (integer->char (fxior #b11110000 (fxshr i 18)))
2652	(integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
2653	(integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
2654	(integer->char (fxior #b10000000 (fxand i #b111111)))) ]
2655	[else
2656	(error "UTF-8 codepoint out of range:" i) ] ) ) )
2657
2658	(define (##sys#unicode-surrogate? n)
2659	(and (fx<= #xD800 n) (fx<= n #xDFFF)) )
2660
2661	;; returns #f if the inputs are not a valid surrogate pair (hi followed by lo)
2662	(define (##sys#surrogates->codepoint hi lo)
2663	(and (fx<= #xD800 hi) (fx<= hi #xDBFF)
2664	(fx<= #xDC00 lo) (fx<= lo #xDFFF)
2665	(fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16)
2666	(fxior (fxshl (fxand hi #b111111) 10)
2667	(fxand lo #b1111111111)))) )
2668
2669	;;; Hooks for user-defined read-syntax:
2670	;
2671	; - Redefine this to handle new read-syntaxes. If 'char' doesn't match
2672	; your character then call the previous handler.
2673	; - Don't forget to read 'char', it's only peeked at this point.
2674
2675	(define (##sys#user-read-hook char port)
2676	(case char
2677	;; I put it here, so the SRFI-4 unit can intercept '#f...'
2678	[(#\f #\F) (##sys#read-char-0 port) #f ]
2679	[(#\t #\T) (##sys#read-char-0 port) #t ]
2680	[else (##sys#read-error port "invalid sharp-sign read syntax" char) ] ) )
2681
2682
2683	;;; Table for specially handled read-syntax:
2684	;
2685	; - should be either #f or a 256-element vector containing procedures
2686	; - the procedure is called with two arguments, a char (peeked) and a port and should return an expression
2687
2688	(define read-marks '())
2689
2690	(define (##sys#set-read-mark! sym proc)
2691	(let ((a (assq sym read-marks)))
2692	(if a
2693	(##sys#setslot a 1 proc)
2694	(set! read-marks (cons (cons sym proc) read-marks)) ) ) )
2695
2696	(define set-read-syntax!)
2697	(define set-sharp-read-syntax!)
2698	(define set-parameterized-read-syntax!)
2699
2700	(let ((crt current-read-table))
2701
2702	(define ((syntax-setter loc slot wrap) chr proc)
2703	(cond ((symbol? chr) (##sys#set-read-mark! chr proc))
2704	(else
2705	(let ((crt (crt)))
2706	(unless (##sys#slot crt slot)
2707	(##sys#setslot crt slot (##sys#make-vector 256 #f)) )
2708	(##sys#check-char chr loc)
2709	(let ([i (char->integer chr)])
2710	(##sys#check-range i 0 256 loc)
2711	(##sys#setslot (##sys#slot crt slot) i (wrap proc)) ) ) ) ) )
2712
2713	(set! set-read-syntax!
2714	(syntax-setter
2715	'set-read-syntax! 1
2716	(lambda (proc)
2717	(lambda (_ port)
2718	(##sys#read-char-0 port)
2719	(proc port) ) ) ) )
2720
2721	(set! set-sharp-read-syntax!
2722	(syntax-setter
2723	'set-sharp-read-syntax! 2
2724	(lambda (proc)
2725	(lambda (_ port)
2726	(##sys#read-char-0 port)
2727	(proc port) ) ) ) )
2728
2729	(set! set-parameterized-read-syntax!
2730	(syntax-setter
2731	'set-parameterized-read-syntax! 3
2732	(lambda (proc)
2733	(lambda (_ port num)
2734	(##sys#read-char-0 port)
2735	(proc port num) ) ) ) ) )
2736
2737
2738	;;; Read-table operations:
2739
2740	(define (copy-read-table rt)
2741	(##sys#check-structure rt 'read-table 'copy-read-table)
2742	(##sys#make-structure
2743	'read-table
2744	(let ((t1 (##sys#slot rt 1)))
2745	(and t1 (##sys#grow-vector t1 (##sys#size t1) #f) ) )
2746	(let ((t2 (##sys#slot rt 2)))
2747	(and t2 (##sys#grow-vector t2 (##sys#size t2) #f) ) )
2748	(let ((t3 (##sys#slot rt 3)))
2749	(and t3 (##sys#grow-vector t3 (##sys#size t3) #f) ) ) ))
2750
2751
2752	;;; Output:
2753
2754	(define (##sys#write-char-0 c p)
2755	((##sys#slot (##sys#slot p 2) 2) p c) )
2756
2757	(define (##sys#write-char/port c port)
2758	(##sys#check-port* port 'write-char)
2759	(##sys#check-char c 'write-char)
2760	(##sys#write-char-0 c port) )
2761
2762	(define (write-char c #!optional (port ##sys#standard-output))
2763	(##sys#check-char c 'write-char)
2764	(##sys#check-port* port 'write-char)
2765	(##sys#check-port-mode port #f 'write-char)
2766	(##sys#write-char-0 c port) )
2767
2768	(define (newline #!optional (port ##sys#standard-output))
2769	(##sys#write-char/port #\newline port) )
2770
2771	(define (write x #!optional (port ##sys#standard-output))
2772	(##sys#check-port* port 'write)
2773	(##sys#print x #t port) )
2774
2775	(define (display x #!optional (port ##sys#standard-output))
2776	(##sys#check-port* port 'display)
2777	(##sys#print x #f port) )
2778
2779	(define-inline (*print-each lst)
2780	(for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )
2781
2782	(define (print . args)
2783	(*print-each args)
2784	(##sys#write-char-0 #\newline ##sys#standard-output)
2785	(void) )
2786
2787	(define (print* . args)
2788	(*print-each args)
2789	(##sys#flush-output ##sys#standard-output)
2790	(void) )
2791
2792	(define current-print-length (make-parameter 0))
2793	(define print-length-limit (make-parameter #f))
2794	(define ##sys#print-exit (make-parameter #f))
2795
2796	(define ##sys#print
2797	(let ([char-name char-name]
2798	[csp case-sensitive]
2799	[ksp keyword-style]
2800	[cpp current-print-length]
2801	[string-append string-append])
2802	(lambda (x readable port)
2803	(##sys#check-port-mode port #f)
2804	(let ([csp (csp)]
2805	[ksp (ksp)]
2806	[length-limit (print-length-limit)]
2807	[special-characters '(#$ #$ #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\\|)] )
2808
2809	(define (outstr port str)
2810	(if length-limit
2811	(let* ((len (##sys#size str))
2812	(cpp0 (cpp))
2813	(cpl (fx+ cpp0 len)) )
2814	(if (fx>= cpl length-limit)
2815	(cond ((fx> len 3)
2816	(let ((n (fx- length-limit cpp0)))
2817	(when (fx> n 0) (outstr0 port (##sys#substring str 0 n)))
2818	(outstr0 port "...") ) )
2819	(else (outstr0 port str)) )
2820	(outstr0 port str) )
2821	(cpp cpl) )
2822	(outstr0 port str) ) )
2823
2824	(define (outstr0 port str)
2825	((##sys#slot (##sys#slot port 2) 3) port str) )
2826
2827	(define (outchr port chr)
2828	(let ((cpp0 (cpp)))
2829	(cpp (fx+ cpp0 1))
2830	(when (and length-limit (fx>= cpp0 length-limit))
2831	(outstr0 port "...")
2832	((##sys#print-exit) #t) )
2833	((##sys#slot (##sys#slot port 2) 2) port chr) ) )
2834
2835	(define (specialchar? chr)
2836	(let ([c (char->integer chr)])
2837	(or (fx<= c 32)
2838	(fx>= c 128)
2839	(memq chr special-characters) ) ) )
2840
2841	(define (outreadablesym port str)
2842	(let ([len (##sys#size str)])
2843	(outchr port #\\|)
2844	(let loop ([i 0])
2845	(if (fx>= i len)
2846	(outchr port #\\|)
2847	(let ([c (##core#inline "C_subchar" str i)])
2848	(when (or (eq? c #\\|) (eq? c #\\)) (outchr port #\\))
2849	(outchr port c)
2850	(loop (fx+ i 1)) ) ) ) ) )
2851
2852	(define (sym-is-readable? str)
2853	(let ([len (##sys#size str)])
2854	(and (fx> len 0)
2855	(if (eq? len 1)
2856	(case (##core#inline "C_subchar" str 0)
2857	((#\. #\#) #f)
2858	(else #t) ) )
2859	(not (##core#inline "C_substring_compare" "#!" str 0 0 2))
2860	(let loop ((i (fx- len 1)))
2861	(if (eq? i 0)
2862	(let ((c (##core#inline "C_subchar" str 0)))
2863	(cond ((or (char-numeric? c)
2864	(eq? c #\+)
2865	(eq? c #\-)
2866	(eq? c #\.) )
2867	(not (##sys#string->number str)) )
2868	((specialchar? c) #f)
2869	(else #t) ) )
2870	(let ([c (##core#inline "C_subchar" str i)])
2871	(and (or csp (not (char-upper-case? c)))
2872	(not (specialchar? c))
2873	(loop (fx- i 1)) ) ) ) ) ) ) )
2874
2875	(let out ([x x])
2876	(cond ((eq? x '()) (outstr port "()"))
2877	((eq? x #t) (outstr port "#t"))
2878	((eq? x #f) (outstr port "#f"))
2879	((##core#inline "C_eofp" x) (outstr port "#!eof"))
2880	((##core#inline "C_undefinedp" x) (outstr port "#<unspecified>"))
2881	((##core#inline "C_charp" x)
2882	(cond [readable
2883	(outstr port "#\\")
2884	(let ([code (char->integer x)])
2885	(cond [(char-name x)
2886	=> (lambda (cn)
2887	(outstr port (##sys#slot cn 1)) ) ]
2888	[(fx< code 32)
2889	(outchr port #\x)
2890	(outstr port (##sys#number->string code 16)) ]
2891	[(fx> code 255)
2892	(outchr port (if (fx> code #xffff) #\U #\u))
2893	(outstr port (##sys#number->string code 16)) ]
2894	[else (outchr port x)] ) ) ]
2895	[else (outchr port x)] ) )
2896	((##core#inline "C_fixnump" x) (outstr port (##sys#number->string x)))
2897	((eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
2898	(outstr port "#<unbound value>") )
2899	((not (##core#inline "C_blockp" x)) (outstr port "#<invalid immediate object>"))
2900	((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>"))
2901	((##core#inline "C_symbolp" x)
2902	(cond [(fx= 0 (##sys#byte (##sys#slot x 1) 0))
2903	(let ([str (##sys#symbol->string x)])
2904	(case ksp
2905	[(#:prefix)
2906	(outchr port #\:)
2907	(outstr port str) ]
2908	[(#:suffix)
2909	(outstr port str)
2910	(outchr port #\:) ]
2911	[else
2912	(outstr port "#:")
2913	(outstr port str) ] ) ) ]
2914	[(memq x '(#!optional #!key #!rest)) (outstr port (##sys#slot x 1))]
2915	[else
2916	(let ([str (##sys#symbol->qualified-string x)])
2917	(if (or (not readable) (sym-is-readable? str))
2918	(outstr port str)
2919	(outreadablesym port str) ) ) ] ) )
2920	((##sys#number? x) (outstr port (##sys#number->string x)))
2921	((##core#inline "C_anypointerp" x) (outstr port (##sys#pointer->string x)))
2922	((##core#inline "C_stringp" x)
2923	(cond (readable
2924	(outchr port #\")
2925	(do ((i 0 (fx+ i 1))
2926	(c (##core#inline "C_block_size" x) (fx- c 1)) )
2927	((eq? c 0)
2928	(outchr port #\") )
2929	(let ((chr (##core#inline "C_subbyte" x i)))
2930	(case chr
2931	((34) (outstr port "\\\""))
2932	((92) (outstr port "\\\\"))
2933	(else
2934	(cond ((fx< chr 32)
2935	(outchr port #\\)
2936	(case chr
2937	((9) (outchr port #\t))
2938	((10) (outchr port #\n))
2939	((13) (outchr port #\r))
2940	((11) (outchr port #\v))
2941	((12) (outchr port #\f))
2942	((8) (outchr port #\b))
2943	(else
2944	(outchr port #\x)
2945	(when (fx< chr 16) (outchr port #\0))
2946	(outstr port (##sys#number->string chr 16)) ) ) )
2947	(else (outchr port (##core#inline "C_fix_to_char" chr)) ) ) ) ) ) ) )
2948	(else (outstr port x)) ) )
2949	((##core#inline "C_pairp" x)
2950	(outchr port #\()
2951	(out (##sys#slot x 0))
2952	(do ((x (##sys#slot x 1) (##sys#slot x 1)))
2953	((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
2954	(if (not (eq? x '()))
2955	(begin
2956	(outstr port " . ")
2957	(out x) ) )
2958	(outchr port #\)) )
2959	(outchr port #\space)
2960	(out (##sys#slot x 0)) ) )
2961	((##core#inline "C_bytevectorp" x)
2962	(if (##core#inline "C_permanentp" x)
2963	(outstr port "#<static blob of size")
2964	(outstr port "#<blob of size ") )
2965	(outstr port (number->string (##core#inline "C_block_size" x)))
2966	(outchr port #\>) )
2967	((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
2968	((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))
2969	((##core#inline "C_locativep" x) (outstr port "#<locative>"))
2970	((##core#inline "C_lambdainfop" x)
2971	(outstr port "#<lambda info ")
2972	(outstr port (##sys#lambda-info->string x))
2973	(outchr port #\>) )
2974	((##core#inline "C_portp" x)
2975	(if (##sys#slot x 1)
2976	(outstr port "#<input port \"")
2977	(outstr port "#<output port \"") )
2978	(outstr port (##sys#slot x 3))
2979	(outstr port "\">") )
2980	((##core#inline "C_vectorp" x)
2981	(let ((n (##core#inline "C_block_size" x)))
2982	(cond ((eq? 0 n)
2983	(outstr port "#()") )
2984	(else
2985	(outstr port "#(")
2986	(out (##sys#slot x 0))
2987	(do ((i 1 (fx+ i 1))
2988	(c (fx- n 1) (fx- c 1)) )
2989	((eq? c 0)
2990	(outchr port #\)) )
2991	(outchr port #\space)
2992	(out (##sys#slot x i)) ) ) ) ) )
2993	(else (##sys#error "unprintable non-immediate object encountered")) ) ) ) ) ) )
2994
2995	(define ##sys#procedure->string
2996	(let ((string-append string-append))
2997	(lambda (x)
2998	(let ((info (##sys#lambda-info x)))
2999	(if info
3000	(string-append "#<procedure " (##sys#lambda-info->string info) ">")
3001	"#<procedure>") ) ) ) )
3002
3003	(define ##sys#record-printers '())
3004
3005	(define (##sys#register-record-printer type proc)
3006	(let ([a (assq type ##sys#record-printers)])
3007	(if a
3008	(##sys#setslot a 1 proc)
3009	(set! ##sys#record-printers (cons (cons type proc) ##sys#record-printers)) )
3010	(##core#undefined) ) )
3011
3012	(define (##sys#user-print-hook x readable port)
3013	(let* ([type (##sys#slot x 0)]
3014	[a (assq type ##sys#record-printers)] )
3015	(cond [a ((##sys#slot a 1) x port)]
3016	[else
3017	(##sys#print "#<" #f port)
3018	(##sys#print (##sys#symbol->string type) #f port)
3019	(case type
3020	[(condition)
3021	(##sys#print ": " #f port)
3022	(##sys#print (##sys#slot x 1) #f port) ]
3023	[(thread)
3024	(##sys#print ": " #f port)
3025	(##sys#print (##sys#slot x 6) #f port) ] )
3026	(##sys#print #\> #f port) ] ) ) )
3027
3028	(define ##sys#with-print-length-limit
3029	(let ([call-with-current-continuation call-with-current-continuation])
3030	(lambda (limit thunk)
3031	(call-with-current-continuation
3032	(lambda (return)
3033	(parameterize ((print-length-limit limit)
3034	(##sys#print-exit return)
3035	(current-print-length 0))
3036	(thunk)))))))
3037
3038
3039	;;; Bitwise fixnum operations:
3040
3041	(define (bitwise-and . xs)
3042	(let loop ([x -1] [xs xs])
3043	(if (null? xs)
3044	x
3045	(loop (##core#inline_allocate ("C_a_i_bitwise_and" 4) x (##sys#slot xs 0))
3046	(##sys#slot xs 1)) ) ) )
3047
3048	(define (bitwise-ior . xs)
3049	(let loop ([x 0] [xs xs])
3050	(if (null? xs)
3051	x
3052	(loop (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x (##sys#slot xs 0))
3053	(##sys#slot xs 1)) ) ) )
3054
3055	(define (bitwise-xor . xs)
3056	(let loop ([x 0] [xs xs])
3057	(if (null? xs)
3058	x
3059	(loop (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x (##sys#slot xs 0))
3060	(##sys#slot xs 1)) ) ) )
3061
3062	(define (bitwise-not x)
3063	(##core#inline_allocate ("C_a_i_bitwise_not" 4) x) )
3064
3065	(define (arithmetic-shift x y)
3066	(##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x y) )
3067
3068	(define (bit-set? n i)
3069	(##core#inline "C_i_bit_setp" n i) )
3070
3071
3072	;;; String ports:
3073	;
3074	; - Port-slots:
3075	;
3076	; Input:
3077	;
3078	; 10: position
3079	; 11: len
3080	; 12: string
3081	;
3082	; Output:
3083	;
3084	; 10: position
3085	; 11: limit
3086	; 12: output
3087
3088	(define ##sys#string-port-class
3089	(letrec ([check
3090	(lambda (p n)
3091	(let* ([position (##sys#slot p 10)]
3092	[limit (##sys#slot p 11)]
3093	[output (##sys#slot p 12)]
3094	[limit2 (fx+ position n)] )
3095	(when (fx>= limit2 limit)
3096	(when (fx>= limit2 maximal-string-length)
3097	(##sys#error "string buffer full" p) )
3098	(let* ([limit3 (fxmin maximal-string-length (fx+ limit limit))]
3099	[buf (##sys#make-string limit3)] )
3100	(##sys#copy-bytes output buf 0 0 position)
3101	(##sys#setslot p 12 buf)
3102	(##sys#setislot p 11 limit3)
3103	(check p n) ) ) ) ) ] )
3104	(vector
3105	(lambda (p) ; read-char
3106	(let ([position (##sys#slot p 10)]
3107	[string (##sys#slot p 12)]
3108	[len (##sys#slot p 11)] )
3109	(if (>= position len)
3110	#!eof
3111	(let ((c (##core#inline "C_subchar" string position)))
3112	(##sys#setislot p 10 (fx+ position 1))
3113	c) ) ) )
3114	(lambda (p) ; peek-char
3115	(let ([position (##sys#slot p 10)]
3116	[string (##sys#slot p 12)]
3117	[len (##sys#slot p 11)] )
3118	(if (fx>= position len)
3119	#!eof
3120	(##core#inline "C_subchar" string position) ) ) )
3121	(lambda (p c) ; write-char
3122	(check p 1)
3123	(let ([position (##sys#slot p 10)]
3124	[output (##sys#slot p 12)] )
3125	(##core#inline "C_setsubchar" output position c)
3126	(##sys#setislot p 10 (fx+ position 1)) ) )
3127	(lambda (p str) ; write-string
3128	(let ([len (##core#inline "C_block_size" str)])
3129	(check p len)
3130	(let ([position (##sys#slot p 10)]
3131	[output (##sys#slot p 12)] )
3132	(##core#inline "C_substring_copy" str output 0 len position)
3133	(##sys#setislot p 10 (fx+ position len)) ) ) )
3134	(lambda (p) ; close
3135	(##sys#setislot p 10 (##sys#slot p 11)) )
3136	(lambda (p) #f) ; flush-output
3137	(lambda (p) ; char-ready?
3138	(fx< (##sys#slot p 10) (##sys#slot p 11)) )
3139	(lambda (p n dest start) ; read-string!
3140	(let* ((pos (##sys#slot p 10))
3141	(n2 (fx- (##sys#slot p 11) pos) ) )
3142	(when (or (not n) (fx> n n2)) (set! n n2))
3143	(##core#inline "C_substring_copy" (##sys#slot p 12) dest pos (fx+ pos n) start)
3144	(##sys#setislot p 10 (fx+ pos n))
3145	n))
3146	(lambda (p limit) ; read-line
3147	(let* ((pos (##sys#slot p 10))
3148	(size (##sys#slot p 11))
3149	(buf (##sys#slot p 12))
3150	(end (if limit (fx+ pos limit) size)))
3151	(if (fx>= pos size)
3152	#!eof
3153	(##sys#scan-buffer-line
3154	buf
3155	(if (fx> end size) size end)
3156	pos
3157	(lambda (pos2 next)
3158	(when (not (eq? pos2 next))
3159	(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) )
3160	(let ((dest (##sys#make-string (fx- pos2 pos))))
3161	(##core#inline "C_substring_copy" buf dest pos pos2 0)
3162	(##sys#setislot p 10 next)
3163	dest) ) ) ) ) ) ) ) )
3164
3165	; Invokes the eol handler when EOL or EOS is reached.
3166	(define (##sys#scan-buffer-line buf limit pos k)
3167	(let loop ((pos2 pos))
3168	(if (fx>= pos2 limit)
3169	(k pos2 pos2)
3170	(let ((c (##core#inline "C_subchar" buf pos2)))
3171	(cond ((eq? c #\newline) (k pos2 (fx+ pos2 1)))
3172	((and (eq? c #\return)
3173	(fx> limit (fx+ pos2 1))
3174	(eq? (##core#inline "C_subchar" buf (fx+ pos2 1)) #\newline) )
3175	(k pos2 (fx+ pos2 2)) )
3176	(else (loop (fx+ pos2 1))) ) ) ) ) )
3177
3178	; Scans a string, 'buf', from a start index, 'pos', to an end index,
3179	; 'lim'. During the scan the current position of the 'port' is updated to
3180	; reflect the rows & columns encountered.
3181	#; ;UNUSED (at the moment)
3182	(define (##sys#update-port-position/scan port buf pos lim)
3183	(let loop ([pos pos])
3184	(let ([bumper
3185	(lambda (cur ptr)
3186	(cond [(eq? cur ptr) ; at EOB
3187	(##sys#setislot port 5 (fx+ (##sys#slot port 5) (fx- cur pos)))
3188	#f ]
3189	[else ; at EOL
3190	(##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
3191	(##sys#setislot port 5 0)
3192	ptr ] ) ) ] )
3193	(when pos
3194	(loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
3195
3196	(define (open-input-string string)
3197	(##sys#check-string string 'open-input-string)
3198	(let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
3199	(##sys#setislot port 11 (##core#inline "C_block_size" string))
3200	(##sys#setislot port 10 0)
3201	(##sys#setslot port 12 string)
3202	port ) )
3203
3204	(define (open-output-string)
3205	(let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
3206	(##sys#setislot port 10 0)
3207	(##sys#setislot port 11 output-string-initial-size)
3208	(##sys#setslot port 12 (##sys#make-string output-string-initial-size))
3209	port ) )
3210
3211	(define (get-output-string port)
3212	(##sys#check-port port 'get-output-string)
3213	(##sys#check-port-mode port #f 'get-output-string)
3214	(if (not (eq? 'string (##sys#slot port 7)))
3215	(##sys#signal-hook
3216	#:type-error 'get-output-string "argument is not a string-output-port" port)
3217	(##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)) ) )
3218
3219	(define ##sys#print-to-string
3220	(let ([get-output-string get-output-string]
3221	[open-output-string open-output-string] )
3222	(lambda (xs)
3223	(let ([out (open-output-string)])
3224	(for-each (lambda (x) (##sys#print x #f out)) xs)
3225	(get-output-string out) ) ) ) )
3226
3227	(define ##sys#pointer->string
3228	(let ((string-append string-append))
3229	(lambda (x)
3230	(cond ((##core#inline "C_taggedpointerp" x)
3231	(string-append
3232	"#<tagged pointer "
3233	(##sys#print-to-string
3234	(let ((tag (##sys#slot x 1)))
3235	(list (if (pair? tag) (car tag) tag) ) ) )
3236	" "
3237	(##sys#number->string (##sys#pointer->address x) 16)
3238	">") )
3239	((##core#inline "C_swigpointerp" x)
3240	(string-append "#<SWIG pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") )
3241	(else
3242	(string-append "#<pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") ) ) ) ) )
3243
3244
3245	;;; Platform configuration inquiry:
3246
3247	(define software-type
3248	(let ([sym (string->symbol ((##core#primitive "C_software_type")))])
3249	(lambda () sym) ) )
3250
3251	(define machine-type
3252	(let ([sym (string->symbol ((##core#primitive "C_machine_type")))])
3253	(lambda () sym) ) )
3254
3255	(define machine-byte-order
3256	(let ([sym (string->symbol ((##core#primitive "C_machine_byte_order")))])
3257	(lambda () sym) ) )
3258
3259	(define software-version
3260	(let ([sym (string->symbol ((##core#primitive "C_software_version")))])
3261	(lambda () sym) ) )
3262
3263	(define build-platform
3264	(let ([sym (string->symbol ((##core#primitive "C_build_platform")))])
3265	(lambda () sym) ) )
3266
3267	(define c-runtime
3268	(let ([sym (string->symbol ((##core#primitive "C_c_runtime")))])
3269	(lambda () sym) ) )
3270
3271	(define ##sys#windows-platform
3272	(and (eq? 'windows (software-type))
3273	;; Still windows even if 'Linux-like'
3274	(not (eq? 'cygwin (build-platform)))) )
3275
3276	(define (chicken-version #!optional full)
3277	(define (get-config)
3278	(let ([bp (build-platform)]
3279	[st (software-type)]
3280	[sv (software-version)]
3281	[mt (machine-type)] )
3282	(define (str x)
3283	(if (eq? 'unknown x)
3284	""
3285	(string-append (symbol->string x) "-") ) )
3286	(string-append (str sv) (str st) (str bp) (##sys#symbol->string mt)) ) )
3287	(if full
3288	(let ((rev (##sys#fudge 38))
3289	(spec (string-append
3290	(if (##sys#fudge 3) " 64bit" "")
3291	(if (##sys#fudge 15) " symbolgc" "")
3292	(if (##sys#fudge 40) " manyargs" "")
3293	(if (##sys#fudge 24) " dload" "")
3294	(if (##sys#fudge 28) " ptables" "")
3295	(if (##sys#fudge 32) " gchooks" "")
3296	(if (##sys#fudge 35) " applyhook" "")
3297	(if (##sys#fudge 39) " cross" "") ) ) )
3298	(string-append
3299	"Version " +build-version+
3300	(if (not (zero? rev))
3301	(string-append
3302	" - SVN rev. " (number->string rev) "\n")
3303	"\n")
3304	(get-config)
3305	(if (zero? (##sys#size spec))
3306	""
3307	(string-append " [" spec " ]") )
3308	"\n"
3309	+build-tag+))
3310	+build-version+) )
3311
3312	(define ##sys#pathname-directory-separator #\/) ; DEPRECATED
3313
3314
3315	;;; Feature identifiers:
3316
3317	(define ##sys#->feature-id
3318	(let ([string->keyword string->keyword]
3319	[keyword? keyword?] )
3320	(define (err . args)
3321	(apply ##sys#signal-hook #:type-error "bad argument type - not a valid feature identifer" args) )
3322	(define (prefix s)
3323	(if s
3324	(##sys#string-append s "-")
3325	"") )
3326	(lambda (x)
3327	(cond [(string? x) (string->keyword x)]
3328	[(keyword? x) x]
3329	[(symbol? x) (string->keyword (##sys#symbol->string x))]
3330	[else (err x)] ) ) ) )
3331
3332	(define ##sys#features
3333	'(#:chicken #:srfi-23 #:srfi-30 #:srfi-39 #:srfi-62 #:srfi-17 #:srfi-12 #:srfi-98))
3334
3335	;; Add system features:
3336
3337	(let ((check (lambda (f)
3338	(unless (eq? 'unknown f)
3339	(set! ##sys#features (cons (##sys#->feature-id f) ##sys#features))))))
3340	(check (software-type))
3341	(check (software-version))
3342	(check (build-platform))
3343	(check (machine-type))
3344	(check (machine-byte-order)) )
3345
3346	(when (##sys#fudge 40) (set! ##sys#features (cons #:manyargs ##sys#features)))
3347	(when (##sys#fudge 24) (set! ##sys#features (cons #:dload ##sys#features)))
3348	(when (##sys#fudge 28) (set! ##sys#features (cons #:ptables ##sys#features)))
3349	(when (##sys#fudge 35) (set! ##sys#features (cons #:applyhook ##sys#features)))
3350
3351	(define (register-feature! . fs)
3352	(for-each
3353	(lambda (f)
3354	(let ([id (##sys#->feature-id f)])
3355	(unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features))) ) )
3356	fs)
3357	(##core#undefined) )
3358
3359	(define (unregister-feature! . fs)
3360	(let ([fs (map ##sys#->feature-id fs)])
3361	(set! ##sys#features
3362	(let loop ([ffs ##sys#features])
3363	(if (null? ffs)
3364	'()
3365	(let ([f (##sys#slot ffs 0)]
3366	[r (##sys#slot ffs 1)] )
3367	(if (memq f fs)
3368	(loop r)
3369	(cons f (loop r)) ) ) ) ) )
3370	(##core#undefined) ) )
3371
3372	(define (features) ##sys#features)
3373
3374	(define (##sys#feature? . ids)
3375	(let loop ([ids ids])
3376	(or (null? ids)
3377	(and (memq (##sys#->feature-id (##sys#slot ids 0)) ##sys#features)
3378	(loop (##sys#slot ids 1)) ) ) ) )
3379
3380	(define feature? ##sys#feature?)
3381
3382
3383	;;; Access backtrace:
3384
3385	(define ##sys#get-call-chain
3386	(let ((extract (foreign-lambda* nonnull-c-string ((scheme-object x)) "return((C_char *)x);")))
3387	(lambda (#!optional (start 0) (thread ##sys#current-thread))
3388	(let* ((tbl (foreign-value "C_trace_buffer_size" int))
3389	(vec (##sys#make-vector (fx* 4 tbl) #f))
3390	(r (##core#inline "C_fetch_trace" start vec))
3391	(n (if (fixnum? r) r (fx* 4 tbl))) )
3392	(let loop ((i 0))
3393	(if (fx>= i n)
3394	'()
3395	(let ((t (##sys#slot vec (fx+ i 3))))
3396	(if (or (not t) (not thread) (eq? thread t))
3397	(cons (vector (extract (##sys#slot vec i))
3398	(##sys#slot vec (fx+ i 1))
3399	(##sys#slot vec (fx+ i 2)) )
3400	(loop (fx+ i 4)) )
3401	(loop (fx+ i 4))) ) ) ) ) ) ) )
3402
3403	(define (##sys#really-print-call-chain port chain header)
3404	(when (pair? chain)
3405	(##sys#print header #f port)
3406	(for-each
3407	(lambda (info)
3408	(let ((more1 (##sys#slot info 1))
3409	(more2 (##sys#slot info 2))
3410	(t (##sys#slot info 3)))
3411	(##sys#print "\n\t" #f port)
3412	(##sys#print (##sys#slot info 0) #f port)
3413	(##sys#print "\t\t" #f port)
3414	(when more2
3415	(##sys#write-char-0 #\[ port)
3416	(##sys#print more2 #f port)
3417	(##sys#print "] " #f port) )
3418	(when more1
3419	(##sys#with-print-length-limit
3420	100
3421	(lambda ()
3422	(##sys#print more1 #t port) ) ) ) ) )
3423	chain)
3424	(##sys#print "\t<--\n" #f port) ) )
3425
3426	(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
3427	(thread ##sys#current-thread)
3428	(header "\n\tCall history:\n") )
3429	(##sys#check-port port 'print-call-chain)
3430	(##sys#check-exact start 'print-call-chain)
3431	(##sys#check-string header 'print-call-chain)
3432	(##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) )
3433
3434	(define get-call-chain ##sys#get-call-chain)
3435
3436
3437	;;; Interrupt handling:
3438
3439	(define (##sys#user-interrupt-hook)
3440	(define (break) (##sys#signal-hook #:user-interrupt #f))
3441	(if (eq? ##sys#current-thread ##sys#primordial-thread)
3442	(break)
3443	(##sys#setslot ##sys#primordial-thread 1 break) ) )
3444
3445
3446	;;; Breakpoints
3447
3448	(define ##sys#last-breakpoint #f)
3449	(define ##sys#break-in-thread #f)
3450
3451	(define (##sys#break-entry name args)
3452	;; Does _not_ unwind!
3453	(##sys#call-with-current-continuation
3454	(lambda (c)
3455	(let ((exn (##sys#make-structure
3456	'condition
3457	'(exn breakpoint)
3458	(list '(exn . message) "* breakpoint *"
3459	'(exn . arguments) (list (cons name args))
3460	'(exn . location) name
3461	'(exn . continuation) c) ) ) )
3462	(set! ##sys#last-breakpoint exn)
3463	(##sys#signal exn) ) ) ) )
3464
3465	(define (##sys#break-resume exn)
3466	(let ((a (member '(exn . continuation) (##sys#slot exn 2))))
3467	(if a
3468	((cadr a) (##core#undefined))
3469	(##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
3470
3471	(define (breakpoint #!optional name)
3472	(##sys#break-entry (or name 'breakpoint) '()) )
3473
3474
3475	;;; Single stepping
3476
3477	(define ##sys#stepped-thread #f)
3478	(define ##sys#step-ports (cons ##sys#standard-input ##sys#standard-output))
3479
3480	(define (##sys#step thunk)
3481	(when (eq? ##sys#stepped-thread ##sys#current-thread)
3482	(##sys#call-with-values
3483	(lambda ()
3484	(set! ##sys#apply-hook ##sys#step-hook)
3485	(##core#app thunk) )
3486	(lambda vals
3487	(set! ##sys#apply-hook #f)
3488	(set! ##sys#stepped-thread #f)
3489	(##sys#apply-values vals) ) ) ) )
3490
3491	(define (singlestep thunk)
3492	(unless (##sys#fudge 35)
3493	(##sys#signal-hook #:runtime-error 'singlestep "apply-hook not available") )
3494	(##sys#check-closure thunk 'singlestep)
3495	(set! ##sys#stepped-thread ##sys#current-thread)
3496	(##sys#step thunk) )
3497
3498	(define (##sys#step-hook . args)
3499	(set! ##sys#apply-hook #f)
3500	(let ((o (##sys#slot ##sys#step-ports 1))
3501	(i (##sys#slot ##sys#step-ports 0))
3502	(p ##sys#last-applied-procedure))
3503	(define (skip-to-nl)
3504	(let ((c (##sys#read-char-0 i)))
3505	(unless (or (eof-object? c) (char=? #\newline c))
3506	(sip-to-nl) ) ) )
3507	(define (cont)
3508	(set! ##sys#stepped-thread #f)
3509	(##sys#apply p args) )
3510	(##sys#print "\n " #f o)
3511	(##sys#with-print-length-limit
3512	1024
3513	(lambda () (##sys#print (cons p args) #t o)) )
3514	(flush-output o)
3515	(let loop ()
3516	(##sys#print "\n step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
3517	(let ((c (##sys#read-char-0 i)))
3518	(if (eof-object? c)
3519	(cont)
3520	(case c
3521	((#\newline)
3522	(set! ##sys#apply-hook ##sys#step-hook)
3523	(##core#app ##sys#apply p args))
3524	((#\return #\tab #\space) (loop))
3525	((#\c) (skip-to-nl) (cont))
3526	((#\s)
3527	(skip-to-nl)
3528	(##sys#call-with-values
3529	(lambda () (##core#app ##sys#apply p args))
3530	(lambda results
3531	(set! ##sys#apply-hook ##sys#step-hook)
3532	(##core#app ##sys#apply-values results) ) ) )
3533	((#\b)
3534	(skip-to-nl)
3535	(set! ##sys#stepped-thread #f)
3536	(##sys#break-entry '<step> '())
3537	(##sys#apply p args) )
3538	(else
3539	(cond ((eof-object? c) (cont))
3540	(else
3541	(skip-to-nl)
3542	(loop))))))))))
3543
3544
3545	;;; Default handlers
3546
3547	(define ##sys#break-on-error (##sys#fudge 25))
3548
3549	(define-foreign-variable _ex_software int "EX_SOFTWARE")
3550
3551	(define ##sys#error-handler
3552	(make-parameter
3553	(let ([string-append string-append]
3554	[open-output-string open-output-string]
3555	[get-output-string get-output-string]
3556	[print-call-chain print-call-chain] )
3557	(lambda (msg . args)
3558	(##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))
3559	(cond ((##sys#fudge 4)
3560	(##sys#print "\nError" #f ##sys#standard-error)
3561	(when msg
3562	(##sys#print ": " #f ##sys#standard-error)
3563	(##sys#print msg #f ##sys#standard-error) )
3564	(cond [(fx= 1 (length args))
3565	(##sys#print ": " #f ##sys#standard-error)
3566	(##sys#print (##sys#slot args 0) #t ##sys#standard-error) ]
3567	[else
3568	(##sys#for-each
3569	(lambda (x)
3570	(##sys#print #\newline #f ##sys#standard-error)
3571	(##sys#print x #t ##sys#standard-error) )
3572	args) ] )
3573	(##sys#print #\newline #f ##sys#standard-error)
3574	(print-call-chain ##sys#standard-error)
3575	(when (and ##sys#break-on-error (##sys#symbol-has-toplevel-binding? 'repl))
3576	(repl)
3577	(##sys#print #\newline #f ##sys#standard-error)
3578	(##core#inline "C_exit_runtime" _ex_software) )
3579	(##core#inline "C_halt" #f) )
3580	(else
3581	(let ((out (open-output-string)))
3582	(when msg (##sys#print msg #f out))
3583	(##sys#print #\newline #f out)
3584	(##sys#for-each (lambda (x) (##sys#print x #t out) (##sys#print #\newline #f out)) args)
3585	(##core#inline "C_halt" (get-output-string out)) ) ) ) ) ) ) )
3586
3587	(define reset-handler
3588	(make-parameter
3589	(lambda ()
3590	((##sys#exit-handler) _ex_software)) ) )
3591
3592	(define exit-handler
3593	(make-parameter
3594	(lambda code
3595	(##sys#cleanup-before-exit)
3596	(##core#inline
3597	"C_exit_runtime"
3598	(if (null? code)
3599	0
3600	(let ([code (car code)])
3601	(##sys#check-exact code)
3602	code) ) ) ) ) )
3603
3604	(define implicit-exit-handler
3605	(make-parameter
3606	(lambda ()
3607	(##sys#cleanup-before-exit) ) ) )
3608
3609	(define ##sys#exit-handler exit-handler)
3610	(define ##sys#reset-handler reset-handler)
3611	(define ##sys#implicit-exit-handler implicit-exit-handler)
3612
3613	(define force-finalizers (make-parameter #t))
3614
3615	(define ##sys#cleanup-before-exit
3616	(let ([ffp force-finalizers])
3617	(lambda ()
3618	(when (##sys#fudge 13)
3619	(##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-output) )
3620	(when (ffp) (##sys#force-finalizers)) ) ) )
3621
3622	(define (on-exit thunk)
3623	(set! ##sys#cleanup-before-exit
3624	(let ((old ##sys#cleanup-before-exit))
3625	(lambda () (old) (thunk)) ) ) )
3626
3627
3628	;;; Condition handling:
3629
3630	(define (##sys#signal-hook mode msg . args)
3631	(##core#inline "C_dbg_hook" #f)
3632	(case mode
3633	[(#:user-interrupt)
3634	(##sys#abort
3635	(##sys#make-structure
3636	'condition
3637	'(user-interrupt)
3638	'() ) ) ]
3639	[(#:warning)
3640	(##sys#print "\nWarning: " #f ##sys#standard-error)
3641	(##sys#print msg #f ##sys#standard-error)
3642	(if (or (null? args) (fx> (length args) 1))
3643	(##sys#write-char-0 #\newline ##sys#standard-error)
3644	(##sys#print ": " #f ##sys#standard-error))
3645	(for-each
3646	(lambda (x)
3647	(##sys#print x #t ##sys#standard-error)
3648	(##sys#write-char-0 #\newline ##sys#standard-error) )
3649	args)
3650	(##sys#flush-output ##sys#standard-error) ]
3651	[else
3652	(when (and (symbol? msg) (null? args))
3653	(set! msg (##sys#symbol->string msg)) )
3654	(let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
3655	[loc (and hasloc msg)]
3656	[msg (if hasloc (##sys#slot args 0) msg)]
3657	[args (if hasloc (##sys#slot args 1) args)] )
3658	(##sys#abort
3659	(##sys#make-structure
3660	'condition
3661	(case mode
3662	[(#:type-error) '(exn type)]
3663	[(#:syntax-error) '(exn syntax)]
3664	[(#:bounds-error) '(exn bounds)]
3665	[(#:arithmetic-error) '(exn arithmetic)]
3666	[(#:file-error) '(exn i/o file)]
3667	[(#:runtime-error) '(exn runtime)]
3668	[(#:process-error) '(exn process)]
3669	[(#:network-error) '(exn i/o net)]
3670	[(#:limit-error) '(exn runtime limit)]
3671	[(#:arity-error) '(exn arity)]
3672	[(#:access-error) '(exn access)]
3673	[(#:domain-error) '(exn domain)]
3674	[else '(exn)] )
3675	(list '(exn . message) msg
3676	'(exn . arguments) args
3677	'(exn . location) loc) ) ) ) ] ) )
3678
3679	(define (##sys#abort x)
3680	(##sys#current-exception-handler x)
3681	(##sys#abort
3682	(##sys#make-structure
3683	'condition
3684	'(exn)
3685	(list '(exn . message) "exception handler returned"
3686	'(exn . arguments) '()
3687	'(exn . location) #f) ) ) )
3688
3689	(define (##sys#signal x)
3690	(##sys#current-exception-handler x) )
3691
3692	(define abort ##sys#abort)
3693	(define signal ##sys#signal)
3694
3695	(define ##sys#