source: project/chicken/branches/release/library.scm @ 6577

Last change on this file since 6577 was 6577, checked in by felix winkelmann, 12 years ago

merged changes from trunk (rev 6579)

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