source: project/chicken/branches/prerelease/eval.scm @ 15229

Last change on this file since 15229 was 15229, checked in by felix, 10 years ago

(really) merged trunk changes till 15228 into prerelease branch

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