source: project/chicken/branches/dsssl-delegate/eval.scm @ 16107

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

delegation function argument for ##sys#expand-extended-lambda-list

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