source: project/chicken/trunk/eval.scm @ 15543

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

merged inlining branch (r15318:15542) into trunk; updated bootstrap tarball; bumped version to 4.1.4

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