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

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

low-level module attempt; converted some more macros

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