source: project/chicken/trunk/library.scm @ 13125

Last change on this file since 13125 was 13125, checked in by Kon Lovett, 11 years ago

Chgd to use existing errmsg (##sys#error-hook). Use of define-inline for common fx & fp code. Common cond-expand style for fx & fp.

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