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

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

Dup ##sys#signal-hook in forward refs.

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