source: project/chicken/branches/inlining/eval.scm @ 15323

Last change on this file since 15323 was 15323, checked in by felix winkelmann, 10 years ago

more intelligent inlining; standard-extension procedure in setup-api

File size: 61.3 KB
Line 
1;;;; eval.scm - Interpreter for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit eval)
30  (uses expand)
31  (disable-warning var)
32  (hide ##sys#split-at-separator
33        ##sys#r4rs-environment ##sys#r5rs-environment 
34        ##sys#interaction-environment pds pdss pxss) 
35  (not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook 
36       ##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
37       ##sys#syntax-error-hook))
38
39(define (d arg1 . more)
40  (if (null? more)
41      (pp arg1)
42      (apply print arg1 more)))
43
44(define-syntax d (syntax-rules () ((_ . _) (void))))
45
46#>
47#ifndef C_INSTALL_EGG_HOME
48# define C_INSTALL_EGG_HOME    "."
49#endif
50
51#ifndef C_INSTALL_SHARE_HOME
52# define C_INSTALL_SHARE_HOME NULL
53#endif
54<#
55
56(cond-expand
57 [paranoia]
58 [else
59  (declare
60    ;***(no-bound-checks)
61    (no-procedure-checks-for-usual-bindings)
62    (bound-to-procedure 
63     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#load-library
64     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
65     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round 
66     ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
67     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure 
68     ##sys#make-structure ##sys#feature?
69     ##sys#error-handler ##sys#hash-symbol ##sys#check-syntax
70     ##sys#hash-table-ref ##sys#hash-table-set! ##sys#canonicalize-body ##sys#decompose-lambda-list
71     ##sys#make-c-string ##sys#resolve-include-filename
72     ##sys#load ##sys#error ##sys#warn ##sys#hash-table-location ##sys#expand-home-path
73     ##sys#make-flonum ##sys#make-pointer ##sys#null-pointer ##sys#address->pointer 
74     ##sys#pointer->address ##sys#compile-to-closure ##sys#make-string ##sys#make-lambda-info
75     ##sys#number? ##sys#symbol->qualified-string ##sys#decorate-lambda ##sys#string-append
76     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
77     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
78     open-output-string get-output-string make-parameter software-type software-version machine-type
79     build-platform set-extensions-specifier! ##sys#string->symbol list->vector get-environment-variable
80     extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
81     vector->list store-string open-input-string eval ##sys#gc
82     with-exception-handler print-error-message read-char read ##sys#read-error
83     ##sys#reset-handler call-with-current-continuation ##sys#peek-char-0 ##sys#read-char-0
84     ##sys#clear-trace-buffer ##sys#write-char-0 print-call-chain ##sys#with-print-length-limit
85     repl-prompt ##sys#flush-output ##sys#extended-lambda-list? keyword? get-line-number
86     symbol->string string-append display ##sys#repository-path ##sys#file-info make-vector
87     ##sys#make-vector string-copy vector->list ##sys#do-the-right-thing ##sys#->feature-id
88     ##sys#extension-information ##sys#symbol->string ##sys#canonicalize-extension-path
89     file-exists? ##sys#load-extension ##sys#find-extension ##sys#substring reverse
90     dynamic-load-libraries ##sys#string->c-identifier load-verbose ##sys#load ##sys#get-keyword
91     port? ##sys#file-info ##sys#signal-hook ##sys#dload open-input-file close-input-port
92     read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
93     map string->keyword ##sys#abort
94     ##sys#expand-0) ) ] )
95
96(include "unsafe-declarations.scm")
97
98(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
99(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
100
101(define ##sys#core-library-modules
102  '(extras lolevel utils files tcp regex regex-extras posix srfi-1 srfi-4 srfi-13 
103           srfi-14 srfi-18 data-structures ports chicken-syntax))
104
105(define ##sys#explicit-library-modules '())
106
107(define-constant default-dynamic-load-libraries '("libchicken"))
108(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
109(define-constant macosx-load-library-extension ".dylib")
110(define-constant windows-load-library-extension ".dll")
111(define-constant hppa-load-library-extension ".sl")
112(define-constant default-load-library-extension ".so")
113(define-constant environment-table-size 301)
114(define-constant source-file-extension ".scm")
115(define-constant setup-file-extension "setup-info")
116(define-constant repository-environment-variable "CHICKEN_REPOSITORY")
117(define-constant prefix-environment-variable "CHICKEN_PREFIX")
118(define-constant default-binary-version 4)
119
120; these are actually in unit extras, but that is used by default
121; srfi-12 in unit library
122; srfi-98 partically in unit posix
123
124(define-constant builtin-features
125  '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39 
126            srfi-69 srfi-98) )
127
128(define-constant builtin-features/compiled
129  '(srfi-6 srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26 srfi-55) )
130
131(define ##sys#chicken-prefix
132  (let ((prefix (and-let* ((p (get-environment-variable prefix-environment-variable)))
133                  (##sys#string-append 
134                   p
135                   (if (memq (string-ref p (fx- (##sys#size p) 1)) '(#\\ #\/)) "" "/")) ) ) )
136    (lambda (#!optional dir)
137      (and prefix
138           (if dir (##sys#string-append prefix dir) prefix) ) ) ) )
139         
140
141;;; System settings
142
143(define (chicken-home)
144  (or (##sys#chicken-prefix "share/chicken")
145      installation-home) )
146
147
148;;; Lo-level hashtable support:
149
150(define ##sys#hash-symbol
151  (let ([cache-s #f]
152        [cache-h #f] )
153    (lambda (s n)
154      (if (eq? s cache-s)
155          (##core#inline "C_fixnum_modulo" cache-h n)
156          (begin
157            (set! cache-s s)
158            (set! cache-h (##core#inline "C_hash_string" (##sys#slot s 1)))
159            (##core#inline "C_fixnum_modulo" cache-h n))))))
160
161(define (##sys#hash-table-ref ht key)
162  (let loop ((bucket (##sys#slot ht (##sys#hash-symbol key (##core#inline "C_block_size" ht)))))
163      (and (not (eq? '() bucket))
164           (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
165               (##sys#slot (##sys#slot bucket 0) 1)
166               (loop (##sys#slot bucket 1))))))
167
168(define (##sys#hash-table-set! ht key val)
169  (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
170         (ib (##sys#slot ht k)))
171      (let loop ((bucket ib))
172          (if (eq? '() bucket)
173              (##sys#setslot ht k (cons (cons key val) ib))
174              (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
175                  (##sys#setslot (##sys#slot bucket 0) 1 val)
176                  (loop (##sys#slot bucket 1)))))))
177
178(define (##sys#hash-table-update! ht key updtfunc valufunc)
179  (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) )
180
181(define (##sys#hash-table-for-each p ht)
182  (let ((len (##core#inline "C_block_size" ht)))
183    (do ((i 0 (fx+ i 1)))
184        ((fx>= i len))
185      (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1)))
186                      (##sys#slot ht i) ) ) ) )
187
188(define ##sys#hash-table-location
189  (let ([unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)])
190    (lambda (ht key addp)
191      (let* ([k (##sys#hash-symbol key (##sys#size ht))]
192             [bucket0 (##sys#slot ht k)] )
193        (let loop ([bucket bucket0])
194          (if (null? bucket)
195              (and addp
196                   (let ([p (vector key unbound #t)])
197                     (##sys#setslot ht k (cons p bucket0))
198                     p) )
199              (let ([b (##sys#slot bucket 0)])
200                (if (eq? key (##sys#slot b 0))
201                    b
202                    (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )
203
204
205;;; Compile lambda to closure:
206
207(define ##sys#eval-environment #f)
208(define ##sys#environment-is-mutable #f)
209
210(define (##sys#eval-decorator p ll h cntr)
211  (##sys#decorate-lambda
212   p 
213   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
214   (lambda (p i)
215     (##sys#setslot 
216      p i 
217      (##sys#make-lambda-info 
218       (let ((o (open-output-string)))
219         (write ll o)
220         (get-output-string o))))
221     p) ) )
222
223(define ##sys#unbound-in-eval #f)
224(define ##sys#eval-debug-level 1)
225
226(define ##sys#compile-to-closure
227  (let ([write write]
228        [reverse reverse]
229        [open-output-string open-output-string]
230        [get-output-string get-output-string] 
231        [with-input-from-file with-input-from-file]
232        [unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
233        [display display] )
234    (lambda (exp env se #!optional cntr)
235
236      (define (find-id id se)           ; ignores macro bindings
237        (cond ((null? se) #f)
238              ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
239              (else (find-id id (cdr se)))))
240
241      (define (rename var se)
242        (cond ((find-id var se))
243              ((##sys#get var '##core#macro-alias))
244              (else var)))
245
246      (define (lookup var0 e se)
247        (let ((var (rename var0 se)))
248          (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map car se)))
249          (let loop ((envs e) (ei 0))
250            (cond ((null? envs) (values #f var))
251                  ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
252                  (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
253
254      (define (posq x lst)
255        (let loop ((lst lst) (i 0))
256          (cond ((null? lst) #f)
257                ((eq? x (##sys#slot lst 0)) i)
258                (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
259
260      (define (emit-trace-info tf info cntr) 
261        (when tf
262          (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )
263
264      (define (emit-syntax-trace-info tf info cntr) 
265        (when tf
266          (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
267       
268      (define (decorate p ll h cntr)
269        (##sys#eval-decorator p ll h cntr) )
270
271      (define (eval/meta form)
272        (parameterize ((##sys#current-module #f)
273                       (##sys#macro-environment (##sys#meta-macro-environment)))
274            ((##sys#compile-to-closure
275              form
276              '() 
277              (##sys#current-meta-environment))
278             '() ) ))
279
280      (define (eval/elab form)
281        ((##sys#compile-to-closure
282          form
283          '() 
284          (##sys#current-environment))
285         '() ) )
286
287      (define (compile x e h tf cntr se)
288        (cond ((keyword? x) (lambda v x))
289              ((symbol? x)
290               (receive (i j) (lookup x e se)
291                 (cond [(not i)
292                        (let ((var (if (not (assq x se)) ; global?
293                                       (##sys#alias-global-hook j #f)
294                                       (or (##sys#get j '##core#primitive) j))))
295                          (if ##sys#eval-environment
296                              (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
297                                (unless loc (##sys#syntax-error-hook "reference to undefined identifier" var))
298                                (cond-expand 
299                                 [unsafe (lambda v (##sys#slot loc 1))]
300                                 [else
301                                  (lambda v 
302                                    (let ([val (##sys#slot loc 1)])
303                                      (if (eq? unbound val)
304                                          (##sys#error "unbound variable" var)
305                                          val) ) ) ] ) )
306                              (cond-expand
307                               [unsafe (lambda v (##core#inline "C_slot" var 0))]
308                               [else
309                                (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? var)))
310                                  (set! ##sys#unbound-in-eval (cons (cons var cntr) ##sys#unbound-in-eval)) )
311                                (lambda v (##core#inline "C_retrieve" var))] ) ) ) ]
312                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
313                       [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) )
314              [(##sys#number? x)
315               (case x
316                 [(-1) (lambda v -1)]
317                 [(0) (lambda v 0)]
318                 [(1) (lambda v 1)]
319                 [(2) (lambda v 2)]
320                 [else (lambda v x)] ) ]
321              [(boolean? x)
322               (if x
323                   (lambda v #t)
324                   (lambda v #f) ) ]
325              [(or (char? x)
326                   (eof-object? x)
327                   (string? x) )
328               (lambda v x) ]
329              [(not (pair? x)) (##sys#syntax-error-hook "illegal non-atomic object" x)]
330              [(symbol? (##sys#slot x 0))
331               (emit-syntax-trace-info tf x cntr)
332               (let ((x2 (##sys#expand x se #f)))
333                 (d `(EVAL/EXPANDED: ,x2))
334                 (if (not (eq? x2 x))
335                     (compile x2 e h tf cntr se)
336                     (let ((head (rename (##sys#slot x 0) se))) 
337                       ;; here we did't resolve ##core#primitive, but that is done in compile-call (via
338                       ;; a normal walking of the operator)
339                       (case head
340
341                         [(quote)
342                          (##sys#check-syntax 'quote x '(quote _) #f se)
343                          (let* ((c (##sys#strip-syntax (cadr x))))
344                            (case c
345                              [(-1) (lambda v -1)]
346                              [(0) (lambda v 0)]
347                              [(1) (lambda v 1)]
348                              [(2) (lambda v 2)]
349                              [(#t) (lambda v #t)]
350                              [(#f) (lambda v #f)]
351                              [(()) (lambda v '())]
352                              [else (lambda v c)] ) ) ]
353
354                         ((syntax ##core#syntax)
355                          (let ((c (cadr x)))
356                            (lambda v c)))
357
358                         [(##core#global-ref)
359                          (let ([var (cadr x)])
360                            (if ##sys#eval-environment
361                                (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
362                                  (lambda v (##sys#slot loc 1)) )
363                                (lambda v (##core#inline "C_slot" var 0)) ) ) ]
364
365                         [(##core#check)
366                          (compile (cadr x) e h tf cntr se) ]
367
368                         [(##core#immutable)
369                          (compile (cadr x) e #f tf cntr se) ]
370                   
371                         [(##core#undefined) (lambda (v) (##core#undefined))]
372
373                         [(if)
374                          (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
375                          (let* ([test (compile (cadr x) e #f tf cntr se)]
376                                 [cns (compile (caddr x) e #f tf cntr se)]
377                                 [alt (if (pair? (cdddr x))
378                                          (compile (cadddr x) e #f tf cntr se)
379                                          (compile '(##core#undefined) e #f tf cntr se) ) ] )
380                            (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
381
382                         [(begin ##core#begin)
383                          (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
384                          (let* ([body (##sys#slot x 1)]
385                                 [len (length body)] )
386                            (case len
387                              [(0) (compile '(##core#undefined) e #f tf cntr se)]
388                              [(1) (compile (##sys#slot body 0) e #f tf cntr se)]
389                              [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
390                                          [x2 (compile (cadr body) e #f tf cntr se)] )
391                                     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
392                              [else
393                               (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
394                                      [x2 (compile (cadr body) e #f tf cntr se)] 
395                                      [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
396                                 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
397
398                         [(set! ##core#set!)
399                          (##sys#check-syntax 'set! x '(_ variable _) #f se)
400                          (let ((var (cadr x)))
401                            (receive (i j) (lookup var e se)
402                              (let ((val (compile (caddr x) e var tf cntr se)))
403                                (cond [(not i)
404                                       (let ((var (##sys#alias-global-hook j #t)))
405                                         (if ##sys#eval-environment
406                                             (let ([loc (##sys#hash-table-location
407                                                         ##sys#eval-environment 
408                                                         var
409                                                         ##sys#environment-is-mutable) ] )
410                                               (unless loc (##sys#error "assignment of undefined identifier" var))
411                                               (if (##sys#slot loc 2)
412                                                   (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
413                                                   (lambda v (##sys#error "assignment to immutable variable" var)) ) )
414                                             (lambda (v)
415                                               (##sys#setslot var 0 (##core#app val v))) ) ) ]
416                                      [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
417                                      [else
418                                       (lambda (v)
419                                         (##sys#setslot
420                                          (##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
421
422                         [(let ##core#let)
423                          (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
424                          (let* ([bindings (cadr x)]
425                                 [n (length bindings)] 
426                                 [vars (map (lambda (x) (car x)) bindings)] 
427                                 (aliases (map gensym vars))
428                                 [e2 (cons aliases e)]
429                                 (se2 (append (map cons vars aliases) se))
430                                 [body (##sys#compile-to-closure
431                                        (##sys#canonicalize-body (cddr x) se2 #f)
432                                        e2
433                                        se2
434                                        cntr) ] )
435                            (case n
436                              [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
437                                     (lambda (v)
438                                       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
439                              [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
440                                         [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] )
441                                     (lambda (v)
442                                       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
443                              [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
444                                          [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
445                                          [t (cddr bindings)]
446                                          [val3 (compile (cadar t) e (caddr vars) tf cntr se)] )
447                                     (lambda (v)
448                                       (##core#app 
449                                        body
450                                        (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
451                              [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
452                                          [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
453                                          [t (cddr bindings)]
454                                          [val3 (compile (cadar t) e (caddr vars) tf cntr se)] 
455                                          [val4 (compile (cadadr t) e (cadddr vars) tf cntr se)] )
456                                     (lambda (v)
457                                       (##core#app 
458                                        body
459                                        (cons (vector (##core#app val1 v)
460                                                      (##core#app val2 v)
461                                                      (##core#app val3 v)
462                                                      (##core#app val4 v))
463                                              v)) ) ) ]
464                              [else
465                               (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])
466                                 (lambda (v)
467                                   (let ([v2 (##sys#make-vector n)])
468                                     (do ([i 0 (fx+ i 1)]
469                                          [vlist vals (##sys#slot vlist 1)] )
470                                         ((fx>= i n))
471                                       (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
472                                     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
473
474                         ((letrec ##core#letrec)
475                          (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
476                          (let ((bindings (cadr x))
477                                (body (cddr x)) )
478                            (compile
479                             `(##core#let
480                               ,(##sys#map (lambda (b)
481                                             (list (car b) '(##core#undefined))) 
482                                           bindings)
483                               ,@(##sys#map (lambda (b)
484                                              `(##core#set! ,(car b) ,(cadr b))) 
485                                            bindings)
486                               (##core#let () ,@body) )
487                             e h tf cntr se)))
488
489                         [(lambda ##core#lambda)
490                          (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
491                          (let* ([llist (cadr x)]
492                                 [body (cddr x)] 
493                                 [info (cons (or h '?) llist)] )
494                            (when (##sys#extended-lambda-list? llist)
495                              (set!-values 
496                               (llist body) 
497                               (##sys#expand-extended-lambda-list 
498                                llist body ##sys#syntax-error-hook se) ) ) 
499                            (##sys#decompose-lambda-list
500                             llist
501                             (lambda (vars argc rest)
502                               (let* ((aliases (map gensym vars))
503                                      (se2 (append (map cons vars aliases) se))
504                                      (e2 (cons aliases e))
505                                      (body 
506                                       (##sys#compile-to-closure
507                                        (##sys#canonicalize-body body se2 #f)
508                                        e2
509                                        se2
510                                        (or h cntr) ) ) )
511                                 (case argc
512                                   [(0) (if rest
513                                            (lambda (v)
514                                              (decorate
515                                               (lambda r
516                                                 (##core#app body (cons (vector r) v)))
517                                               info h cntr) )
518                                            (lambda (v)
519                                              (decorate
520                                               (lambda () (##core#app body (cons #f v)))
521                                               info h cntr) ) ) ]
522                                   [(1) (if rest
523                                            (lambda (v)
524                                              (decorate
525                                               (lambda (a1 . r)
526                                                 (##core#app body (cons (vector a1 r) v)))
527                                               info h cntr) ) 
528                                            (lambda (v)
529                                              (decorate 
530                                               (lambda (a1)
531                                                 (##core#app body (cons (vector a1) v)))
532                                               info h cntr) ) ) ]
533                                   [(2) (if rest
534                                            (lambda (v) 
535                                              (decorate
536                                               (lambda (a1 a2 . r)
537                                                 (##core#app body (cons (vector a1 a2 r) v)))
538                                               info h cntr) )
539                                            (lambda (v)
540                                              (decorate
541                                               (lambda (a1 a2)
542                                                 (##core#app body (cons (vector a1 a2) v)))
543                                               info h cntr) ) ) ]
544                                   [(3) (if rest
545                                            (lambda (v) 
546                                              (decorate
547                                               (lambda (a1 a2 a3 . r)
548                                                 (##core#app body (cons (vector a1 a2 a3 r) v)))
549                                               info h cntr) )
550                                            (lambda (v)
551                                              (decorate
552                                               (lambda (a1 a2 a3)
553                                                 (##core#app body (cons (vector a1 a2 a3) v)))
554                                               info h cntr) ) ) ]
555                                   [(4) (if rest
556                                            (lambda (v)
557                                              (decorate
558                                               (lambda (a1 a2 a3 a4 . r)
559                                                 (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
560                                               info h cntr) )
561                                            (lambda (v)
562                                              (decorate
563                                               (lambda (a1 a2 a3 a4)
564                                                 (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
565                                               info h cntr) ) ) ]
566                                   [else
567                                    (if rest
568                                        (lambda (v)
569                                          (decorate
570                                           (lambda as
571                                             (##core#app
572                                              body
573                                              (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
574                                           info h cntr) )
575                                        (lambda (v)
576                                          (decorate
577                                           (lambda as 
578                                             (let ([len (length as)])
579                                               (if (not (fx= len argc))
580                                                   (##sys#error "bad argument count" argc len)
581                                                   (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
582                                           info h cntr) ) ) ] ) ) ) ) ) ]
583
584                         ((let-syntax)
585                          (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
586                          (let ((se2 (append
587                                      (map (lambda (b)
588                                             (list
589                                              (car b)
590                                              se
591                                              (##sys#er-transformer
592                                               (eval/meta (cadr b)))))
593                                           (cadr x) ) 
594                                      se) ) )
595                            (compile
596                             (##sys#canonicalize-body (cddr x) se2 #f)
597                             e #f tf cntr se2)))
598                               
599                         ((letrec-syntax)
600                          (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
601                          (let* ((ms (map (lambda (b)
602                                            (list
603                                             (car b)
604                                             #f
605                                             (##sys#er-transformer
606                                              (eval/meta (cadr b)))))
607                                          (cadr x) ) )
608                                 (se2 (append ms se)) )
609                            (for-each
610                             (lambda (sb)
611                               (set-car! (cdr sb) se2) )
612                             ms) 
613                            (compile
614                             (##sys#canonicalize-body (cddr x) se2 #f)
615                             e #f tf cntr se2)))
616                               
617                         ((define-syntax define-compiled-syntax)
618                          (##sys#check-syntax
619                           'define-syntax x
620                           (if (and (pair? (cdr x)) (pair? (cadr x)))
621                               '(_ (variable . lambda-list) . #(_ 1))
622                               '(_ variable _))
623                           #f se)
624                          (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
625                                 (body (if (pair? (cadr x))
626                                           `(,(rename 'lambda se) ,(cdadr x) ,@(cddr x))
627                                           (caddr x)))
628                                 (name (rename var se)))
629                            (##sys#register-syntax-export 
630                             name (##sys#current-module)
631                             body)      ;*** not really necessary, it only shouldn't be #f
632                            (##sys#extend-macro-environment
633                             name
634                             (##sys#current-environment)
635                             (##sys#er-transformer (eval/meta body)))
636                            (compile '(##core#undefined) e #f tf cntr se) ) )
637
638                         ((##core#define-compiler-syntax)
639                          (compile '(##core#undefined) e #f tf cntr se))
640
641                         ((##core#let-compiler-syntax)
642                          (compile 
643                           (##sys#canonicalize-body (cddr x) se #f)
644                           e #f tf cntr se))
645
646                         ((##core#module)
647                          (let* ((name (rename (cadr x) se))
648                                 (exports 
649                                  (or (eq? #t (caddr x))
650                                      (map (lambda (exp)
651                                             (cond ((symbol? exp) exp)
652                                                   ((and (pair? exp) 
653                                                         (let loop ((exp exp))
654                                                           (or (null? exp)
655                                                               (and (symbol? (car exp))
656                                                                    (loop (cdr exp))))))
657                                                    exp)
658                                                   (else
659                                                    (##sys#syntax-error-hook
660                                                     'module
661                                                     "invalid export syntax" exp name))))
662                                           (##sys#strip-syntax (caddr x))))))
663                            (when (##sys#current-module)
664                              (##sys#syntax-error-hook 'module "modules may not be nested" name))
665                            (parameterize ((##sys#current-module 
666                                            (##sys#register-module name exports))
667                                           (##sys#current-environment '())
668                                           (##sys#macro-environment ##sys#initial-macro-environment))
669                                (let loop ((body (cdddr x)) (xs '()))
670                                  (if (null? body)
671                                      (let ((xs (reverse xs)))
672                                        (##sys#finalize-module (##sys#current-module))
673                                        (lambda (v)
674                                          (let loop2 ((xs xs))
675                                            (if (null? xs)
676                                                (##sys#void)
677                                                (let ((n (##sys#slot xs 1)))
678                                                  (cond ((pair? n)
679                                                         ((##sys#slot xs 0) v)
680                                                         (loop2 n))
681                                                        (else
682                                                         ((##sys#slot xs 0) v))))))))
683                                      (loop 
684                                       (cdr body)
685                                       (cons (compile 
686                                              (car body) 
687                                              '() #f tf cntr 
688                                              (##sys#current-environment))
689                                             xs))))) ) )
690
691                         [(##core#loop-lambda)
692                          (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
693
694                         [(##core#named-lambda)
695                          (compile `(,(rename 'lambda se) ,@(cddr x)) e (cadr x) tf cntr se) ]
696
697                         [(##core#require-for-syntax)
698                          (let ([ids (map (lambda (x)
699                                            (eval/meta x))
700                                          (cdr x))])
701                            (apply ##sys#require ids)
702                            (let ([rs (##sys#lookup-runtime-requirements ids)])
703                              (compile
704                               (if (null? rs)
705                                   '(##core#undefined)
706                                   `(##sys#require ,@(map (lambda (x) `',x) rs)) )
707                               e #f tf cntr se) ) ) ]
708
709                         [(##core#require-extension)
710                          (let ((imp? (caddr x)))
711                            (compile
712                             (let loop ([ids (cadr x)])
713                               (if (null? ids)
714                                   '(##core#undefined)
715                                   (let-values ([(exp _)
716                                                 (##sys#do-the-right-thing (car ids) #f imp?)])
717                                     `(##core#begin ,exp ,(loop (cdr ids))) ) ) )
718                             e #f tf cntr se) ) ]
719
720                         [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
721                          (eval/meta (cadr x))
722                          (compile '(##core#undefined) e #f tf cntr se) ]
723
724                         [(##core#compiletimetoo)
725                          (compile (cadr x) e #f tf cntr se) ]
726
727                         [(##core#compiletimeonly ##core#callunit) 
728                          (compile '(##core#undefined) e #f tf cntr se) ]
729
730                         [(##core#declare)
731                          (if (memq #:compiling ##sys#features)
732                              (for-each (lambda (d) (##compiler#process-declaration d se)) (cdr x)) 
733                              (##sys#warn "declarations are ignored in interpreted code" x) )
734                          (compile '(##core#undefined) e #f tf cntr se) ]
735
736                         [(define-inline define-constant)
737                          (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
738                   
739                         [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
740                                            ##core#define-foreign-variable 
741                                            ##core#define-external-variable ##core#let-location
742                                            ##core#foreign-primitive
743                                            ##core#foreign-lambda* ##core#define-foreign-type)
744                          (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
745
746                         [(##core#app)
747                          (compile-call (cdr x) e tf cntr se) ]
748
749                         [else
750                          (cond [(eq? head 'location)
751                                 (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
752
753                                [else (compile-call x e tf cntr se)] ) ] ) ) ) ) ]
754             
755              [else
756               (emit-syntax-trace-info tf x cntr)
757               (compile-call x e tf cntr se)] ) )
758
759      (define (fudge-argument-list n alst)
760        (if (null? alst) 
761            (list alst)
762            (do ((n n (fx- n 1))
763                 (c 0 (fx+ c 1))
764                 (args alst 
765                       (if (eq? '() args)
766                           (##sys#error "bad argument count" n c)
767                           (##sys#slot args 1)))
768                 (last #f args) )
769                ((fx= n 0)
770                 (##sys#setslot last 1 (list args))
771                 alst) ) ) )
772
773      (define (checked-length lst)
774        (let loop ([lst lst] [n 0])
775          (cond [(null? lst) n]
776                [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
777                [else #f] ) ) )
778
779      (define (compile-call x e tf cntr se)
780        (let* ([fn (compile (##sys#slot x 0) e #f tf cntr se)]
781               [args (##sys#slot x 1)]
782               [argc (checked-length args)]
783               [info x] )
784          (case argc
785            [(#f) (##sys#syntax-error-hook "malformed expression" x)]
786            [(0) (lambda (v)
787                   (emit-trace-info tf info cntr)
788                   ((fn v)))]
789            [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
790                   (lambda (v)
791                     (emit-trace-info tf info cntr)
792                     ((##core#app fn v) (##core#app a1 v))) ) ]
793            [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
794                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
795                   (lambda (v)
796                     (emit-trace-info tf info cntr)
797                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
798            [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
799                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
800                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
801                   (lambda (v)
802                     (emit-trace-info tf info cntr)
803                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
804            [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
805                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
806                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] 
807                        [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
808                   (lambda (v)
809                     (emit-trace-info tf info cntr)
810                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
811            [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
812                    (lambda (v)
813                      (emit-trace-info tf info cntr)
814                      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
815
816      (compile exp env #f (fx> ##sys#eval-debug-level 0) cntr se) ) ) )
817
818(define ##sys#eval-handler 
819  (make-parameter
820   (lambda (x . env)
821     (let ([mut ##sys#environment-is-mutable]
822           [e #f] )
823       (when (pair? env)
824         (let ([env (car env)])
825           (when env
826             (##sys#check-structure env 'environment)
827             (set! e (##sys#slot env 1)) 
828             (set! mut (##sys#slot env 2)) ) ) )
829       ((fluid-let ([##sys#environment-is-mutable mut]
830                    [##sys#eval-environment e] )
831          (##sys#compile-to-closure x '() (##sys#current-environment)) )
832        '() ) ) ) ) )
833
834(define eval-handler ##sys#eval-handler)
835
836(define (eval x . env)
837  (apply (##sys#eval-handler) 
838         x
839         env) )
840
841;;; Split lambda-list into its parts:
842
843(define ##sys#decompose-lambda-list
844  (let ([reverse reverse])
845    (lambda (llist0 k)
846
847      (define (err)
848        (set! ##sys#syntax-error-culprit #f)
849        (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
850
851      (let loop ([llist llist0] [vars '()] [argc 0])
852        (cond [(eq? llist '()) (k (reverse vars) argc #f)]
853              [(not (##core#inline "C_blockp" llist)) (err)]
854              [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
855              [(not (##core#inline "C_pairp" llist)) (err)]
856              [else (loop (##sys#slot llist 1)
857                          (cons (##sys#slot llist 0) vars)
858                          (fx+ argc 1) ) ] ) ) ) ) )
859
860
861;;; Loading source/object files:
862
863(define load-verbose (make-parameter (##sys#fudge 13)))
864
865(define (##sys#abort-load) #f)
866(define ##sys#current-source-filename #f)
867(define ##sys#current-load-path "")
868(define ##sys#dload-disabled #f)
869
870(define-foreign-variable _dlerror c-string "C_dlerror")
871
872(define (set-dynamic-load-mode! mode)
873  (let ([mode (if (pair? mode) mode (list mode))]
874        [now #f]
875        [global #t] )
876    (let loop ([mode mode])
877      (when (pair? mode)
878        (case (##sys#slot mode 0)
879          [(global) (set! global #t)]
880          [(local) (set! global #f)]
881          [(lazy) (set! now #f)]
882          [(now) (set! now #t)]
883          [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
884        (loop (##sys#slot mode 1)) ) )
885    (##sys#set-dlopen-flags! now global) ) )
886
887(let ([read read]
888      [write write]
889      [display display]
890      [newline newline]
891      (flush-output flush-output)
892      [eval eval]
893      [open-input-file open-input-file]
894      [close-input-port close-input-port]
895      [string-append string-append] 
896      [load-verbose load-verbose]
897      [topentry (##sys#make-c-string "C_toplevel")] )
898  (define (has-sep? str)
899    (let loop ([i (fx- (##sys#size str) 1)])
900      (and (not (zero? i))
901           (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
902               i
903               (loop (fx- i 1)) ) ) ) )
904  (define (badfile x)
905    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
906  (set! ##sys#load 
907    (lambda (input evaluator pf #!optional timer printer)
908      (when (string? input) 
909        (set! input (##sys#expand-home-path input)) )
910      (let* ([isdir #f]
911             [fname 
912             (cond [(port? input) #f]
913                   [(not (string? input)) (badfile input)]
914                   [(and-let* ([info (##sys#file-info input)]
915                               [id (##sys#slot info 4)] )
916                      (set! isdir (eq? 1 id)) 
917                      (not id) )
918                    input]
919                   [else
920                    (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
921                      (if (and (not ##sys#dload-disabled)
922                               (##sys#fudge 24) ; dload?
923                               (##sys#file-info fname2))
924                          fname2
925                          (let ([fname3 (##sys#string-append input source-file-extension)])
926                            (if (##sys#file-info fname3)
927                                fname3
928                                (and (not isdir) input) ) ) ) ) ] ) ]
929            [evproc (or evaluator eval)] )
930        (cond [(and (string? input) (not fname))
931               (##sys#signal-hook #:file-error 'load "cannot open file" input) ]
932              [(and (load-verbose) fname)
933               (display "; loading ")
934               (display fname)
935               (display " ...\n") 
936               (flush-output)] )
937        (or (and fname
938                 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
939                     (and (not (has-sep? fname))
940                          (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
941            (call-with-current-continuation
942             (lambda (abrt)
943               (fluid-let ([##sys#read-error-with-line-number #t]
944                           [##sys#current-source-filename fname]
945                           [##sys#current-load-path
946                            (and fname
947                                 (let ((i (has-sep? fname)))
948                                   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
949                           [##sys#abort-load (lambda () (abrt #f))] )
950                 (let ([in (if fname (open-input-file fname) input)])
951                   (##sys#dynamic-wind
952                    (lambda () #f)
953                    (lambda ()
954                      (let ([c1 (peek-char in)])
955                        (when (char=? c1 (integer->char 127))
956                          (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
957                      (let ((x1 (read in)))
958                        (do ((x x1 (read in)))
959                            ((eof-object? x))
960                          (when printer (printer x))
961                          (##sys#call-with-values
962                           (lambda () 
963                             (if timer
964                                 (time (evproc x)) 
965                                 (evproc x) ) )
966                           (lambda results
967                             (when pf
968                               (for-each
969                                (lambda (r) 
970                                  (write r)
971                                  (newline) )
972                                results) ) ) ) ) ) )
973                    (lambda () (close-input-port in)) ) ) ) ) ) )
974        (##core#undefined) ) ) )
975  (set! load
976    (lambda (filename . evaluator)
977      (##sys#load filename (optional evaluator #f) #f) ) )
978  (set! load-relative
979    (lambda (filename . evaluator)
980      (##sys#load
981       (if (memq (string-ref filename 0) '(#\\ #\/))
982           filename
983           (##sys#string-append ##sys#current-load-path filename) )
984       (optional evaluator #f) #f) ) )
985  (set! load-noisily
986    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
987      (##sys#load filename evaluator #t time printer) ) ) )
988
989(define ##sys#load-library-extension    ; this is crude...
990  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
991        [(eq? (software-version) 'macosx) macosx-load-library-extension]
992        [(and (eq? (software-version) 'hpux) 
993              (eq? (machine-type) 'hppa)) hppa-load-library-extension]
994        [else default-load-library-extension] ) )
995
996(define ##sys#load-dynamic-extension default-load-library-extension)
997
998(define ##sys#default-dynamic-load-libraries 
999  (case (build-platform)
1000    ((cygwin) cygwin-default-dynamic-load-libraries)
1001    (else default-dynamic-load-libraries) ) )
1002
1003(define dynamic-load-libraries 
1004  (make-parameter
1005   (map (cut ##sys#string-append <> ##sys#load-library-extension) ##sys#default-dynamic-load-libraries)
1006   (lambda (x)
1007     (##sys#check-list x)
1008     x) ) )
1009
1010(define ##sys#load-library
1011  (let ([load-verbose load-verbose]
1012        [string-append string-append]
1013        [dynamic-load-libraries dynamic-load-libraries]
1014        [display display] )
1015    (lambda (uname lib)
1016      (let ([id (##sys#->feature-id uname)])
1017        (or (memq id ##sys#features)
1018            (let ([libs
1019                   (if lib
1020                       (##sys#list lib)
1021                       (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
1022                             (dynamic-load-libraries) ) ) ]
1023                  [top 
1024                   (##sys#make-c-string
1025                    (string-append
1026                     "C_"
1027                     (##sys#string->c-identifier (##sys#slot uname 1)) 
1028                     "_toplevel") ) ] )
1029              (when (load-verbose)
1030                (display "; loading library ")
1031                (display uname)
1032                (display " ...\n") )
1033              (let loop ([libs libs])
1034                (cond [(null? libs) #f]
1035                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
1036                       (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
1037                       #t]
1038                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
1039
1040(define load-library
1041  (lambda (uname . lib)
1042    (##sys#check-symbol uname 'load-library)
1043    (or (##sys#load-library uname (and (pair? lib) (car lib)))
1044        (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
1045
1046(define ##sys#split-at-separator
1047  (let ([reverse reverse] )
1048    (lambda (str sep)
1049      (let ([len (##sys#size str)])
1050        (let loop ([items '()] [i 0] [j 0])
1051          (cond [(fx>= i len)
1052                 (reverse (cons (##sys#substring str j len) items)) ]
1053                [(char=? (##core#inline "C_subchar" str i) sep)
1054                 (let ([i2 (fx+ i 1)])
1055                   (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
1056                [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
1057
1058
1059;;; Extensions:
1060
1061(define ##sys#canonicalize-extension-path
1062  (let ([string-append string-append])
1063    (lambda (id loc)
1064      (define (err) (##sys#error loc "invalid extension path" id))
1065      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
1066      (let ([p (cond [(string? id) id]
1067                     [(symbol? id) (##sys#symbol->string id)]
1068                     [(list? id) 
1069                      (let loop ([id id])
1070                        (if (null? id)
1071                            ""
1072                            (string-append
1073                             (let ([id0 (##sys#slot id 0)])
1074                               (cond [(symbol? id0) (##sys#symbol->string id0)]
1075                                     [(string? id0) id0]
1076                                     [else (err)] ) )
1077                             (if (null? (##sys#slot id 1))
1078                                 ""
1079                                 "/")
1080                             (loop (##sys#slot id 1)) ) ) ) ] ) ] )
1081        (let check ([p p])
1082          (let ([n (##sys#size p)])
1083            (cond [(fx= 0 n) (err)]
1084                  [(sep? (string-ref p 0))
1085                   (check (##sys#substring p 1 n)) ]
1086                  [(sep? (string-ref p (fx- n 1)))
1087                   (check (##sys#substring p 0 (fx- n 1))) ]
1088                  [else p] ) ) ) ) ) ) )
1089
1090(define ##sys#repository-path
1091  (make-parameter 
1092   (or (get-environment-variable repository-environment-variable)
1093       (##sys#chicken-prefix 
1094        (##sys#string-append 
1095         "lib/chicken/"
1096         (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
1097       install-egg-home) ) )
1098
1099(define repository-path ##sys#repository-path)
1100
1101(define ##sys#find-extension
1102  (let ((file-exists? file-exists?)
1103        (string-append string-append) )
1104    (lambda (p inc?)
1105      (let ((rp (##sys#repository-path)))
1106        (define (check path)
1107          (let ((p0 (string-append path "/" p)))
1108            (and (or (and rp
1109                          (not ##sys#dload-disabled)
1110                          (##sys#fudge 24) ; dload?
1111                          (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
1112                     (file-exists? (##sys#string-append p0 source-file-extension)) )
1113                 p0) ) )
1114          (let loop ((paths (##sys#append
1115                             (if rp (list rp) '())
1116                             (if inc? ##sys#include-pathnames '())
1117                             '("."))) )
1118            (and (pair? paths)
1119                 (let ((pa (##sys#slot paths 0)))
1120                   (or (check pa)
1121                       (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
1122
1123(define ##sys#loaded-extensions '())
1124
1125(define ##sys#load-extension
1126  (let ((string->symbol string->symbol))
1127    (lambda (id loc . err?)
1128      (cond ((string? id) (set! id (string->symbol id)))
1129            (else (##sys#check-symbol id loc)) )
1130      (let ([p (##sys#canonicalize-extension-path id loc)])
1131        (cond ((member p ##sys#loaded-extensions))
1132              ((memq id ##sys#core-library-modules)
1133               (##sys#load-library id #f) )
1134              (else
1135               (let ([id2 (##sys#find-extension p #t)])
1136                 (cond (id2
1137                        (##sys#load id2 #f #f)
1138                        (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
1139                        #t)
1140                       ((optional err? #t) (##sys#error loc "cannot load extension" id))
1141                       (else #f) ) ) ) ) ) ) ) )
1142
1143(define (##sys#provide . ids)
1144  (for-each
1145   (lambda (id)
1146     (##sys#check-symbol id 'provide)
1147     (let ([p (##sys#canonicalize-extension-path id 'provide)])
1148       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
1149   ids) )
1150
1151(define provide ##sys#provide)
1152
1153(define (##sys#provided? id)
1154  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
1155       #t) )
1156
1157(define provided? ##sys#provided?)
1158
1159(define ##sys#require
1160  (lambda ids
1161    (for-each
1162     (cut ##sys#load-extension <> 'require) 
1163     ids) ) )
1164
1165(define require ##sys#require)
1166
1167(define ##sys#extension-information
1168  (let ([with-input-from-file with-input-from-file]
1169        [file-exists? file-exists?]
1170        [string-append string-append]
1171        [read read] )
1172    (lambda (id loc)
1173      (and-let* ((rp (##sys#repository-path)))
1174        (let* ((p (##sys#canonicalize-extension-path id loc))
1175               (rpath (string-append rp "/" p ".")) )
1176          (cond ((file-exists? (string-append rpath setup-file-extension))
1177                 => (cut with-input-from-file <> read) )
1178                (else #f) ) ) ) ) ))
1179
1180(define (extension-information ext)
1181  (##sys#extension-information ext 'extension-information) )
1182
1183(define ##sys#lookup-runtime-requirements 
1184  (let ([with-input-from-file with-input-from-file]
1185        [read read] )
1186    (lambda (ids)
1187      (let loop1 ([ids ids])
1188        (if (null? ids)
1189            '()
1190            (append
1191             (or (and-let* ([info (##sys#extension-information (car ids) #f)]
1192                            [a (assq 'require-at-runtime info)] )
1193                   (cdr a) )
1194                 '() )
1195             (loop1 (cdr ids)) ) ) ) ) ) )
1196
1197(define ##sys#do-the-right-thing
1198  (let ((vector->list vector->list))
1199    (lambda (id comp? imp?)
1200      (define (add-req id syntax?)
1201        (when comp?
1202          (##sys#hash-table-update! ; assumes compiler has extras available - will break in the interpreter
1203           ##compiler#file-requirements
1204           (if syntax? 'dynamic/syntax 'dynamic)
1205           (cut lset-adjoin eq? <> id) 
1206           (lambda () (list id)))))
1207      (define (impform x id builtin?)
1208        `(##core#begin
1209           ,x
1210           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
1211                 `((import ,id))        ;XXX make hygienic
1212                 '())))
1213      (define (doit id)
1214        (cond ((or (memq id builtin-features)
1215                   (if comp?
1216                       (memq id builtin-features/compiled)
1217                       (##sys#feature? id) ) )
1218               (values (impform '(##core#undefined) id #t) #t) )
1219              ((memq id ##sys#core-library-modules)
1220               (values
1221                (impform
1222                 (if comp?
1223                     `(##core#declare (uses ,id))
1224                     `(##sys#load-library ',id #f) )
1225                 id #t)
1226                #t) )
1227              ((memq id ##sys#explicit-library-modules)
1228               (let* ((info (##sys#extension-information id 'require-extension))
1229                      (s (assq 'syntax info)))
1230                 (values
1231                  `(##core#begin
1232                     ,@(if s `((##core#require-for-syntax ',id)) '())
1233                     ,(impform
1234                       (if comp?
1235                           `(##core#declare (uses ,id)) 
1236                           `(##sys#load-library ',id #f) )
1237                       id #f))
1238                  #t) ) )
1239              (else
1240               (let ((info (##sys#extension-information id 'require-extension)))
1241                 (cond (info
1242                        (let ((s (assq 'syntax info))
1243                              (rr (assq 'require-at-runtime info)) )
1244                          (when s (add-req id #t))
1245                          (values
1246                           (impform
1247                            `(##core#begin
1248                               ,@(if s `((##core#require-for-syntax ',id)) '())
1249                               ,@(if (and (not rr) s)
1250                                     '()
1251                                     `((##sys#require
1252                                        ,@(map (lambda (id) `',id)
1253                                               (cond (rr (cdr rr))
1254                                                     (else (list id)) ) ) ) ) ) )
1255                            id #f)
1256                           #t) ) )
1257                       (else
1258                        (add-req id #f)
1259                        (values
1260                         (impform
1261                          `(##sys#require ',id) 
1262                          id #f)
1263                         #f)))))))
1264      (if (and (pair? id) (symbol? (car id)))
1265          (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
1266            (if a
1267                (let ((a ((##sys#slot a 1) id)))
1268                  (cond ((string? a) (values `(load ,a) #f))
1269                        ((vector? a) 
1270                         (let loop ((specs (vector->list a))
1271                                    (exps '())
1272                                    (f #f) )
1273                           (if (null? specs)
1274                               (values `(##core#begin ,@(reverse exps)) f)
1275                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
1276                                 (loop (cdr specs)
1277                                       (cons exp exps)
1278                                       (or fi f) ) ) ) ) )
1279                        (else (##sys#do-the-right-thing a comp? imp?)) ) )
1280                (##sys#error "undefined extension specifier" id) ) )
1281          (if (symbol? id)
1282              (doit id) 
1283              (##sys#error "invalid extension specifier" id) ) ) ) ) )
1284
1285(define ##sys#extension-specifiers '())
1286
1287(define (set-extension-specifier! name proc)
1288  (##sys#check-symbol name 'set-extension-specifier!)
1289  (let ([a (assq name ##sys#extension-specifiers)])
1290    (if a
1291        (let ([old (##sys#slot a 1)])
1292          (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
1293        (set! ##sys#extension-specifiers
1294          (cons (cons name (lambda (spec) (proc spec #f)))
1295                ##sys#extension-specifiers)) ) ) )
1296
1297
1298;;; SRFI-55
1299
1300(set-extension-specifier!
1301 'srfi 
1302 (let ([list->vector list->vector])
1303   (lambda (spec old)
1304     (list->vector
1305      (let loop ([ids (cdr spec)])
1306        (if (null? ids)
1307            '()
1308            (let ([id (car ids)])
1309              (##sys#check-exact id 'require-extension)
1310              (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
1311                    (loop (cdr ids)) ) ) ) ) ) ) ) )
1312
1313
1314;;; Version checking
1315
1316(set-extension-specifier!
1317 'version
1318 (lambda (spec _)
1319   (define (->string x)
1320     (cond ((string? x) x)
1321           ((symbol? x) (##sys#slot x 1))
1322           ((number? x) (##sys#number->string x))
1323           (else (error "invalid extension version" x)) ) )
1324   (if (and (list? spec) (fx= 3 (length spec)))
1325       (let* ((info (extension-information (cadr spec)))
1326              (vv (and info (assq 'version info))) )
1327         (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
1328           (error "installed extension does not match required version" id vv (caddr spec)))
1329         id) 
1330       (##sys#syntax-error-hook "invalid version specification" spec)) ) )
1331
1332
1333;;; Convert string into valid C-identifier:
1334
1335(define ##sys#string->c-identifier
1336  (let ([string-copy string-copy])
1337    (lambda (str)
1338      (let* ([s2 (string-copy str)]
1339             [n (##sys#size s2)] )
1340        (do ([i 0 (fx+ i 1)])
1341            ((fx>= i n) s2)
1342          (let ([c (##core#inline "C_subchar" s2 i)])
1343            (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
1344              (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )
1345
1346
1347;;; Environments:
1348
1349(define ##sys#r4rs-environment (make-vector environment-table-size '()))
1350(define ##sys#r5rs-environment #f)
1351(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
1352
1353(define (##sys#environment? obj)
1354  (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
1355
1356(define ##sys#copy-env-table
1357  (lambda (e mff mf . args)
1358    (let ([syms (and (pair? args) (car args))])
1359      (let* ([s (##sys#size e)]
1360             [e2 (##sys#make-vector s '())] )
1361       (do ([i 0 (fx+ i 1)])
1362           ((fx>= i s) e2)
1363         (##sys#setslot 
1364          e2 i
1365          (let copy ([b (##sys#slot e i)])
1366            (if (null? b)
1367                '()
1368                (let ([bi (##sys#slot b 0)])
1369                  (let ([sym (##sys#slot bi 0)])
1370                    (if (or (not syms) (memq sym syms))
1371                      (cons (vector
1372                              sym
1373                              (##sys#slot bi 1)
1374                              (if mff mf (##sys#slot bi 2)))
1375                            (copy (##sys#slot b 1)))
1376                      (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
1377
1378(define ##sys#environment-symbols
1379  (lambda (env . args)
1380    (##sys#check-structure env 'environment)
1381    (let ([pred (and (pair? args) (car args))])
1382      (let ([envtbl (##sys#slot env 1)])
1383        (if envtbl
1384            ;then "real" environment
1385          (let ([envtblsiz (vector-length envtbl)])
1386            (do ([i 0 (fx+ i 1)]
1387                 [syms
1388                   '()
1389                   (let loop ([bucket (vector-ref envtbl i)] [syms syms])
1390                     (if (null? bucket)
1391                       syms
1392                       (let ([sym (vector-ref (car bucket) 0)])
1393                         (if (or (not pred) (pred sym))
1394                           (loop (cdr bucket) (cons sym syms))
1395                           (loop (cdr bucket) syms) ) ) ) )])
1396                ((fx>= i envtblsiz) syms) ) )
1397            ;else interaction-environment
1398          (let ([syms '()])
1399            (##sys#walk-namespace
1400              (lambda (sym)
1401                (when (or (not pred) (pred sym))
1402                  (set! syms (cons sym syms)) ) ) )
1403            syms ) ) ) ) ) )
1404
1405(define (interaction-environment) ##sys#interaction-environment)
1406
1407(define scheme-report-environment
1408  (lambda (n . mutable)
1409    (##sys#check-exact n 'scheme-report-environment)
1410    (let ([mf (and (pair? mutable) (car mutable))])
1411      (case n
1412        [(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
1413        [(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
1414        [else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )
1415
1416(define null-environment
1417  (let ([make-vector make-vector])
1418    (lambda (n . mutable)
1419      (##sys#check-exact n 'null-environment)
1420      (when (or (fx< n 4) (fx> n 5))
1421        (##sys#error 'null-environment "no support for version" n) )
1422      (##sys#make-structure
1423       'environment
1424       (make-vector environment-table-size '())
1425       (and (pair? mutable) (car mutable)) ) ) ) )
1426
1427(let ()
1428  (define (initb ht) 
1429    (lambda (b)
1430      (let ([loc (##sys#hash-table-location ht b #t)])
1431        (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
1432  (for-each
1433   (initb ##sys#r4rs-environment)
1434   '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
1435     cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
1436     cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
1437     append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
1438     number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
1439     max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
1440     exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
1441     string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
1442     char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
1443     char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
1444     string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
1445     make-string string-length string-ref string-set! string-append string-copy string->list 
1446     list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
1447     vector-length vector->list list->vector vector-fill! procedure? map for-each apply force 
1448     call-with-current-continuation input-port? output-port? current-input-port current-output-port
1449     call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
1450     close-output-port load read eof-object? read-char peek-char
1451     write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
1452     ##sys#values ##sys#dynamic-wind ##sys#void
1453     ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
1454  (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
1455  (for-each
1456   (initb ##sys#r5rs-environment)
1457   '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )
1458
1459
1460;;; Find included file:
1461
1462(define ##sys#include-pathnames 
1463  (let ((h (chicken-home)))
1464    (if h (list h) '())) )
1465
1466(define ##sys#resolve-include-filename
1467  (let ((string-append string-append) )
1468    (define (exists? fname)
1469      (let ([info (##sys#file-info fname)])
1470        (and info (not (eq? 1 (##sys#slot info 4)))) ) )
1471    (lambda (fname prefer-source #!optional repo)
1472      (define (test2 fname lst)
1473        (if (null? lst)
1474            (and (exists? fname) fname)
1475            (let ([fn (##sys#string-append fname (car lst))])
1476              (if (exists? fn)
1477                  fn
1478                  (test2 fname (cdr lst)) ) ) ) )
1479      (define (test fname)
1480        (test2 
1481         fname
1482         (cond ((not (##sys#fudge 24)) (list source-file-extension)) ; no dload?
1483               (prefer-source (list source-file-extension ##sys#load-dynamic-extension))
1484               (else (list ##sys#load-dynamic-extension source-file-extension) ) ) ))
1485      (or (test fname)
1486          (let loop ((paths (if repo
1487                                (##sys#append 
1488                                 ##sys#include-pathnames 
1489                                 (let ((rp (##sys#repository-path)))
1490                                   (if rp
1491                                       (list (##sys#repository-path))
1492                                       '())))
1493                                ##sys#include-pathnames) ) )
1494            (cond ((eq? paths '()) fname)
1495                  ((test (string-append (##sys#slot paths 0)
1496                                        "/"
1497                                        fname) ) )
1498                  (else (loop (##sys#slot paths 1))) ) ) ) ) ) )
1499
1500
1501;;; Print timing information (support for "time" macro):
1502
1503(define ##sys#display-times
1504  (let* ((display display)
1505         (spaces 
1506          (lambda (n)
1507            (do ((i n (fx- i 1)))
1508                ((fx<= i 0))
1509              (display #\space) ) ) )
1510         (display-rj 
1511          (lambda (x w)
1512            (let* ((xs (if (zero? x) "0" (number->string x)))
1513                   (xslen (##core#inline "C_block_size" xs)) )
1514              (spaces (fx- w xslen))
1515              (display xs) ) ) ) )
1516    (lambda (info)
1517      (display-rj (##sys#slot info 0) 8)
1518      (display " seconds elapsed\n") 
1519      (display-rj (##sys#slot info 1) 8)
1520      (display " seconds in (major) GC\n")
1521      (display-rj (##sys#slot info 2) 8)
1522      (display " mutations\n")
1523      (display-rj (##sys#slot info 3) 8)
1524      (display " minor GCs\n")
1525      (display-rj (##sys#slot info 4) 8)
1526      (display " major GCs\n") ) ) )
1527
1528
1529;;; SRFI-0 support code:
1530
1531(set! ##sys#features
1532  (append '(#:srfi-8 #:srfi-6 #:srfi-2 #:srfi-0 #:srfi-10 #:srfi-9 #:srfi-55 #:srfi-61) 
1533          ##sys#features))
1534
1535
1536;;;; Read-Eval-Print loop:
1537
1538(define ##sys#repl-eval-hook #f)
1539(define ##sys#repl-print-length-limit #f)
1540(define ##sys#repl-read-hook #f)
1541
1542(define (##sys#repl-print-hook x port)
1543  (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
1544  (##sys#write-char-0 #\newline port) )
1545
1546(define repl-prompt (make-parameter (lambda () "#;> ")))
1547
1548(define ##sys#read-prompt-hook
1549  (let ([repl-prompt repl-prompt])
1550    (lambda () 
1551      (##sys#print ((repl-prompt)) #f ##sys#standard-output)
1552      (##sys#flush-output ##sys#standard-output) ) ) )
1553
1554(define ##sys#clear-trace-buffer (foreign-lambda void "C_clear_trace_buffer"))
1555
1556(define repl
1557  (let ((eval eval)
1558        (read read)
1559        (call-with-current-continuation call-with-current-continuation)
1560        (print-call-chain print-call-chain)
1561        (flush-output flush-output)
1562        (load-verbose load-verbose)
1563        (reset reset) )
1564    (lambda ()
1565
1566      (define (write-err xs)
1567        (for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs) )
1568
1569      (define (write-results xs)
1570        (unless (or (null? xs) (eq? (##core#undefined) (car xs)))
1571          (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs) ) )
1572
1573      (let ((stdin ##sys#standard-input)
1574            (stdout ##sys#standard-output)
1575            (stderr ##sys#standard-error)
1576            (ehandler (##sys#error-handler))
1577            (rhandler (##sys#reset-handler)) 
1578            (lv #f)
1579            (uie ##sys#unbound-in-eval) )
1580
1581        (define (saveports)
1582          (set! stdin ##sys#standard-input)
1583          (set! stdout ##sys#standard-output)
1584          (set! stderr ##sys#standard-error) )
1585
1586        (define (resetports)
1587          (set! ##sys#standard-input stdin)
1588          (set! ##sys#standard-output stdout)
1589          (set! ##sys#standard-error stderr) )
1590
1591        (##sys#dynamic-wind
1592         (lambda ()
1593           (set! lv (load-verbose))
1594           (load-verbose #t)
1595           (##sys#error-handler
1596            (lambda (msg . args)
1597              (resetports)
1598              (##sys#print "\nError" #f ##sys#standard-error)
1599              (when msg
1600                (##sys#print ": " #f ##sys#standard-error)
1601                (##sys#print msg #f ##sys#standard-error) )
1602              (if (and (pair? args) (null? (cdr args)))
1603                  (begin
1604                    (##sys#print ": " #f ##sys#standard-error)
1605                    (write-err args) )
1606                  (begin
1607                    (##sys#write-char-0 #\newline ##sys#standard-error)
1608                    (write-err args) ) )
1609              (print-call-chain ##sys#standard-error)
1610              (flush-output ##sys#standard-error) ) ) )
1611         (lambda ()
1612           (let loop ()
1613             (saveports)
1614             (call-with-current-continuation
1615              (lambda (c)
1616                (##sys#reset-handler
1617                 (lambda ()
1618                   (set! ##sys#read-error-with-line-number #f)
1619                   (set! ##sys#enable-qualifiers #t)
1620                   (resetports)
1621                   (c #f) ) ) ) )
1622             (##sys#read-prompt-hook)
1623             (let ([exp ((or ##sys#repl-read-hook read))])
1624               (unless (eof-object? exp)
1625                 (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
1626                   (##sys#read-char-0 ##sys#standard-input) )
1627                 (##sys#clear-trace-buffer)
1628                 (set! ##sys#unbound-in-eval '())
1629                 (receive result ((or ##sys#repl-eval-hook eval) exp)
1630                   (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
1631                     (let loop ((vars ##sys#unbound-in-eval) (u '()))
1632                       (cond ((null? vars)
1633                              (when (pair? u)
1634                                (##sys#print 
1635                                 "Warning: the following toplevel variables are referenced but unbound:\n" 
1636                                 #f ##sys#standard-error)
1637                                (for-each
1638                                 (lambda (v)
1639                                   (##sys#print "  " #f ##sys#standard-error)
1640                                   (##sys#print (car v) #t ##sys#standard-error)
1641                                   (when (cdr v)
1642                                     (##sys#print " (in " #f ##sys#standard-error)
1643                                     (##sys#print (cdr v) #t ##sys#standard-error) 
1644                                     (##sys#write-char-0 #\) ##sys#standard-error) )
1645                                   (##sys#write-char-0 #\newline ##sys#standard-error) )
1646                                 u)
1647                                (##sys#flush-output ##sys#standard-error)))
1648                             ((or (memq (caar vars) u) 
1649                                  (##sys#symbol-has-toplevel-binding? (caar vars)) )
1650                              (loop (cdr vars) u) )
1651                             (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
1652                   (write-results result) 
1653                   (loop) ) ) ) ) )
1654         (lambda ()
1655           (load-verbose lv)
1656           (set! ##sys#unbound-in-eval uie)
1657           (##sys#error-handler ehandler)
1658           (##sys#reset-handler rhandler) ) ) ) ) ) )
1659
1660
1661;;; SRFI-10:
1662
1663(define ##sys#sharp-comma-reader-ctors (make-vector 301 '()))
1664
1665(define (define-reader-ctor spec proc)
1666  (##sys#check-symbol spec 'define-reader-ctor)
1667  (##sys#hash-table-set! ##sys#sharp-comma-reader-ctors spec proc) )
1668
1669(set! ##sys#user-read-hook
1670  (let ((old ##sys#user-read-hook)
1671        (read-char read-char)
1672        (read read) )
1673    (lambda (char port)
1674      (cond ((char=? char #\,)
1675             (read-char port)
1676             (let* ((exp (read port))
1677                    (err (lambda () (##sys#read-error port "invalid sharp-comma external form" exp))) )
1678               (if (or (null? exp) (not (list? exp)))
1679                   (err)
1680                   (let ([spec (##sys#slot exp 0)])
1681                     (if (not (symbol? spec))
1682                         (err) 
1683                         (let ((ctor (##sys#hash-table-ref ##sys#sharp-comma-reader-ctors spec)))
1684                           (if ctor
1685                               (apply ctor (##sys#slot exp 1))
1686                               (##sys#read-error port "undefined sharp-comma constructor" spec) ) ) ) ) ) ) )
1687            (else (old char port)) ) ) ) )
1688
1689
1690;;; Simple invocation API:
1691
1692(declare
1693  (hide last-error run-safe store-result store-string
1694        CHICKEN_yield CHICKEN_apply_to_string
1695        CHICKEN_eval CHICKEN_eval_string CHICKEN_eval_to_string CHICKEN_eval_string_to_string
1696        CHICKEN_apply CHICKEN_eval_apply CHICKEN_eval_to_string
1697        CHICKEN_read CHICKEN_load CHICKEN_get_error_message) )
1698       
1699(define last-error #f)
1700
1701(define (run-safe thunk)
1702  (set! last-error #f)
1703  (handle-exceptions ex 
1704      (let ((o (open-output-string)))
1705        (print-error-message ex o)
1706        (set! last-error (get-output-string o))
1707        #f)
1708    (thunk) ) )
1709
1710#>
1711#define C_store_result(x, ptr)   (*((C_word *)C_block_item(ptr, 0)) = (x), C_SCHEME_TRUE)
1712<#
1713
1714(define (store-result x result)
1715  (##sys#gc #f)
1716  (when result
1717    (##core#inline "C_store_result" x result) )
1718  #t)
1719
1720(define-external (CHICKEN_yield) bool
1721  (run-safe (lambda () (begin (thread-yield!) #t))) )
1722
1723(define-external (CHICKEN_eval (scheme-object exp) ((c-pointer "C_word") result)) bool
1724  (run-safe
1725   (lambda ()
1726     (store-result (eval exp) result) ) ) )
1727
1728(define-external (CHICKEN_eval_string (c-string str) ((c-pointer "C_word") result)) bool
1729  (run-safe
1730   (lambda ()
1731     (let ([i (open-input-string str)])
1732       (store-result (eval (read i)) result)) )))
1733
1734#>
1735#define C_copy_result_string(str, buf, n)  (C_memcpy((char *)C_block_item(buf, 0), C_c_string(str), C_unfix(n)), ((char *)C_block_item(buf, 0))[ C_unfix(n) ] = '\0', C_SCHEME_TRUE)
1736<#
1737
1738(define (store-string str bufsize buf)
1739  (let ((len (##sys#size str)))
1740    (cond ((fx>= len bufsize)
1741           (set! last-error "Error: not enough room for result string")
1742           #f)
1743          (else (##core#inline "C_copy_result_string" str buf len)) ) ) )
1744
1745(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
1746                                          (int bufsize))
1747  bool
1748  (run-safe
1749   (lambda ()
1750     (let ([o (open-output-string)])
1751       (write (eval exp) o) 
1752       (store-string (get-output-string o) bufsize buf)) ) ) )
1753
1754(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
1755                                                 (int bufsize) ) 
1756  bool
1757  (run-safe
1758   (lambda ()
1759     (let ([o (open-output-string)])
1760       (write (eval (read (open-input-string str))) o)
1761       (store-string (get-output-string o) bufsize buf)) ) ) )
1762
1763(define-external (CHICKEN_apply (scheme-object func) (scheme-object args) 
1764                                 ((c-pointer "C_word") result))
1765  bool
1766  (run-safe (lambda () (store-result (apply func args) result))) )
1767
1768(define-external (CHICKEN_apply_to_string (scheme-object func) (scheme-object args) 
1769                                           ((c-pointer "char") buf) (int bufsize))
1770  bool
1771  (run-safe
1772   (lambda ()
1773     (let ([o (open-output-string)])
1774       (write (apply func args) o) 
1775       (store-string (get-output-string o) bufsize buf)) ) ) )
1776
1777(define-external (CHICKEN_read (c-string str) ((c-pointer "C_word") result)) bool
1778  (run-safe
1779   (lambda ()
1780     (let ([i (open-input-string str)])
1781       (store-result (read i) result) ) ) ) )
1782
1783(define-external (CHICKEN_load (c-string str)) bool
1784  (run-safe (lambda () (load str) #t)) )
1785
1786(define-external (CHICKEN_get_error_message ((c-pointer "char") buf) (int bufsize)) void
1787  (store-string (or last-error "No error") bufsize buf) )
1788
1789
1790;;; Create lambda-info object
1791
1792(define (##sys#make-lambda-info str)
1793  (let* ((sz (##sys#size str))
1794         (info (##sys#make-string sz)) )
1795    (##core#inline "C_copy_memory" info str sz)
1796    (##core#inline "C_string_to_lambdainfo" info)
1797    info) )
Note: See TracBrowser for help on using the repository browser.