source: project/chicken/branches/chicken-3/library.scm @ 13178

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

defaults.make : chking of svnrev sep from svnrev fil as a target
lolevel.scm : comment fix
runtime.c : use of C defines for platform info, reflow of some comments/code due to > 100 chars long, cl -> closure (like other procs), use of macros rather than open-coded block access, added return value testing for FreeLibrary? & shl_unlaod.
library.scm : refactored make-property-condition & condition-property-accessor so ##sy# routine available, make ##sys# routines for breakpoint condition, placed 'continuation, etc, on breakpoint condition & not exn.
chicken.h : use of C defines for platform info, added comments, C_CHAR_SHIFT.
posixunix.scm, posixwin.scm : added use of Unit ports
scheduler.scm : use of library breakpoint condition routines, placed 'continuation, etc, on breakpoint condition & not exn
srfi-18.scm : renamed some -inlines (match chicken-thread-object-inlines)

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