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

Last change on this file since 15816 was 15816, checked in by Kon Lovett, 10 years ago

Begin of "module" (actually loaded .so) introspection. Reminder about 'normalize-pathname' problem with absolute pathnames.

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