source: project/chicken/branches/hygienic/eval.scm @ 11401

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

working mini-setup; csi describe and report tweaks; wrong handling of require-extension with core libs (import case)

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