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

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

merged from prerelease branch rev. 7930 - release version 3.0.0; fixed wrong version numbers in some files

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