source: project/chicken/branches/lazy-gensyms/library.scm @ 12612

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

applied changes (untested)

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