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

Last change on this file since 10426 was 10426, checked in by felix winkelmann, 13 years ago

removed current module crap and made compiler run again; fixed several bugs introduced by decruftification; I'm still the boss here.

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