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

Last change on this file since 15951 was 15951, checked in by Kon Lovett, 10 years ago

Unit srfi-69 is-a core-library-module but not a builtin-feature, and Unit regex-extras doesn't exist.
Added %list-fold, alist routines, renamed any/1. (chicken-primitive-object-inlines.scm).

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