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

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

painfully slowly debugging compiler

File size: 57.4 KB
Line 
1;;;; eval.scm - Interpreter for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit eval)
30  (uses expand)
31  (disable-warning var)
32  (hide ##sys#split-at-separator
33        ##sys#r4rs-environment ##sys#r5rs-environment 
34        ##sys#interaction-environment pds pdss pxss) )
35
36(define (d arg1 . more)
37  (if (null? more)
38      (pp arg1)
39      (apply print arg1 more)))
40
41(cond-expand 
42 (hygienic-macros
43  (define-syntax d (syntax-rules () ((_ . _) (void)))) )
44 (else
45  (define-macro (d . _) '(void))))      ;*** remove later
46
47#>
48#ifndef C_INSTALL_EGG_HOME
49# define C_INSTALL_EGG_HOME    "."
50#endif
51
52#ifndef C_INSTALL_SHARE_HOME
53# define C_INSTALL_SHARE_HOME NULL
54#endif
55<#
56
57(cond-expand
58 [paranoia]
59 [else
60  (declare
61    ;***(no-bound-checks)
62    (no-procedure-checks-for-usual-bindings)
63    (bound-to-procedure 
64     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#load-library
65     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#not-a-proper-list-error
66     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round 
67     ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
68     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure 
69     ##sys#make-structure ##sys#feature?
70     ##sys#error-handler ##sys#hash-symbol ##sys#check-syntax
71     ##sys#hash-table-ref ##sys#hash-table-set! ##sys#canonicalize-body ##sys#decompose-lambda-list
72     ##sys#make-c-string ##sys#resolve-include-filename
73     ##sys#load ##sys#error ##sys#warn ##sys#hash-table-location ##sys#expand-home-path
74     ##sys#make-flonum ##sys#make-pointer ##sys#null-pointer ##sys#address->pointer 
75     ##sys#pointer->address ##sys#compile-to-closure ##sys#make-string ##sys#make-lambda-info
76     ##sys#number? ##sys#symbol->qualified-string ##sys#decorate-lambda ##sys#string-append
77     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
78     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
79     open-output-string get-output-string make-parameter software-type software-version machine-type
80     build-platform getenv set-extensions-specifier! ##sys#string->symbol list->vector
81     extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
82     vector->list store-string open-input-string eval ##sys#gc
83     with-exception-handler print-error-message read-char read ##sys#read-error
84     ##sys#reset-handler call-with-current-continuation ##sys#peek-char-0 ##sys#read-char-0
85     ##sys#clear-trace-buffer ##sys#write-char-0 print-call-chain ##sys#with-print-length-limit
86     repl-prompt ##sys#flush-output ##sys#extended-lambda-list? keyword? get-line-number
87     symbol->string string-append display ##sys#repository-path ##sys#file-info make-vector
88     ##sys#make-vector string-copy vector->list ##sys#do-the-right-thing ##sys#->feature-id
89     ##sys#extension-information ##sys#symbol->string ##sys#canonicalize-extension-path
90     file-exists? ##sys#load-extension ##sys#find-extension ##sys#substring reverse
91     dynamic-load-libraries ##sys#string->c-identifier load-verbose ##sys#load ##sys#get-keyword
92     port? ##sys#file-info ##sys#signal-hook ##sys#dload open-input-file close-input-port
93     read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
94     map string->keyword ##sys#abort
95     ##sys#expand-0) ) ] )
96
97(include "unsafe-declarations.scm")
98
99(cond-expand 
100 ((not unsafe) (declare (emit-exports "eval.exports")))
101 (else))
102
103(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
104(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
105
106(define ##sys#core-library-modules
107  '(extras lolevel utils tcp regex regex-extras posix srfi-1 srfi-4 srfi-13 srfi-14 srfi-18))
108
109(define ##sys#explicit-library-modules '())
110
111(define-constant default-dynamic-load-libraries '("libchicken"))
112(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
113(define-constant macosx-load-library-extension ".dylib")
114(define-constant windows-load-library-extension ".dll")
115(define-constant hppa-load-library-extension ".sl")
116(define-constant default-load-library-extension ".so")
117(define-constant environment-table-size 301)
118(define-constant source-file-extension ".scm")
119(define-constant setup-file-extension "setup-info")
120(define-constant repository-environment-variable "CHICKEN_REPOSITORY")
121(define-constant prefix-environment-variable "CHICKEN_PREFIX")
122(define-constant special-syntax-files '(chicken-ffi-macros chicken-more-macros))
123(define-constant default-binary-version 3)
124
125; these are actually in unit extras, but that is used by default
126; srfi-12 in unit library
127(define-constant builtin-features
128  '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39 srfi-69) )
129
130(define-constant builtin-features/compiled
131  '(srfi-6 srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26 srfi-55) )
132
133(define ##sys#chicken-prefix
134  (let ((prefix (and-let* ((p (getenv prefix-environment-variable)))
135                  (##sys#string-append 
136                   p
137                   (if (memq (string-ref p (fx- (##sys#size p) 1)) '(#\\ #\/))
138                       "" "/") ) ) ) )
139    (lambda (#!optional dir)
140      (and prefix
141           (if dir (##sys#string-append prefix dir) prefix) ) ) ) )
142         
143
144;;; System settings
145
146(define chicken-home
147  (let ([getenv getenv])
148    (lambda ()
149      (or (##sys#chicken-prefix "share/chicken")
150          installation-home) ) ) )
151
152
153;;; Lo-level hashtable support:
154
155(define ##sys#hash-symbol
156  (let ([cache-s #f]
157        [cache-h #f] )
158    (lambda (s n)
159      (if (eq? s cache-s)
160          (##core#inline "C_fixnum_modulo" cache-h n)
161          (let ([h (##core#inline "C_hash_string" (##sys#slot s 1))])
162            (set! cache-s s)
163            (set! cache-h h)
164            (##core#inline "C_fixnum_modulo" h n) ) ) ) ) )
165
166(define (##sys#hash-table-ref ht key)
167  (let ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht))))
168    (let loop ((bucket (##sys#slot ht k)))
169      (if (eq? bucket '())
170          #f
171          (let ((b (##sys#slot bucket 0)))
172            (if (eq? key (##sys#slot b 0))
173                (##sys#slot b 1)
174                (loop (##sys#slot bucket 1)) ) ) ) ) ) )
175
176(define ##sys#hash-table-set! 
177  (lambda (ht key val)
178    (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
179           (bucket0 (##sys#slot ht k)) )
180      (let loop ((bucket bucket0))
181        (if (eq? bucket '())
182            (##sys#setslot ht k (cons (cons key val) bucket0))
183            (let ((b (##sys#slot bucket 0)))
184              (if (eq? key (##sys#slot b 0))
185                  (##sys#setslot b 1 val)
186                  (loop (##sys#slot bucket 1)) ) ) ) ) ) ) )
187
188(define (##sys#hash-table-for-each p ht)
189  (let ((len (##core#inline "C_block_size" ht)))
190    (do ((i 0 (fx+ i 1)))
191        ((fx>= i len))
192      (##sys#for-each (lambda (bucket) 
193                   (p (##sys#slot bucket 0)
194                      (##sys#slot bucket 1) ) )
195                 (##sys#slot ht i) ) ) ) )
196
197(define ##sys#hash-table-location
198  (let ([unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)])
199    (lambda (ht key addp)
200      (let* ([k (##sys#hash-symbol key (##sys#size ht))]
201             [bucket0 (##sys#slot ht k)] )
202        (let loop ([bucket bucket0])
203          (if (null? bucket)
204              (and addp
205                   (let ([p (vector key unbound #t)])
206                     (##sys#setslot ht k (cons p bucket0))
207                     p) )
208              (let ([b (##sys#slot bucket 0)])
209                (if (eq? key (##sys#slot b 0))
210                    b
211                    (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )
212
213
214;;; Compile lambda to closure:
215
216(define ##sys#eval-environment #f)
217(define ##sys#environment-is-mutable #f)
218
219(define (##sys#eval-decorator p ll h cntr)
220  (##sys#decorate-lambda
221   p 
222   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
223   (lambda (p i)
224     (##sys#setslot 
225      p i 
226      (##sys#make-lambda-info 
227       (let ((o (open-output-string)))
228         (write ll o)
229         (get-output-string o))))
230     p) ) )
231
232(define ##sys#unbound-in-eval #f)
233(define ##sys#eval-debug-level 1)
234
235(define ##sys#compile-to-closure
236  (let ([write write]
237        [reverse reverse]
238        [open-output-string open-output-string]
239        [get-output-string get-output-string] 
240        [with-input-from-file with-input-from-file]
241        [unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
242        [display display] )
243    (lambda (exp env se #!optional cntr)
244
245      (define (find-id id se)           ; ignores macro bindings
246        (cond ((null? se) #f)
247              ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
248              (else (find-id id (cdr se)))))
249
250      (define (rename var se)
251        (cond ((find-id var se))
252              ((##sys#get var '##sys#macro-alias))
253              (else var)))
254
255      (define (lookup var0 e se)
256        (let ((var (rename var0 se)))
257          (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map car se)))
258          (let loop ((envs e) (ei 0))
259            (cond ((null? envs) (values #f var))
260                  ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
261                  (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
262
263      (define (posq x lst)
264        (let loop ((lst lst) (i 0))
265          (cond ((null? lst) #f)
266                ((eq? x (##sys#slot lst 0)) i)
267                (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
268
269      (define (emit-trace-info tf info cntr) 
270        (when tf
271          (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )
272
273      (define (emit-syntax-trace-info tf info cntr) 
274        (when tf
275          (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
276       
277      (define (decorate p ll h cntr)
278        (##sys#eval-decorator p ll h cntr) )
279
280      (define (eval/meta form)
281        ((##sys#compile-to-closure
282          form
283          '() 
284          (##sys#current-meta-environment))
285         '() ) )
286
287      (define (eval/elab form)
288        ((##sys#compile-to-closure
289          form
290          '() 
291          (##sys#current-environment))
292         '() ) )
293
294      (define (compile x e h tf cntr se)
295        (cond [(symbol? x)
296               (receive (i j) (lookup x e se)
297                 (cond [(not i)
298                        (let ((var (##sys#alias-global-hook j)))
299                          (if ##sys#eval-environment
300                              (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
301                                (unless loc (##sys#syntax-error-hook "reference to undefined identifier" var))
302                                (cond-expand 
303                                 [unsafe (lambda v (##sys#slot loc 1))]
304                                 [else
305                                  (lambda v 
306                                    (let ([val (##sys#slot loc 1)])
307                                      (if (eq? unbound val)
308                                          (##sys#error "unbound variable" var)
309                                          val) ) ) ] ) )
310                              (cond-expand
311                               [unsafe (lambda v (##core#inline "C_slot" var 0))]
312                               [else
313                                (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? var)))
314                                  (set! ##sys#unbound-in-eval (cons (cons var cntr) ##sys#unbound-in-eval)) )
315                                (lambda v (##core#inline "C_retrieve" var))] ) ) ) ]
316                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
317                       [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) ]
318              [(##sys#number? x)
319               (case x
320                 [(-1) (lambda v -1)]
321                 [(0) (lambda v 0)]
322                 [(1) (lambda v 1)]
323                 [(2) (lambda v 2)]
324                 [else (lambda v x)] ) ]
325              [(boolean? x)
326               (if x
327                   (lambda v #t)
328                   (lambda v #f) ) ]
329              [(or (char? x)
330                   (eof-object? x)
331                   (string? x) )
332               (lambda v x) ]
333              [(not (pair? x)) (##sys#syntax-error-hook "illegal non-atomic object" x)]
334              [(symbol? (##sys#slot x 0))
335               (emit-syntax-trace-info tf x cntr)
336               (let ((x2 (##sys#expand x se)))
337                 (d `(EVAL/EXPANDED: ,x2))
338                 (if (not (eq? x2 x))
339                     (compile x2 e h tf cntr se)
340                     (let ((head (rename (##sys#slot x 0) se)))
341                       (case head
342
343                         [(quote)
344                          (##sys#check-syntax 'quote x '(quote _) #f se)
345                          (let* ((c (##sys#strip-syntax (cadr x))))
346                            (case c
347                              [(-1) (lambda v -1)]
348                              [(0) (lambda v 0)]
349                              [(1) (lambda v 1)]
350                              [(2) (lambda v 2)]
351                              [(#t) (lambda v #t)]
352                              [(#f) (lambda v #f)]
353                              [(()) (lambda v '())]
354                              [else (lambda v c)] ) ) ]
355
356                         ((##core#syntax)
357                          (let ((c (cadr x)))
358                            (lambda v c)))
359
360                         [(##core#global-ref)
361                          (let ([var (cadr x)])
362                            (if ##sys#eval-environment
363                                (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
364                                  (lambda v (##sys#slot loc 1)) )
365                                (lambda v (##core#inline "C_slot" var 0)) ) ) ]
366
367                         [(##core#check)
368                          (compile (cadr x) e h tf cntr se) ]
369
370                         [(##core#immutable)
371                          (compile (cadr x) e #f tf cntr se) ]
372                   
373                         [(##core#undefined) (lambda (v) (##core#undefined))]
374
375                         [(if)
376                          (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
377                          (let* ([test (compile (cadr x) e #f tf cntr se)]
378                                 [cns (compile (caddr x) e #f tf cntr se)]
379                                 [alt (if (pair? (cdddr x))
380                                          (compile (cadddr x) e #f tf cntr se)
381                                          (compile '(##core#undefined) e #f tf cntr se) ) ] )
382                            (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
383
384                         [(begin)
385                          (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
386                          (let* ([body (##sys#slot x 1)]
387                                 [len (length body)] )
388                            (case len
389                              [(0) (compile '(##core#undefined) e #f tf cntr se)]
390                              [(1) (compile (##sys#slot body 0) e #f tf cntr se)]
391                              [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
392                                          [x2 (compile (cadr body) e #f tf cntr se)] )
393                                     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
394                              [else
395                               (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
396                                      [x2 (compile (cadr body) e #f tf cntr se)] 
397                                      [x3 (compile `(,(rename 'begin se) ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
398                                 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
399
400                         [(set! ##core#set!)
401                          (##sys#check-syntax 'set! x '(_ variable _) #f se)
402                          (let ((var (cadr x)))
403                            (receive (i j) (lookup var e se)
404                              (let ((val (compile (caddr x) e var tf cntr se)))
405                                (cond [(not i)
406                                       (let ((var (##sys#alias-global-hook j)))
407                                         (if ##sys#eval-environment
408                                             (let ([loc (##sys#hash-table-location
409                                                         ##sys#eval-environment 
410                                                         var
411                                                         ##sys#environment-is-mutable) ] )
412                                               (unless loc (##sys#error "assignment of undefined identifier" var))
413                                               (if (##sys#slot loc 2)
414                                                   (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
415                                                   (lambda v (##sys#error "assignment to immutable variable" var)) ) )
416                                             (lambda (v)
417                                               (##sys#setslot var 0 (##core#app val v))) ) ) ]
418                                      [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
419                                      [else
420                                       (lambda (v)
421                                         (##sys#setslot
422                                          (##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
423
424                         [(let)
425                          (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f se)
426                          (let* ([bindings (cadr x)]
427                                 [n (length bindings)] 
428                                 [vars (map (lambda (x) (car x)) bindings)] 
429                                 (aliases (map gensym vars))
430                                 [e2 (cons aliases e)]
431                                 (se2 (append (map cons vars aliases) se))
432                                 [body (##sys#compile-to-closure
433                                        (##sys#canonicalize-body (cddr x) se2)
434                                        e2
435                                        se2
436                                        cntr) ] )
437                            (case n
438                              [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
439                                     (lambda (v)
440                                       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
441                              [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
442                                         [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] )
443                                     (lambda (v)
444                                       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
445                              [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
446                                          [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
447                                          [t (cddr bindings)]
448                                          [val3 (compile (cadar t) e (caddr vars) tf cntr se)] )
449                                     (lambda (v)
450                                       (##core#app 
451                                        body
452                                        (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
453                              [(4) (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                                          [val4 (compile (cadadr t) e (cadddr vars) tf cntr se)] )
458                                     (lambda (v)
459                                       (##core#app 
460                                        body
461                                        (cons (vector (##core#app val1 v)
462                                                      (##core#app val2 v)
463                                                      (##core#app val3 v)
464                                                      (##core#app val4 v))
465                                              v)) ) ) ]
466                              [else
467                               (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])
468                                 (lambda (v)
469                                   (let ([v2 (##sys#make-vector n)])
470                                     (do ([i 0 (fx+ i 1)]
471                                          [vlist vals (##sys#slot vlist 1)] )
472                                         ((fx>= i n))
473                                       (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
474                                     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
475
476                         [(lambda)
477                          (##sys#check-syntax 'lambda x '(lambda lambda-list . #(_ 1)) #f se)
478                          (let* ([llist (cadr x)]
479                                 [body (cddr x)] 
480                                 [info (cons (or h '?) llist)] )
481                            (when (##sys#extended-lambda-list? llist)
482                              (set!-values 
483                               (llist body) 
484                               (##sys#expand-extended-lambda-list 
485                                llist body ##sys#syntax-error-hook se) ) ) 
486                            (##sys#decompose-lambda-list
487                             llist
488                             (lambda (vars argc rest)
489                               (let* ((aliases (map gensym vars))
490                                      (se2 (append (map cons vars aliases) se))
491                                      (e2 (cons aliases e))
492                                      (body 
493                                       (##sys#compile-to-closure
494                                        (##sys#canonicalize-body body se2)
495                                        e2
496                                        se2
497                                        (or h cntr) ) ) )
498                                 (case argc
499                                   [(0) (if rest
500                                            (lambda (v)
501                                              (decorate
502                                               (lambda r
503                                                 (##core#app body (cons (vector r) v)))
504                                               info h cntr) )
505                                            (lambda (v)
506                                              (decorate
507                                               (lambda () (##core#app body (cons #f v)))
508                                               info h cntr) ) ) ]
509                                   [(1) (if rest
510                                            (lambda (v)
511                                              (decorate
512                                               (lambda (a1 . r)
513                                                 (##core#app body (cons (vector a1 r) v)))
514                                               info h cntr) ) 
515                                            (lambda (v)
516                                              (decorate 
517                                               (lambda (a1)
518                                                 (##core#app body (cons (vector a1) v)))
519                                               info h cntr) ) ) ]
520                                   [(2) (if rest
521                                            (lambda (v) 
522                                              (decorate
523                                               (lambda (a1 a2 . r)
524                                                 (##core#app body (cons (vector a1 a2 r) v)))
525                                               info h cntr) )
526                                            (lambda (v)
527                                              (decorate
528                                               (lambda (a1 a2)
529                                                 (##core#app body (cons (vector a1 a2) v)))
530                                               info h cntr) ) ) ]
531                                   [(3) (if rest
532                                            (lambda (v) 
533                                              (decorate
534                                               (lambda (a1 a2 a3 . r)
535                                                 (##core#app body (cons (vector a1 a2 a3 r) v)))
536                                               info h cntr) )
537                                            (lambda (v)
538                                              (decorate
539                                               (lambda (a1 a2 a3)
540                                                 (##core#app body (cons (vector a1 a2 a3) v)))
541                                               info h cntr) ) ) ]
542                                   [(4) (if rest
543                                            (lambda (v)
544                                              (decorate
545                                               (lambda (a1 a2 a3 a4 . r)
546                                                 (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
547                                               info h cntr) )
548                                            (lambda (v)
549                                              (decorate
550                                               (lambda (a1 a2 a3 a4)
551                                                 (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
552                                               info h cntr) ) ) ]
553                                   [else
554                                    (if rest
555                                        (lambda (v)
556                                          (decorate
557                                           (lambda as
558                                             (##core#app
559                                              body
560                                              (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
561                                           info h cntr) )
562                                        (lambda (v)
563                                          (decorate
564                                           (lambda as 
565                                             (let ([len (length as)])
566                                               (if (not (fx= len argc))
567                                                   (##sys#error "bad argument count" argc len)
568                                                   (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
569                                           info h cntr) ) ) ] ) ) ) ) ) ]
570
571                         ((let-syntax)
572                          (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
573                          (let ((se2 (append
574                                      (map (lambda (b)
575                                             (list
576                                              (car b)
577                                              se
578                                              (##sys#er-transformer
579                                               (eval/meta (cadr b)))))
580                                           (cadr x) ) 
581                                      se) ) )
582                            (compile
583                             (##sys#canonicalize-body (cddr x) se2)
584                             e #f tf cntr se2)))
585                               
586                         ((letrec-syntax)
587                          (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
588                          (let* ((ms (map (lambda (b)
589                                            (list
590                                             (car b)
591                                             #f
592                                             (##sys#er-transformer
593                                              (eval/meta (cadr b)))))
594                                          (cadr x) ) )
595                                 (se2 (append ms se)) )
596                            (for-each
597                             (lambda (sb)
598                               (set-car! (cdr sb) se2) )
599                             ms) 
600                            (compile
601                             (##sys#canonicalize-body (cddr x) se2)
602                             e #f tf cntr se2)))
603                               
604                         ((define-syntax)
605                          (##sys#check-syntax 'define-syntax x '(define-syntax variable _) #f se)
606                          (##sys#extend-macro-environment
607                           (rename (cadr x) se)
608                           (##sys#current-environment)
609                           (##sys#er-transformer
610                            (eval/meta (caddr x))))
611                          (compile '(##core#undefined) e #f tf cntr se) )
612
613                         [(##core#loop-lambda)
614                          (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
615
616                         [(##core#named-lambda)
617                          (compile `(,(rename 'lambda se) ,@(cddr x)) e (cadr x) tf cntr se) ]
618
619                         [(##core#require-for-syntax)
620                          (let ([ids (map (lambda (x)
621                                            (eval/meta x))
622                                          (cdr x))])
623                            (apply ##sys#require ids)
624                            (let ([rs (##sys#lookup-runtime-requirements ids)])
625                              (compile
626                               (if (null? rs)
627                                   '(##core#undefined)
628                                   `(##sys#require ,@(map (lambda (x) `',x) rs)) )
629                               e #f tf cntr se) ) ) ]
630
631                         [(##core#require-extension)
632                          (compile
633                           (let loop ([ids (cdr x)])
634                             (if (null? ids)
635                                 '(##core#undefined)
636                                 (let-values ([(exp _) (##sys#do-the-right-thing (car ids) #f)])
637                                   `(,(rename 'begin se) ,exp ,(loop (cdr ids))) ) ) )
638                           e #f tf cntr se) ]
639
640                         [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
641                          (eval/elab (cadr x))
642                          (compile '(##core#undefined) e #f tf cntr se) ]
643
644                         [(##core#compiletimetoo)
645                          (compile (cadr x) e #f tf cntr se) ]
646
647                         [(##core#compiletimeonly ##core#callunit) 
648                          (compile '(##core#undefined) e #f tf cntr se) ]
649
650                         [(##core#declare)
651                          (if (memq #:compiling ##sys#features)
652                              (for-each (lambda (d) (##compiler#process-declaration (cadr d))) (cdr x)) 
653                              (##sys#warn "declarations are ignored in interpreted code" x) )
654                          (compile '(##core#undefined) e #f tf cntr se) ]
655
656                         [(define-inline define-constant)
657                          (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
658                   
659                         [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
660                                            ##core#define-foreign-variable 
661                                            ##core#define-external-variable ##core#let-location
662                                            ##core#foreign-primitive
663                                            ##core#foreign-lambda* ##core#define-foreign-type)
664                          (##sys#syntax-error-hook "can not evaluate compiler-special-form" x) ]
665
666                         [(##core#app)
667                          (compile-call (cdr x) e tf cntr se) ]
668
669                         [else
670                          (cond [(eq? head 'location)
671                                 (##sys#syntax-error-hook "can not evaluate compiler-special-form" x) ]
672
673                                [else (compile-call x e tf cntr se)] ) ] ) ) ) ) ]
674             
675              [else
676               (emit-syntax-trace-info tf x cntr)
677               (compile-call x e tf cntr se)] ) )
678
679      (define (fudge-argument-list n alst)
680        (if (null? alst) 
681            (list alst)
682            (do ([n n (fx- n 1)]
683                 [args alst (##sys#slot args 1)]
684                 [last #f args] )
685                ((fx= n 0)
686                 (##sys#setslot last 1 (list args))
687                 alst) ) ) )
688
689      (define (checked-length lst)
690        (let loop ([lst lst] [n 0])
691          (cond [(null? lst) n]
692                [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
693                [else #f] ) ) )
694
695      (define (compile-call x e tf cntr se)
696        (let* ([fn (compile (##sys#slot x 0) e #f tf cntr se)]
697               [args (##sys#slot x 1)]
698               [argc (checked-length args)]
699               [info x] )
700          (case argc
701            [(#f) (##sys#syntax-error-hook "malformed expression" x)]
702            [(0) (lambda (v)
703                   (emit-trace-info tf info cntr)
704                   ((fn v)))]
705            [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
706                   (lambda (v)
707                     (emit-trace-info tf info cntr)
708                     ((##core#app fn v) (##core#app a1 v))) ) ]
709            [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
710                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
711                   (lambda (v)
712                     (emit-trace-info tf info cntr)
713                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
714            [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
715                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
716                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
717                   (lambda (v)
718                     (emit-trace-info tf info cntr)
719                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
720            [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
721                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
722                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] 
723                        [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
724                   (lambda (v)
725                     (emit-trace-info tf info cntr)
726                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
727            [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
728                    (lambda (v)
729                      (emit-trace-info tf info cntr)
730                      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
731
732      (compile exp env #f (fx> ##sys#eval-debug-level 0) cntr se) ) ) )
733
734(define ##sys#eval-handler 
735  (make-parameter
736   (lambda (x . env)
737     (let ([mut ##sys#environment-is-mutable]
738           [e #f] )
739       (when (pair? env)
740         (let ([env (car env)])
741           (when env
742             (##sys#check-structure env 'environment)
743             (set! e (##sys#slot env 1)) 
744             (set! mut (##sys#slot env 2)) ) ) )
745       ((fluid-let ([##sys#environment-is-mutable mut]
746                    [##sys#eval-environment e] )
747          (##sys#compile-to-closure x '() (##sys#current-environment)) )
748        '() ) ) ) ) )
749
750(define eval-handler ##sys#eval-handler)
751
752(define (eval x . env)
753  (apply (##sys#eval-handler) 
754         x
755         env) )
756
757;;; Split lambda-list into its parts:
758
759(define ##sys#decompose-lambda-list
760  (let ([reverse reverse])
761    (lambda (llist0 k)
762
763      (define (err)
764        (set! ##sys#syntax-error-culprit #f)
765        (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
766
767      (let loop ([llist llist0] [vars '()] [argc 0])
768        (cond [(eq? llist '()) (k (reverse vars) argc #f)]
769              [(not (##core#inline "C_blockp" llist)) (err)]
770              [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
771              [(not (##core#inline "C_pairp" llist)) (err)]
772              [else (loop (##sys#slot llist 1)
773                          (cons (##sys#slot llist 0) vars)
774                          (fx+ argc 1) ) ] ) ) ) ) )
775
776
777;;; Loading source/object files:
778
779(define load-verbose (make-parameter (##sys#fudge 13)))
780
781(define (##sys#abort-load) #f)
782(define ##sys#current-source-filename #f)
783(define ##sys#current-load-path "")
784
785(define-foreign-variable _dlerror c-string "C_dlerror")
786
787(define (set-dynamic-load-mode! mode)
788  (let ([mode (if (pair? mode) mode (list mode))]
789        [now #f]
790        [global #t] )
791    (let loop ([mode mode])
792      (when (pair? mode)
793        (case (##sys#slot mode 0)
794          [(global) (set! global #t)]
795          [(local) (set! global #f)]
796          [(lazy) (set! now #f)]
797          [(now) (set! now #t)]
798          [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
799        (loop (##sys#slot mode 1)) ) )
800    (##sys#set-dlopen-flags! now global) ) )
801
802(let ([read read]
803      [write write]
804      [display display]
805      [newline newline]
806      [eval eval]
807      [open-input-file open-input-file]
808      [close-input-port close-input-port]
809      [string-append string-append] 
810      [load-verbose load-verbose]
811      [topentry (##sys#make-c-string "C_toplevel")] )
812  (define (has-sep? str)
813    (let loop ([i (fx- (##sys#size str) 1)])
814      (and (not (zero? i))
815           (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
816               i
817               (loop (fx- i 1)) ) ) ) )
818  (define (badfile x)
819    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
820  (set! ##sys#load 
821    (lambda (input evaluator pf #!optional timer printer)
822      (when (string? input) 
823        (set! input (##sys#expand-home-path input)) )
824      (let* ([isdir #f]
825             [fname 
826             (cond [(port? input) #f]
827                   [(not (string? input)) (badfile input)]
828                   [(and-let* ([info (##sys#file-info input)]
829                               [id (##sys#slot info 4)] )
830                      (set! isdir (eq? 1 id)) 
831                      (not id) )
832                    input]
833                   [else
834                    (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
835                      (if (##sys#file-info fname2)
836                          fname2
837                          (let ([fname3 (##sys#string-append input source-file-extension)])
838                            (if (##sys#file-info fname3)
839                                fname3
840                                (and (not isdir) input) ) ) ) ) ] ) ]
841            [evproc (or evaluator eval)] )
842        (cond [(and (string? input) (not fname))
843               (##sys#signal-hook #:file-error 'load "can not open file" input) ]
844              [(and (load-verbose) fname)
845               (display "; loading ")
846               (display fname)
847               (display " ...\n") ] )
848        (or (and fname
849                 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
850                     (and (not (has-sep? fname))
851                          (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
852            (call-with-current-continuation
853             (lambda (abrt)
854               (fluid-let ([##sys#read-error-with-line-number #t]
855                           [##sys#current-source-filename fname]
856                           [##sys#current-load-path
857                            (and fname
858                                 (let ((i (has-sep? fname)))
859                                   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
860                           [##sys#abort-load (lambda () (abrt #f))] )
861                 (let ([in (if fname (open-input-file fname) input)])
862                   (##sys#dynamic-wind
863                    (lambda () #f)
864                    (lambda ()
865                      (let ([c1 (peek-char in)])
866                        (when (char=? c1 (integer->char 127))
867                          (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
868                      (let ((x1 (read in)))
869                        (do ((x x1 (read in)))
870                            ((eof-object? x))
871                          (when printer (printer x))
872                          (##sys#call-with-values
873                           (lambda () 
874                             (if timer
875                                 (time (evproc x)) 
876                                 (evproc x) ) )
877                           (lambda results
878                             (when pf
879                               (for-each
880                                (lambda (r) 
881                                  (write r)
882                                  (newline) )
883                                results) ) ) ) ) ) )
884                    (lambda () (close-input-port in)) ) ) ) ) ) )
885        (##core#undefined) ) ) )
886  (set! load
887    (lambda (filename . evaluator)
888      (##sys#load filename (:optional evaluator #f) #f) ) )
889  (set! load-relative
890    (lambda (filename . evaluator)
891      (##sys#load
892       (if (memq (string-ref filename 0) '(#\\ #\/))
893           filename
894           (##sys#string-append ##sys#current-load-path filename) )
895       (:optional evaluator #f) #f) ) )
896  (set! load-noisily
897    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
898      (##sys#load filename evaluator #t time printer) ) ) )
899
900(define ##sys#load-library-extension    ; this is crude...
901  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
902        [(eq? (software-version) 'macosx) macosx-load-library-extension]
903        [(and (eq? (software-version) 'hpux) 
904              (eq? (machine-type) 'hppa)) hppa-load-library-extension]
905        [else default-load-library-extension] ) )
906
907(define ##sys#load-dynamic-extension default-load-library-extension)
908
909(define ##sys#default-dynamic-load-libraries 
910  (case (build-platform)
911    ((cygwin) cygwin-default-dynamic-load-libraries)
912    (else default-dynamic-load-libraries) ) )
913
914(define dynamic-load-libraries 
915  (make-parameter
916   (map (cut ##sys#string-append <> ##sys#load-library-extension) ##sys#default-dynamic-load-libraries)
917   (lambda (x)
918     (##sys#check-list x)
919     x) ) )
920
921(define ##sys#load-library
922  (let ([load-verbose load-verbose]
923        [string-append string-append]
924        [dynamic-load-libraries dynamic-load-libraries]
925        [display display] )
926    (lambda (uname lib)
927      (let ([id (##sys#->feature-id uname)])
928        (or (memq id ##sys#features)
929            (let ([libs
930                   (if lib
931                       (##sys#list lib)
932                       (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
933                             (dynamic-load-libraries) ) ) ]
934                  [top 
935                   (##sys#make-c-string
936                    (string-append
937                     "C_"
938                     (##sys#string->c-identifier (##sys#slot uname 1)) 
939                     "_toplevel") ) ] )
940              (when (load-verbose)
941                (display "; loading library ")
942                (display uname)
943                (display " ...\n") )
944              (let loop ([libs libs])
945                (cond [(null? libs) #f]
946                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
947                       (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
948                       #t]
949                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
950
951(define load-library
952  (lambda (uname . lib)
953    (##sys#check-symbol uname 'load-library)
954    (or (##sys#load-library uname (and (pair? lib) (car lib)))
955        (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
956
957(define ##sys#split-at-separator
958  (let ([reverse reverse] )
959    (lambda (str sep)
960      (let ([len (##sys#size str)])
961        (let loop ([items '()] [i 0] [j 0])
962          (cond [(fx>= i len)
963                 (reverse (cons (##sys#substring str j len) items)) ]
964                [(char=? (##core#inline "C_subchar" str i) sep)
965                 (let ([i2 (fx+ i 1)])
966                   (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
967                [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
968
969
970;;; Extensions:
971
972(define ##sys#canonicalize-extension-path
973  (let ([string-append string-append])
974    (lambda (id loc)
975      (define (err) (##sys#error loc "invalid extension path" id))
976      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
977      (let ([p (cond [(string? id) id]
978                     [(symbol? id) (##sys#symbol->string id)]
979                     [(list? id) 
980                      (let loop ([id id])
981                        (if (null? id)
982                            ""
983                            (string-append
984                             (let ([id0 (##sys#slot id 0)])
985                               (cond [(symbol? id0) (##sys#symbol->string id0)]
986                                     [(string? id0) id0]
987                                     [else (err)] ) )
988                             (if (null? (##sys#slot id 1))
989                                 ""
990                                 "/")
991                             (loop (##sys#slot id 1)) ) ) ) ] ) ] )
992        (let check ([p p])
993          (let ([n (##sys#size p)])
994            (cond [(fx= 0 n) (err)]
995                  [(sep? (string-ref p 0))
996                   (check (##sys#substring p 1 n)) ]
997                  [(sep? (string-ref p (fx- n 1)))
998                   (check (##sys#substring p 0 (fx- n 1))) ]
999                  [else p] ) ) ) ) ) ) )
1000
1001(define ##sys#repository-path
1002  (make-parameter 
1003   (or (getenv repository-environment-variable)
1004       (##sys#chicken-prefix 
1005        (##sys#string-append 
1006         "lib/chicken/"
1007         (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
1008       install-egg-home) ) )
1009
1010(define repository-path ##sys#repository-path)
1011
1012(define ##sys#find-extension
1013  (let ([file-exists? file-exists?]
1014        [string-append string-append] )
1015    (lambda (p inc?)
1016        (define (check path)
1017          (let ([p0 (string-append path "/" p)])
1018            (and (or (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension))
1019                     (file-exists? (##sys#string-append p0 source-file-extension)) )
1020                 p0) ) )
1021        (let loop ([paths (##sys#append (list (##sys#repository-path))
1022                                        (if inc? (##sys#append ##sys#include-pathnames '(".")) '()) ) ] )
1023          (and (pair? paths)
1024               (let ([pa (##sys#slot paths 0)])
1025                 (or (check pa)
1026                     (loop (##sys#slot paths 1)) ) ) ) ) ) ) )
1027
1028(define ##sys#loaded-extensions '())
1029
1030(define ##sys#load-extension
1031  (let ((string->symbol string->symbol))
1032    (lambda (id loc . err?)
1033      (cond ((string? id) (set! id (string->symbol id)))
1034            (else (##sys#check-symbol id loc)) )
1035      (let ([p (##sys#canonicalize-extension-path id loc)])
1036        (cond ((member p ##sys#loaded-extensions))
1037              ((memq id ##sys#core-library-modules)
1038               (##sys#load-library id #f) )
1039              (else
1040               (let ([id2 (##sys#find-extension p #t)])
1041                 (cond (id2
1042                        (##sys#load id2 #f #f)
1043                        (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
1044                        #t)
1045                       ((:optional err? #t) (##sys#error loc "can not load extension" id))
1046                       (else #f) ) ) ) ) ) ) ) )
1047
1048(define (##sys#provide . ids)
1049  (for-each
1050   (lambda (id)
1051     (##sys#check-symbol id 'provide)
1052     (let ([p (##sys#canonicalize-extension-path id 'provide)])
1053       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
1054   ids) )
1055
1056(define provide ##sys#provide)
1057
1058(define (##sys#provided? id)
1059  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
1060       #t) )
1061
1062(define provided? ##sys#provided?)
1063
1064(define ##sys#require
1065  (lambda ids
1066    (for-each
1067     (cut ##sys#load-extension <> 'require) 
1068     ids) ) )
1069
1070(define require ##sys#require)
1071
1072(define ##sys#extension-information
1073  (let ([with-input-from-file with-input-from-file]
1074        [file-exists? file-exists?]
1075        [string-append string-append]
1076        [read read] )
1077    (lambda (id loc)
1078      (let* ((p (##sys#canonicalize-extension-path id loc))
1079             (rpath (string-append (##sys#repository-path) "/" p ".")) )
1080        (cond ((file-exists? (string-append rpath setup-file-extension))
1081               => (cut with-input-from-file <> read) )
1082              (else #f) ) ) ) ) )
1083
1084(define (extension-information ext)
1085  (##sys#extension-information ext 'extension-information) )
1086
1087(define ##sys#lookup-runtime-requirements 
1088  (let ([with-input-from-file with-input-from-file]
1089        [read read] )
1090    (lambda (ids)
1091      (let loop1 ([ids ids])
1092        (if (null? ids)
1093            '()
1094            (append
1095             (or (and-let* ([info (##sys#extension-information (car ids) #f)]
1096                            [a (assq 'require-at-runtime info)] )
1097                   (cdr a) )
1098                 '() )
1099             (loop1 (cdr ids)) ) ) ) ) ) )
1100
1101(define ##sys#do-the-right-thing
1102  (let ((vector->list vector->list))
1103    (lambda (id comp?)
1104      (define (add-req id)
1105        (when comp?
1106          (hash-table-update!           ; assumes compiler has extras available - will break in the interpreter
1107           ##compiler#file-requirements
1108           'syntax-requirements
1109           (cut lset-adjoin eq? <> id) 
1110           (lambda () (list id)))))
1111      (define (doit id)
1112        (cond ((or (memq id builtin-features)
1113                   (if comp?
1114                       (memq id builtin-features/compiled)
1115                       (##sys#feature? id) ) )
1116               (values '(##sys#void) #t) )
1117              ((memq id special-syntax-files)
1118               (let ((fid (##sys#->feature-id id)))
1119                 (unless (memq fid ##sys#features)
1120                   (##sys#load (##sys#resolve-include-filename (##sys#symbol->string id) #t) #f #f) 
1121                   (set! ##sys#features (cons fid ##sys#features)) )
1122                 (values '(##sys#void) #t) ) )
1123              ((memq id ##sys#core-library-modules)
1124               (values
1125                (if comp?
1126                    `(##core#declare (uses ,id))
1127                    `(load-library ',id) )
1128                #t) )
1129              ((memq id ##sys#explicit-library-modules)
1130               (let* ((info (##sys#extension-information id 'require-extension))
1131                      (s (assq 'syntax info)))
1132                 (values
1133                  `(begin
1134                     ,@(if s `((##core#require-for-syntax ',id)) '())
1135                     ,(if comp?
1136                          `(##core#declare (uses ,id)) 
1137                          `(load-library ',id) ) )
1138                  #t) ) )
1139              (else
1140               (let ((info (##sys#extension-information id 'require-extension)))
1141                 (cond (info
1142                        (let ((s (assq 'syntax info))
1143                              (rr (assq 'require-at-runtime info)) )
1144                          (when s (add-req id))
1145                          (values
1146                           `(begin
1147                              ,@(if s `((##core#require-for-syntax ',id)) '())
1148                              ,@(if (and (not rr) s)
1149                                   '()
1150                                   `((##sys#require
1151                                      ,@(map (lambda (id) `',id)
1152                                             (cond (rr (cdr rr))
1153                                                   (else (list id)) ) ) ) ) ) )
1154                           #t) ) )
1155                       (else
1156                        (add-req id)
1157                        (values `(##sys#require ',id) #f)) ) ) ) ) )
1158      (if (and (pair? id) (symbol? (car id)))
1159          (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
1160            (if a
1161                (let ((a ((##sys#slot a 1) id)))
1162                  (cond ((string? a) (values `(load ,a) #f))
1163                        ((vector? a) 
1164                         (let loop ((specs (vector->list a))
1165                                    (exps '())
1166                                    (f #f) )
1167                           (if (null? specs)
1168                               (values `(begin ,@(reverse exps)) f)
1169                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp?)))
1170                                 (loop (cdr specs)
1171                                       (cons exp exps)
1172                                       (or fi f) ) ) ) ) )
1173                        (else (##sys#do-the-right-thing a comp?)) ) )
1174                (##sys#error "undefined extension specifier" id) ) )
1175          (if (symbol? id)
1176              (doit id) 
1177              (##sys#error "invalid extension specifier" id) ) ) ) ) )
1178
1179(define ##sys#extension-specifiers '())
1180
1181(define (set-extension-specifier! name proc)
1182  (##sys#check-symbol name 'set-extension-specifier!)
1183  (let ([a (assq name ##sys#extension-specifiers)])
1184    (if a
1185        (let ([old (##sys#slot a 1)])
1186          (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
1187        (set! ##sys#extension-specifiers
1188          (cons (cons name (lambda (spec) (proc spec #f)))
1189                ##sys#extension-specifiers)) ) ) )
1190
1191
1192;;; SRFI-55
1193
1194(set-extension-specifier!
1195 'srfi 
1196 (let ([list->vector list->vector])
1197   (lambda (spec old)
1198     (list->vector
1199      (let loop ([ids (cdr spec)])
1200        (if (null? ids)
1201            '()
1202            (let ([id (car ids)])
1203              (##sys#check-exact id 'require-extension)
1204              (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
1205                    (loop (cdr ids)) ) ) ) ) ) ) ) )
1206
1207
1208;;; Version checking
1209
1210(set-extension-specifier!
1211 'version
1212 (lambda (spec _)
1213   (define (->string x)
1214     (cond ((string? x) x)
1215           ((symbol? x) (##sys#slot x 1))
1216           ((number? x) (##sys#number->string x))
1217           (else (error "invalid extension version" x)) ) )
1218   (if (and (list spec) (fx= 3 (length spec)))
1219       (let* ((info (extension-information (cadr spec)))
1220              (vv (and info (assq 'version info))) )
1221         (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
1222           (error "installed extension does not match required version" id vv (caddr spec)))
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.