source: project/chicken/branches/lazy-gensyms/eval.scm @ 12629

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

support for lazy gensyms; some refactoring in get/put\!

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