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

Last change on this file since 15869 was 15869, checked in by kon, 10 years ago

library Added new dynamic library sys namespace procedures
runtime Added support for non-chicken dynload, "folded" 'C_dload2' into platform indep routine
chicken Added new dynload procs
eval Made dynload flags a parameter, added new dynload routines (only a subset is "public", i.e. non-sys namespace)

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