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

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

two more newlines

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