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

Last change on this file since 15438 was 15438, checked in by felix winkelmann, 11 years ago

reactivated SONAME, possibly messed everything up

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