source: project/chicken/branches/beyond-hope/eval.scm @ 10211

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

added feature-ids for highlevel macros; fixes; more tests, all is well

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