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

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

added er-macro-transformer

File size: 60.9 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    (lambda (#!optional dir)
138      (and prefix
139           (if dir (##sys#string-append prefix dir) prefix) ) ) ) )
140         
141
142;;; System settings
143
144(define (chicken-home)
145  (or (##sys#chicken-prefix "share/chicken")
146      installation-home) )
147
148
149;;; Lo-level hashtable support:
150
151(define ##sys#hash-symbol
152  (let ([cache-s #f]
153        [cache-h #f] )
154    (lambda (s n)
155      (if (eq? s cache-s)
156          (##core#inline "C_fixnum_modulo" cache-h n)
157          (begin
158            (set! cache-s s)
159            (set! cache-h (##core#inline "C_hash_string" (##sys#slot s 1)))
160            (##core#inline "C_fixnum_modulo" cache-h n))))))
161
162(define (##sys#hash-table-ref ht key)
163  (let loop ((bucket (##sys#slot ht (##sys#hash-symbol key (##core#inline "C_block_size" ht)))))
164      (and (not (eq? '() bucket))
165           (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
166               (##sys#slot (##sys#slot bucket 0) 1)
167               (loop (##sys#slot bucket 1))))))
168
169(define (##sys#hash-table-set! ht key val)
170  (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
171         (ib (##sys#slot ht k)))
172      (let loop ((bucket ib))
173          (if (eq? '() bucket)
174              (##sys#setslot ht k (cons (cons key val) ib))
175              (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
176                  (##sys#setslot (##sys#slot bucket 0) 1 val)
177                  (loop (##sys#slot bucket 1)))))))
178
179(define (##sys#hash-table-update! ht key updtfunc valufunc)
180  (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) )
181
182(define (##sys#hash-table-for-each p ht)
183  (let ((len (##core#inline "C_block_size" ht)))
184    (do ((i 0 (fx+ i 1)))
185        ((fx>= i len))
186      (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1)))
187                      (##sys#slot ht i) ) ) ) )
188
189(define ##sys#hash-table-location
190  (let ([unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)])
191    (lambda (ht key addp)
192      (let* ([k (##sys#hash-symbol key (##sys#size ht))]
193             [bucket0 (##sys#slot ht k)] )
194        (let loop ([bucket bucket0])
195          (if (null? bucket)
196              (and addp
197                   (let ([p (vector key unbound #t)])
198                     (##sys#setslot ht k (cons p bucket0))
199                     p) )
200              (let ([b (##sys#slot bucket 0)])
201                (if (eq? key (##sys#slot b 0))
202                    b
203                    (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )
204
205
206;;; Compile lambda to closure:
207
208(define ##sys#eval-environment #f)
209(define ##sys#environment-is-mutable #f)
210
211(define (##sys#eval-decorator p ll h cntr)
212  (##sys#decorate-lambda
213   p 
214   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
215   (lambda (p i)
216     (##sys#setslot 
217      p i 
218      (##sys#make-lambda-info 
219       (let ((o (open-output-string)))
220         (write ll o)
221         (get-output-string o))))
222     p) ) )
223
224(define ##sys#unbound-in-eval #f)
225(define ##sys#eval-debug-level 1)
226
227(define ##sys#compile-to-closure
228  (let ([write write]
229        [reverse reverse]
230        [open-output-string open-output-string]
231        [get-output-string get-output-string] 
232        [with-input-from-file with-input-from-file]
233        [unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
234        [display display] )
235    (lambda (exp env se #!optional cntr)
236
237      (define (find-id id se)           ; ignores macro bindings
238        (cond ((null? se) #f)
239              ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
240              (else (find-id id (cdr se)))))
241
242      (define (rename var se)
243        (cond ((find-id var se))
244              ((##sys#get var '##core#macro-alias))
245              (else var)))
246
247      (define (lookup var0 e se)
248        (let ((var (rename var0 se)))
249          (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map car se)))
250          (let loop ((envs e) (ei 0))
251            (cond ((null? envs) (values #f var))
252                  ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
253                  (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
254
255      (define (posq x lst)
256        (let loop ((lst lst) (i 0))
257          (cond ((null? lst) #f)
258                ((eq? x (##sys#slot lst 0)) i)
259                (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
260
261      (define (emit-trace-info tf info cntr) 
262        (when tf
263          (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )
264
265      (define (emit-syntax-trace-info tf info cntr) 
266        (when tf
267          (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
268       
269      (define (decorate p ll h cntr)
270        (##sys#eval-decorator p ll h cntr) )
271
272      (define (eval/meta form)
273        (parameterize ((##sys#current-module #f)
274                       (##sys#macro-environment (##sys#meta-macro-environment)))
275            ((##sys#compile-to-closure
276              form
277              '() 
278              (##sys#current-meta-environment))
279             '() ) ))
280
281      (define (eval/elab form)
282        ((##sys#compile-to-closure
283          form
284          '() 
285          (##sys#current-environment))
286         '() ) )
287
288      (define (compile x e h tf cntr se)
289        (cond ((keyword? x) (lambda v x))
290              ((symbol? x)
291               (receive (i j) (lookup x e se)
292                 (cond [(not i)
293                        (let ((var (if (not (assq x se)) ; global?
294                                       (##sys#alias-global-hook j #f)
295                                       (or (##sys#get j '##core#primitive) j))))
296                          (if ##sys#eval-environment
297                              (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
298                                (unless loc (##sys#syntax-error-hook "reference to undefined identifier" var))
299                                (cond-expand 
300                                 [unsafe (lambda v (##sys#slot loc 1))]
301                                 [else
302                                  (lambda v 
303                                    (let ([val (##sys#slot loc 1)])
304                                      (if (eq? unbound val)
305                                          (##sys#error "unbound variable" var)
306                                          val) ) ) ] ) )
307                              (cond-expand
308                               [unsafe (lambda v (##core#inline "C_slot" var 0))]
309                               [else
310                                (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? var)))
311                                  (set! ##sys#unbound-in-eval (cons (cons var cntr) ##sys#unbound-in-eval)) )
312                                (lambda v (##core#inline "C_retrieve" var))] ) ) ) ]
313                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
314                       [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) )
315              [(##sys#number? x)
316               (case x
317                 [(-1) (lambda v -1)]
318                 [(0) (lambda v 0)]
319                 [(1) (lambda v 1)]
320                 [(2) (lambda v 2)]
321                 [else (lambda v x)] ) ]
322              [(boolean? x)
323               (if x
324                   (lambda v #t)
325                   (lambda v #f) ) ]
326              [(or (char? x)
327                   (eof-object? x)
328                   (string? x) )
329               (lambda v x) ]
330              [(not (pair? x)) (##sys#syntax-error-hook "illegal non-atomic object" x)]
331              [(symbol? (##sys#slot x 0))
332               (emit-syntax-trace-info tf x cntr)
333               (let ((x2 (##sys#expand x se)))
334                 (d `(EVAL/EXPANDED: ,x2))
335                 (if (not (eq? x2 x))
336                     (compile x2 e h tf cntr se)
337                     (let ((head (rename (##sys#slot x 0) se))) 
338                       ;; here we did't resolve ##core#primitive, but that is done in compile-call (via
339                       ;; a normal walking of the operator)
340                       (case head
341
342                         [(quote)
343                          (##sys#check-syntax 'quote x '(quote _) #f se)
344                          (let* ((c (##sys#strip-syntax (cadr x))))
345                            (case c
346                              [(-1) (lambda v -1)]
347                              [(0) (lambda v 0)]
348                              [(1) (lambda v 1)]
349                              [(2) (lambda v 2)]
350                              [(#t) (lambda v #t)]
351                              [(#f) (lambda v #f)]
352                              [(()) (lambda v '())]
353                              [else (lambda v c)] ) ) ]
354
355                         ((syntax)
356                          (let ((c (cadr x)))
357                            (lambda v c)))
358
359                         [(##core#global-ref)
360                          (let ([var (cadr x)])
361                            (if ##sys#eval-environment
362                                (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
363                                  (lambda v (##sys#slot loc 1)) )
364                                (lambda v (##core#inline "C_slot" var 0)) ) ) ]
365
366                         [(##core#check)
367                          (compile (cadr x) e h tf cntr se) ]
368
369                         [(##core#immutable)
370                          (compile (cadr x) e #f tf cntr se) ]
371                   
372                         [(##core#undefined) (lambda (v) (##core#undefined))]
373
374                         [(if)
375                          (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
376                          (let* ([test (compile (cadr x) e #f tf cntr se)]
377                                 [cns (compile (caddr x) e #f tf cntr se)]
378                                 [alt (if (pair? (cdddr x))
379                                          (compile (cadddr x) e #f tf cntr se)
380                                          (compile '(##core#undefined) e #f tf cntr se) ) ] )
381                            (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
382
383                         [(begin)
384                          (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
385                          (let* ([body (##sys#slot x 1)]
386                                 [len (length body)] )
387                            (case len
388                              [(0) (compile '(##core#undefined) e #f tf cntr se)]
389                              [(1) (compile (##sys#slot body 0) e #f tf cntr se)]
390                              [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
391                                          [x2 (compile (cadr body) e #f tf cntr se)] )
392                                     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
393                              [else
394                               (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
395                                      [x2 (compile (cadr body) e #f tf cntr se)] 
396                                      [x3 (compile `(,(rename 'begin se) ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
397                                 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
398
399                         [(set! ##core#set!)
400                          (##sys#check-syntax 'set! x '(_ variable _) #f se)
401                          (let ((var (cadr x)))
402                            (receive (i j) (lookup var e se)
403                              (let ((val (compile (caddr x) e var tf cntr se)))
404                                (cond [(not i)
405                                       (let ((var (##sys#alias-global-hook j #t)))
406                                         (if ##sys#eval-environment
407                                             (let ([loc (##sys#hash-table-location
408                                                         ##sys#eval-environment 
409                                                         var
410                                                         ##sys#environment-is-mutable) ] )
411                                               (unless loc (##sys#error "assignment of undefined identifier" var))
412                                               (if (##sys#slot loc 2)
413                                                   (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
414                                                   (lambda v (##sys#error "assignment to immutable variable" var)) ) )
415                                             (lambda (v)
416                                               (##sys#setslot var 0 (##core#app val v))) ) ) ]
417                                      [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
418                                      [else
419                                       (lambda (v)
420                                         (##sys#setslot
421                                          (##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
422
423                         [(let ##core#let)
424                          (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
425                          (let* ([bindings (cadr x)]
426                                 [n (length bindings)] 
427                                 [vars (map (lambda (x) (car x)) bindings)] 
428                                 (aliases (map gensym vars))
429                                 [e2 (cons aliases e)]
430                                 (se2 (append (map cons vars aliases) se))
431                                 [body (##sys#compile-to-closure
432                                        (##sys#canonicalize-body (cddr x) se2)
433                                        e2
434                                        se2
435                                        cntr) ] )
436                            (case n
437                              [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
438                                     (lambda (v)
439                                       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
440                              [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
441                                         [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] )
442                                     (lambda (v)
443                                       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
444                              [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
445                                          [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
446                                          [t (cddr bindings)]
447                                          [val3 (compile (cadar t) e (caddr vars) tf cntr se)] )
448                                     (lambda (v)
449                                       (##core#app 
450                                        body
451                                        (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
452                              [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
453                                          [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
454                                          [t (cddr bindings)]
455                                          [val3 (compile (cadar t) e (caddr vars) tf cntr se)] 
456                                          [val4 (compile (cadadr t) e (cadddr vars) tf cntr se)] )
457                                     (lambda (v)
458                                       (##core#app 
459                                        body
460                                        (cons (vector (##core#app val1 v)
461                                                      (##core#app val2 v)
462                                                      (##core#app val3 v)
463                                                      (##core#app val4 v))
464                                              v)) ) ) ]
465                              [else
466                               (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])
467                                 (lambda (v)
468                                   (let ([v2 (##sys#make-vector n)])
469                                     (do ([i 0 (fx+ i 1)]
470                                          [vlist vals (##sys#slot vlist 1)] )
471                                         ((fx>= i n))
472                                       (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
473                                     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
474
475                         ((letrec ##core#letrec)
476                          (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
477                          (let ((bindings (cadr x))
478                                (body (cddr x)) )
479                            (compile
480                             `(##core#let
481                               ,(##sys#map (lambda (b)
482                                             (list (car b) '(##core#undefined))) 
483                                           bindings)
484                               ,@(##sys#map (lambda (b)
485                                              `(##core#set! ,(car b) ,(cadr b))) 
486                                            bindings)
487                               (##core#let () ,@body) )
488                             e h tf cntr se)))
489
490                         [(lambda ##core#lambda)
491                          (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
492                          (let* ([llist (cadr x)]
493                                 [body (cddr x)] 
494                                 [info (cons (or h '?) llist)] )
495                            (when (##sys#extended-lambda-list? llist)
496                              (set!-values 
497                               (llist body) 
498                               (##sys#expand-extended-lambda-list 
499                                llist body ##sys#syntax-error-hook se) ) ) 
500                            (##sys#decompose-lambda-list
501                             llist
502                             (lambda (vars argc rest)
503                               (let* ((aliases (map gensym vars))
504                                      (se2 (append (map cons vars aliases) se))
505                                      (e2 (cons aliases e))
506                                      (body 
507                                       (##sys#compile-to-closure
508                                        (##sys#canonicalize-body body se2)
509                                        e2
510                                        se2
511                                        (or h cntr) ) ) )
512                                 (case argc
513                                   [(0) (if rest
514                                            (lambda (v)
515                                              (decorate
516                                               (lambda r
517                                                 (##core#app body (cons (vector r) v)))
518                                               info h cntr) )
519                                            (lambda (v)
520                                              (decorate
521                                               (lambda () (##core#app body (cons #f v)))
522                                               info h cntr) ) ) ]
523                                   [(1) (if rest
524                                            (lambda (v)
525                                              (decorate
526                                               (lambda (a1 . r)
527                                                 (##core#app body (cons (vector a1 r) v)))
528                                               info h cntr) ) 
529                                            (lambda (v)
530                                              (decorate 
531                                               (lambda (a1)
532                                                 (##core#app body (cons (vector a1) v)))
533                                               info h cntr) ) ) ]
534                                   [(2) (if rest
535                                            (lambda (v) 
536                                              (decorate
537                                               (lambda (a1 a2 . r)
538                                                 (##core#app body (cons (vector a1 a2 r) v)))
539                                               info h cntr) )
540                                            (lambda (v)
541                                              (decorate
542                                               (lambda (a1 a2)
543                                                 (##core#app body (cons (vector a1 a2) v)))
544                                               info h cntr) ) ) ]
545                                   [(3) (if rest
546                                            (lambda (v) 
547                                              (decorate
548                                               (lambda (a1 a2 a3 . r)
549                                                 (##core#app body (cons (vector a1 a2 a3 r) v)))
550                                               info h cntr) )
551                                            (lambda (v)
552                                              (decorate
553                                               (lambda (a1 a2 a3)
554                                                 (##core#app body (cons (vector a1 a2 a3) v)))
555                                               info h cntr) ) ) ]
556                                   [(4) (if rest
557                                            (lambda (v)
558                                              (decorate
559                                               (lambda (a1 a2 a3 a4 . r)
560                                                 (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
561                                               info h cntr) )
562                                            (lambda (v)
563                                              (decorate
564                                               (lambda (a1 a2 a3 a4)
565                                                 (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
566                                               info h cntr) ) ) ]
567                                   [else
568                                    (if rest
569                                        (lambda (v)
570                                          (decorate
571                                           (lambda as
572                                             (##core#app
573                                              body
574                                              (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
575                                           info h cntr) )
576                                        (lambda (v)
577                                          (decorate
578                                           (lambda as 
579                                             (let ([len (length as)])
580                                               (if (not (fx= len argc))
581                                                   (##sys#error "bad argument count" argc len)
582                                                   (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
583                                           info h cntr) ) ) ] ) ) ) ) ) ]
584
585                         ((let-syntax)
586                          (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
587                          (let ((se2 (append
588                                      (map (lambda (b)
589                                             (list
590                                              (car b)
591                                              se
592                                              (##sys#er-transformer
593                                               (eval/meta (cadr b)))))
594                                           (cadr x) ) 
595                                      se) ) )
596                            (compile
597                             (##sys#canonicalize-body (cddr x) se2)
598                             e #f tf cntr se2)))
599                               
600                         ((letrec-syntax)
601                          (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
602                          (let* ((ms (map (lambda (b)
603                                            (list
604                                             (car b)
605                                             #f
606                                             (##sys#er-transformer
607                                              (eval/meta (cadr b)))))
608                                          (cadr x) ) )
609                                 (se2 (append ms se)) )
610                            (for-each
611                             (lambda (sb)
612                               (set-car! (cdr sb) se2) )
613                             ms) 
614                            (compile
615                             (##sys#canonicalize-body (cddr x) se2)
616                             e #f tf cntr se2)))
617                               
618                         ((define-syntax define-compiled-syntax)
619                          (##sys#check-syntax
620                           'define-syntax x
621                           (if (and (pair? (cdr x)) (pair? (cadr x)))
622                               '(_ (variable . lambda-list) . #(_ 1))
623                               '(_ variable _))
624                           #f se)
625                          (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
626                                 (body (if (pair? (cadr x))
627                                           `(,(rename 'er-macro-transformer se)
628                                             (,(rename 'lambda se) ,(cdadr x) ,@(cddr x)))
629                                           (caddr x)))
630                                 (name (rename var se)))
631                            (##sys#register-syntax-export 
632                             name (##sys#current-module)
633                             body)      ;*** not really necessary, it only shouldn't be #f
634                            (##sys#extend-macro-environment
635                             name
636                             (##sys#current-environment)
637                             (##sys#er-transformer (eval/meta body)))
638                            (compile '(##core#undefined) e #f tf cntr se) ) )
639
640                         ((##core#module)
641                          (let* ((name (rename (cadr x) se))
642                                 (exports 
643                                  (or (eq? #t (caddr x))
644                                      (map (lambda (exp)
645                                             (cond ((symbol? exp) exp)
646                                                   ((and (pair? exp) 
647                                                         (let loop ((exp exp))
648                                                           (or (null? exp)
649                                                               (and (symbol? (car exp))
650                                                                    (loop (cdr exp))))))
651                                                    exp)
652                                                   (else
653                                                    (##sys#syntax-error-hook
654                                                     'module
655                                                     "invalid export syntax" exp name))))
656                                           (##sys#strip-syntax (caddr x))))))
657                            (when (##sys#current-module)
658                              (##sys#syntax-error-hook 'module "modules may not be nested" name))
659                            (parameterize ((##sys#current-module 
660                                            (##sys#register-module name exports))
661                                           (##sys#current-environment '())
662                                           (##sys#macro-environment ##sys#initial-macro-environment))
663                                (let loop ((body (cdddr x)) (xs '()))
664                                  (if (null? body)
665                                      (let ((xs (reverse xs)))
666                                        (##sys#finalize-module (##sys#current-module))
667                                        (lambda (v)
668                                          (let loop2 ((xs xs))
669                                            (if (null? xs)
670                                                (##sys#void)
671                                                (let ((n (##sys#slot xs 1)))
672                                                  (cond ((pair? n)
673                                                         ((##sys#slot xs 0) v)
674                                                         (loop2 n))
675                                                        (else
676                                                         ((##sys#slot xs 0) v))))))))
677                                      (loop 
678                                       (cdr body)
679                                       (cons (compile 
680                                              (car body) 
681                                              '() #f tf cntr 
682                                              (##sys#current-environment))
683                                             xs))))) ) )
684
685                         [(##core#loop-lambda)
686                          (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
687
688                         [(##core#named-lambda)
689                          (compile `(,(rename 'lambda se) ,@(cddr x)) e (cadr x) tf cntr se) ]
690
691                         [(##core#require-for-syntax)
692                          (let ([ids (map (lambda (x)
693                                            (eval/meta x))
694                                          (cdr x))])
695                            (apply ##sys#require ids)
696                            (let ([rs (##sys#lookup-runtime-requirements ids)])
697                              (compile
698                               (if (null? rs)
699                                   '(##core#undefined)
700                                   `(##sys#require ,@(map (lambda (x) `',x) rs)) )
701                               e #f tf cntr se) ) ) ]
702
703                         [(##core#require-extension)
704                          (let ((imp? (caddr x)))
705                            (compile
706                             (let loop ([ids (cadr x)])
707                               (if (null? ids)
708                                   '(##core#undefined)
709                                   (let-values ([(exp _)
710                                                 (##sys#do-the-right-thing (car ids) #f imp?)])
711                                     `(,(rename 'begin se) ,exp ,(loop (cdr ids))) ) ) )
712                             e #f tf cntr se) ) ]
713
714                         [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
715                          (eval/meta (cadr x))
716                          (compile '(##core#undefined) e #f tf cntr se) ]
717
718                         [(##core#compiletimetoo)
719                          (compile (cadr x) e #f tf cntr se) ]
720
721                         [(##core#compiletimeonly ##core#callunit) 
722                          (compile '(##core#undefined) e #f tf cntr se) ]
723
724                         [(##core#declare)
725                          (if (memq #:compiling ##sys#features)
726                              (for-each (lambda (d) (##compiler#process-declaration d se)) (cdr x)) 
727                              (##sys#warn "declarations are ignored in interpreted code" x) )
728                          (compile '(##core#undefined) e #f tf cntr se) ]
729
730                         [(define-inline define-constant)
731                          (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
732                   
733                         [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
734                                            ##core#define-foreign-variable 
735                                            ##core#define-external-variable ##core#let-location
736                                            ##core#foreign-primitive
737                                            ##core#foreign-lambda* ##core#define-foreign-type)
738                          (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
739
740                         [(##core#app)
741                          (compile-call (cdr x) e tf cntr se) ]
742
743                         [else
744                          (cond [(eq? head 'location)
745                                 (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
746
747                                [else (compile-call x e tf cntr se)] ) ] ) ) ) ) ]
748             
749              [else
750               (emit-syntax-trace-info tf x cntr)
751               (compile-call x e tf cntr se)] ) )
752
753      (define (fudge-argument-list n alst)
754        (if (null? alst) 
755            (list alst)
756            (do ((n n (fx- n 1))
757                 (c 0 (fx+ c 1))
758                 (args alst 
759                       (if (eq? '() args)
760                           (##sys#error "bad argument count" n c)
761                           (##sys#slot args 1)))
762                 (last #f args) )
763                ((fx= n 0)
764                 (##sys#setslot last 1 (list args))
765                 alst) ) ) )
766
767      (define (checked-length lst)
768        (let loop ([lst lst] [n 0])
769          (cond [(null? lst) n]
770                [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
771                [else #f] ) ) )
772
773      (define (compile-call x e tf cntr se)
774        (let* ([fn (compile (##sys#slot x 0) e #f tf cntr se)]
775               [args (##sys#slot x 1)]
776               [argc (checked-length args)]
777               [info x] )
778          (case argc
779            [(#f) (##sys#syntax-error-hook "malformed expression" x)]
780            [(0) (lambda (v)
781                   (emit-trace-info tf info cntr)
782                   ((fn v)))]
783            [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
784                   (lambda (v)
785                     (emit-trace-info tf info cntr)
786                     ((##core#app fn v) (##core#app a1 v))) ) ]
787            [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
788                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
789                   (lambda (v)
790                     (emit-trace-info tf info cntr)
791                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
792            [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
793                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
794                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) 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) (##core#app a3 v))) ) ]
798            [(4) (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                        [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
802                   (lambda (v)
803                     (emit-trace-info tf info cntr)
804                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
805            [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
806                    (lambda (v)
807                      (emit-trace-info tf info cntr)
808                      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
809
810      (compile exp env #f (fx> ##sys#eval-debug-level 0) cntr se) ) ) )
811
812(define ##sys#eval-handler 
813  (make-parameter
814   (lambda (x . env)
815     (let ([mut ##sys#environment-is-mutable]
816           [e #f] )
817       (when (pair? env)
818         (let ([env (car env)])
819           (when env
820             (##sys#check-structure env 'environment)
821             (set! e (##sys#slot env 1)) 
822             (set! mut (##sys#slot env 2)) ) ) )
823       ((fluid-let ([##sys#environment-is-mutable mut]
824                    [##sys#eval-environment e] )
825          (##sys#compile-to-closure x '() (##sys#current-environment)) )
826        '() ) ) ) ) )
827
828(define eval-handler ##sys#eval-handler)
829
830(define (eval x . env)
831  (apply (##sys#eval-handler) 
832         x
833         env) )
834
835;;; Split lambda-list into its parts:
836
837(define ##sys#decompose-lambda-list
838  (let ([reverse reverse])
839    (lambda (llist0 k)
840
841      (define (err)
842        (set! ##sys#syntax-error-culprit #f)
843        (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
844
845      (let loop ([llist llist0] [vars '()] [argc 0])
846        (cond [(eq? llist '()) (k (reverse vars) argc #f)]
847              [(not (##core#inline "C_blockp" llist)) (err)]
848              [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
849              [(not (##core#inline "C_pairp" llist)) (err)]
850              [else (loop (##sys#slot llist 1)
851                          (cons (##sys#slot llist 0) vars)
852                          (fx+ argc 1) ) ] ) ) ) ) )
853
854
855;;; Loading source/object files:
856
857(define load-verbose (make-parameter (##sys#fudge 13)))
858
859(define (##sys#abort-load) #f)
860(define ##sys#current-source-filename #f)
861(define ##sys#current-load-path "")
862(define ##sys#dload-disabled #f)
863
864(define-foreign-variable _dlerror c-string "C_dlerror")
865
866(define (set-dynamic-load-mode! mode)
867  (let ([mode (if (pair? mode) mode (list mode))]
868        [now #f]
869        [global #t] )
870    (let loop ([mode mode])
871      (when (pair? mode)
872        (case (##sys#slot mode 0)
873          [(global) (set! global #t)]
874          [(local) (set! global #f)]
875          [(lazy) (set! now #f)]
876          [(now) (set! now #t)]
877          [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
878        (loop (##sys#slot mode 1)) ) )
879    (##sys#set-dlopen-flags! now global) ) )
880
881(let ([read read]
882      [write write]
883      [display display]
884      [newline newline]
885      [eval eval]
886      [open-input-file open-input-file]
887      [close-input-port close-input-port]
888      [string-append string-append] 
889      [load-verbose load-verbose]
890      [topentry (##sys#make-c-string "C_toplevel")] )
891  (define (has-sep? str)
892    (let loop ([i (fx- (##sys#size str) 1)])
893      (and (not (zero? i))
894           (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
895               i
896               (loop (fx- i 1)) ) ) ) )
897  (define (badfile x)
898    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
899  (set! ##sys#load 
900    (lambda (input evaluator pf #!optional timer printer)
901      (when (string? input) 
902        (set! input (##sys#expand-home-path input)) )
903      (let* ([isdir #f]
904             [fname 
905             (cond [(port? input) #f]
906                   [(not (string? input)) (badfile input)]
907                   [(and-let* ([info (##sys#file-info input)]
908                               [id (##sys#slot info 4)] )
909                      (set! isdir (eq? 1 id)) 
910                      (not id) )
911                    input]
912                   [else
913                    (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
914                      (if (and (not ##sys#dload-disabled)
915                               (##sys#fudge 24) ; dload?
916                               (##sys#file-info fname2))
917                          fname2
918                          (let ([fname3 (##sys#string-append input source-file-extension)])
919                            (if (##sys#file-info fname3)
920                                fname3
921                                (and (not isdir) input) ) ) ) ) ] ) ]
922            [evproc (or evaluator eval)] )
923        (cond [(and (string? input) (not fname))
924               (##sys#signal-hook #:file-error 'load "cannot open file" input) ]
925              [(and (load-verbose) fname)
926               (display "; loading ")
927               (display fname)
928               (display " ...\n") ] )
929        (or (and fname
930                 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
931                     (and (not (has-sep? fname))
932                          (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
933            (call-with-current-continuation
934             (lambda (abrt)
935               (fluid-let ([##sys#read-error-with-line-number #t]
936                           [##sys#current-source-filename fname]
937                           [##sys#current-load-path
938                            (and fname
939                                 (let ((i (has-sep? fname)))
940                                   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
941                           [##sys#abort-load (lambda () (abrt #f))] )
942                 (let ([in (if fname (open-input-file fname) input)])
943                   (##sys#dynamic-wind
944                    (lambda () #f)
945                    (lambda ()
946                      (let ([c1 (peek-char in)])
947                        (when (char=? c1 (integer->char 127))
948                          (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
949                      (let ((x1 (read in)))
950                        (do ((x x1 (read in)))
951                            ((eof-object? x))
952                          (when printer (printer x))
953                          (##sys#call-with-values
954                           (lambda () 
955                             (if timer
956                                 (time (evproc x)) 
957                                 (evproc x) ) )
958                           (lambda results
959                             (when pf
960                               (for-each
961                                (lambda (r) 
962                                  (write r)
963                                  (newline) )
964                                results) ) ) ) ) ) )
965                    (lambda () (close-input-port in)) ) ) ) ) ) )
966        (##core#undefined) ) ) )
967  (set! load
968    (lambda (filename . evaluator)
969      (##sys#load filename (optional evaluator #f) #f) ) )
970  (set! load-relative
971    (lambda (filename . evaluator)
972      (##sys#load
973       (if (memq (string-ref filename 0) '(#\\ #\/))
974           filename
975           (##sys#string-append ##sys#current-load-path filename) )
976       (optional evaluator #f) #f) ) )
977  (set! load-noisily
978    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
979      (##sys#load filename evaluator #t time printer) ) ) )
980
981(define ##sys#load-library-extension    ; this is crude...
982  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
983        [(eq? (software-version) 'macosx) macosx-load-library-extension]
984        [(and (eq? (software-version) 'hpux) 
985              (eq? (machine-type) 'hppa)) hppa-load-library-extension]
986        [else default-load-library-extension] ) )
987
988(define ##sys#load-dynamic-extension default-load-library-extension)
989
990(define ##sys#default-dynamic-load-libraries 
991  (case (build-platform)
992    ((cygwin) cygwin-default-dynamic-load-libraries)
993    (else default-dynamic-load-libraries) ) )
994
995(define dynamic-load-libraries 
996  (make-parameter
997   (map (cut ##sys#string-append <> ##sys#load-library-extension) ##sys#default-dynamic-load-libraries)
998   (lambda (x)
999     (##sys#check-list x)
1000     x) ) )
1001
1002(define ##sys#load-library
1003  (let ([load-verbose load-verbose]
1004        [string-append string-append]
1005        [dynamic-load-libraries dynamic-load-libraries]
1006        [display display] )
1007    (lambda (uname lib)
1008      (let ([id (##sys#->feature-id uname)])
1009        (or (memq id ##sys#features)
1010            (let ([libs
1011                   (if lib
1012                       (##sys#list lib)
1013                       (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
1014                             (dynamic-load-libraries) ) ) ]
1015                  [top 
1016                   (##sys#make-c-string
1017                    (string-append
1018                     "C_"
1019                     (##sys#string->c-identifier (##sys#slot uname 1)) 
1020                     "_toplevel") ) ] )
1021              (when (load-verbose)
1022                (display "; loading library ")
1023                (display uname)
1024                (display " ...\n") )
1025              (let loop ([libs libs])
1026                (cond [(null? libs) #f]
1027                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
1028                       (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
1029                       #t]
1030                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
1031
1032(define load-library
1033  (lambda (uname . lib)
1034    (##sys#check-symbol uname 'load-library)
1035    (or (##sys#load-library uname (and (pair? lib) (car lib)))
1036        (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
1037
1038(define ##sys#split-at-separator
1039  (let ([reverse reverse] )
1040    (lambda (str sep)
1041      (let ([len (##sys#size str)])
1042        (let loop ([items '()] [i 0] [j 0])
1043          (cond [(fx>= i len)
1044                 (reverse (cons (##sys#substring str j len) items)) ]
1045                [(char=? (##core#inline "C_subchar" str i) sep)
1046                 (let ([i2 (fx+ i 1)])
1047                   (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
1048                [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
1049
1050
1051;;; Extensions:
1052
1053(define ##sys#canonicalize-extension-path
1054  (let ([string-append string-append])
1055    (lambda (id loc)
1056      (define (err) (##sys#error loc "invalid extension path" id))
1057      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
1058      (let ([p (cond [(string? id) id]
1059                     [(symbol? id) (##sys#symbol->string id)]
1060                     [(list? id) 
1061                      (let loop ([id id])
1062                        (if (null? id)
1063                            ""
1064                            (string-append
1065                             (let ([id0 (##sys#slot id 0)])
1066                               (cond [(symbol? id0) (##sys#symbol->string id0)]
1067                                     [(string? id0) id0]
1068                                     [else (err)] ) )
1069                             (if (null? (##sys#slot id 1))
1070                                 ""
1071                                 "/")
1072                             (loop (##sys#slot id 1)) ) ) ) ] ) ] )
1073        (let check ([p p])
1074          (let ([n (##sys#size p)])
1075            (cond [(fx= 0 n) (err)]
1076                  [(sep? (string-ref p 0))
1077                   (check (##sys#substring p 1 n)) ]
1078                  [(sep? (string-ref p (fx- n 1)))
1079                   (check (##sys#substring p 0 (fx- n 1))) ]
1080                  [else p] ) ) ) ) ) ) )
1081
1082(define ##sys#repository-path
1083  (make-parameter 
1084   (or (getenv repository-environment-variable)
1085       (##sys#chicken-prefix 
1086        (##sys#string-append 
1087         "lib/chicken/"
1088         (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
1089       install-egg-home) ) )
1090
1091(define repository-path ##sys#repository-path)
1092
1093(define ##sys#find-extension
1094  (let ([file-exists? file-exists?]
1095        [string-append string-append] )
1096    (lambda (p inc?)
1097      (let ((rp (##sys#repository-path)))
1098        (define (check path)
1099          (let ([p0 (string-append path "/" p)])
1100            (and (or (and rp
1101                          (not ##sys#dload-disabled)
1102                          (##sys#fudge 24) ; dload?
1103                          (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
1104                     (file-exists? (##sys#string-append p0 source-file-extension)) )
1105                 p0) ) )
1106          (let loop ([paths (##sys#append
1107                             (if rp (list rp) '("."))
1108                             (if inc? (##sys#append ##sys#include-pathnames '(".")) '()) ) ] )
1109            (and (pair? paths)
1110                 (let ([pa (##sys#slot paths 0)])
1111                   (or (check pa)
1112                       (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
1113
1114(define ##sys#loaded-extensions '())
1115
1116(define ##sys#load-extension
1117  (let ((string->symbol string->symbol))
1118    (lambda (id loc . err?)
1119      (cond ((string? id) (set! id (string->symbol id)))
1120            (else (##sys#check-symbol id loc)) )
1121      (let ([p (##sys#canonicalize-extension-path id loc)])
1122        (cond ((member p ##sys#loaded-extensions))
1123              ((memq id ##sys#core-library-modules)
1124               (##sys#load-library id #f) )
1125              (else
1126               (let ([id2 (##sys#find-extension p #t)])
1127                 (cond (id2
1128                        (##sys#load id2 #f #f)
1129                        (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
1130                        #t)
1131                       ((optional err? #t) (##sys#error loc "cannot load extension" id))
1132                       (else #f) ) ) ) ) ) ) ) )
1133
1134(define (##sys#provide . ids)
1135  (for-each
1136   (lambda (id)
1137     (##sys#check-symbol id 'provide)
1138     (let ([p (##sys#canonicalize-extension-path id 'provide)])
1139       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
1140   ids) )
1141
1142(define provide ##sys#provide)
1143
1144(define (##sys#provided? id)
1145  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
1146       #t) )
1147
1148(define provided? ##sys#provided?)
1149
1150(define ##sys#require
1151  (lambda ids
1152    (for-each
1153     (cut ##sys#load-extension <> 'require) 
1154     ids) ) )
1155
1156(define require ##sys#require)
1157
1158(define ##sys#extension-information
1159  (let ([with-input-from-file with-input-from-file]
1160        [file-exists? file-exists?]
1161        [string-append string-append]
1162        [read read] )
1163    (lambda (id loc)
1164      (and-let* ((rp (##sys#repository-path)))
1165        (let* ((p (##sys#canonicalize-extension-path id loc))
1166               (rpath (string-append rp "/" p ".")) )
1167          (cond ((file-exists? (string-append rpath setup-file-extension))
1168                 => (cut with-input-from-file <> read) )
1169                (else #f) ) ) ) ) ))
1170
1171(define (extension-information ext)
1172  (##sys#extension-information ext 'extension-information) )
1173
1174(define ##sys#lookup-runtime-requirements 
1175  (let ([with-input-from-file with-input-from-file]
1176        [read read] )
1177    (lambda (ids)
1178      (let loop1 ([ids ids])
1179        (if (null? ids)
1180            '()
1181            (append
1182             (or (and-let* ([info (##sys#extension-information (car ids) #f)]
1183                            [a (assq 'require-at-runtime info)] )
1184                   (cdr a) )
1185                 '() )
1186             (loop1 (cdr ids)) ) ) ) ) ) )
1187
1188(define ##sys#do-the-right-thing
1189  (let ((vector->list vector->list))
1190    (lambda (id comp? imp?)
1191      (define (add-req id syntax?)
1192        (when comp?
1193          (##sys#hash-table-update! ; assumes compiler has extras available - will break in the interpreter
1194           ##compiler#file-requirements
1195           (if syntax? 'dynamic/syntax 'dynamic)
1196           (cut lset-adjoin eq? <> id) 
1197           (lambda () (list id)))))
1198      (define (impform x id builtin?)
1199        `(begin
1200           ,x
1201           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
1202                 `((import ,id))
1203                 '())))
1204      (define (doit id)
1205        (cond ((or (memq id builtin-features)
1206                   (if comp?
1207                       (memq id builtin-features/compiled)
1208                       (##sys#feature? id) ) )
1209               (values (impform '(##core#undefined) id #t) #t) )
1210              ((memq id ##sys#core-library-modules)
1211               (values
1212                (impform
1213                 (if comp?
1214                     `(##core#declare (uses ,id))
1215                     `(load-library ',id) )
1216                 id #t)
1217                #t) )
1218              ((memq id ##sys#explicit-library-modules)
1219               (let* ((info (##sys#extension-information id 'require-extension))
1220                      (s (assq 'syntax info)))
1221                 (values
1222                  `(begin
1223                     ,@(if s `((##core#require-for-syntax ',id)) '())
1224                     ,(impform
1225                       (if comp?
1226                           `(##core#declare (uses ,id)) 
1227                           `(load-library ',id) )
1228                       id #f))
1229                  #t) ) )
1230              (else
1231               (let ((info (##sys#extension-information id 'require-extension)))
1232                 (cond (info
1233                        (let ((s (assq 'syntax info))
1234                              (rr (assq 'require-at-runtime info)) )
1235                          (when s (add-req id #t))
1236                          (values
1237                           (impform
1238                            `(begin
1239                               ,@(if s `((##core#require-for-syntax ',id)) '())
1240                               ,@(if (and (not rr) s)
1241                                     '()
1242                                     `((##sys#require
1243                                        ,@(map (lambda (id) `',id)
1244                                               (cond (rr (cdr rr))
1245                                                     (else (list id)) ) ) ) ) ) )
1246                            id #f)
1247                           #t) ) )
1248                       (else
1249                        (add-req id #f)
1250                        (values
1251                         (impform
1252                          `(##sys#require ',id) 
1253                          id #f)
1254                         #f)))))))
1255      (if (and (pair? id) (symbol? (car id)))
1256          (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
1257            (if a
1258                (let ((a ((##sys#slot a 1) id)))
1259                  (cond ((string? a) (values `(load ,a) #f))
1260                        ((vector? a) 
1261                         (let loop ((specs (vector->list a))
1262                                    (exps '())
1263                                    (f #f) )
1264                           (if (null? specs)
1265                               (values `(begin ,@(reverse exps)) f)
1266                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
1267                                 (loop (cdr specs)
1268                                       (cons exp exps)
1269                                       (or fi f) ) ) ) ) )
1270                        (else (##sys#do-the-right-thing a comp? imp?)) ) )
1271                (##sys#error "undefined extension specifier" id) ) )
1272          (if (symbol? id)
1273              (doit id) 
1274              (##sys#error "invalid extension specifier" id) ) ) ) ) )
1275
1276(define ##sys#extension-specifiers '())
1277
1278(define (set-extension-specifier! name proc)
1279  (##sys#check-symbol name 'set-extension-specifier!)
1280  (let ([a (assq name ##sys#extension-specifiers)])
1281    (if a
1282        (let ([old (##sys#slot a 1)])
1283          (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
1284        (set! ##sys#extension-specifiers
1285          (cons (cons name (lambda (spec) (proc spec #f)))
1286                ##sys#extension-specifiers)) ) ) )
1287
1288
1289;;; SRFI-55
1290
1291(set-extension-specifier!
1292 'srfi 
1293 (let ([list->vector list->vector])
1294   (lambda (spec old)
1295     (list->vector
1296      (let loop ([ids (cdr spec)])
1297        (if (null? ids)
1298            '()
1299            (let ([id (car ids)])
1300              (##sys#check-exact id 'require-extension)
1301              (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
1302                    (loop (cdr ids)) ) ) ) ) ) ) ) )
1303
1304
1305;;; Version checking
1306
1307(set-extension-specifier!
1308 'version
1309 (lambda (spec _)
1310   (define (->string x)
1311     (cond ((string? x) x)
1312           ((symbol? x) (##sys#slot x 1))
1313           ((number? x) (##sys#number->string x))
1314           (else (error "invalid extension version" x)) ) )
1315   (if (and (list spec) (fx= 3 (length spec)))
1316       (let* ((info (extension-information (cadr spec)))
1317              (vv (and info (assq 'version info))) )
1318         (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
1319           (error "installed extension does not match required version" id vv (caddr spec)))
1320         id) 
1321       (##sys#syntax-error-hook "invalid version specification" spec)) ) )
1322
1323
1324;;; Convert string into valid C-identifier:
1325
1326(define ##sys#string->c-identifier
1327  (let ([string-copy string-copy])
1328    (lambda (str)
1329      (let* ([s2 (string-copy str)]
1330             [n (##sys#size s2)] )
1331        (do ([i 0 (fx+ i 1)])
1332            ((fx>= i n) s2)
1333          (let ([c (##core#inline "C_subchar" s2 i)])
1334            (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
1335              (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )
1336
1337
1338;;; Environments:
1339
1340(define ##sys#r4rs-environment (make-vector environment-table-size '()))
1341(define ##sys#r5rs-environment #f)
1342(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
1343
1344(define (##sys#environment? obj)
1345  (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
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.