source: project/chicken/branches/beyond-hope/library.scm @ 10211

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

added feature-ids for highlevel macros; fixes; more tests, all is well

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