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

Last change on this file since 15869 was 15869, checked in by Kon Lovett, 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