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

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

library.scm, c-platform.scm : C_pointerp -> C_anypointerp
lolevel.import.scm : added new procs
hash-table-tests.scm : added use of srfi-69 (worked because csi uses srfi-69)
runtests.sh : add lolevel test, no reading of .csirc

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