source: project/chicken/trunk/eval.scm @ 12101

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

declaration processing did not handle expanded names

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