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

Last change on this file since 15869 was 15869, checked in by Kon Lovett, 10 years ago

library Added new dynamic library sys namespace procedures
runtime Added support for non-chicken dynload, "folded" 'C_dload2' into platform indep routine
chicken Added new dynload procs
eval Made dynload flags a parameter, added new dynload routines (only a subset is "public", i.e. non-sys namespace)

File size: 65.2 KB
Line 
1;;;; eval.scm - Interpreter for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit eval)
30  (uses expand 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
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 regex-extras posix srfi-1 srfi-4 srfi-13 
108           srfi-14 srfi-18 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-69 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   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
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 
502                                llist body ##sys#syntax-error-hook se) ) ) 
503                            (##sys#decompose-lambda-list
504                             llist
505                             (lambda (vars argc rest)
506                               (let* ((aliases (map gensym vars))
507                                      (se2 (append (map cons vars aliases) se))
508                                      (e2 (cons aliases e))
509                                      (body 
510                                       (##sys#compile-to-closure
511                                        (##sys#canonicalize-body body se2 #f)
512                                        e2
513                                        se2
514                                        (or h cntr) ) ) )
515                                 (case argc
516                                   [(0) (if rest
517                                            (lambda (v)
518                                              (decorate
519                                               (lambda r
520                                                 (##core#app body (cons (vector r) v)))
521                                               info h cntr) )
522                                            (lambda (v)
523                                              (decorate
524                                               (lambda () (##core#app body (cons #f v)))
525                                               info h cntr) ) ) ]
526                                   [(1) (if rest
527                                            (lambda (v)
528                                              (decorate
529                                               (lambda (a1 . r)
530                                                 (##core#app body (cons (vector a1 r) v)))
531                                               info h cntr) ) 
532                                            (lambda (v)
533                                              (decorate 
534                                               (lambda (a1)
535                                                 (##core#app body (cons (vector a1) v)))
536                                               info h cntr) ) ) ]
537                                   [(2) (if rest
538                                            (lambda (v) 
539                                              (decorate
540                                               (lambda (a1 a2 . r)
541                                                 (##core#app body (cons (vector a1 a2 r) v)))
542                                               info h cntr) )
543                                            (lambda (v)
544                                              (decorate
545                                               (lambda (a1 a2)
546                                                 (##core#app body (cons (vector a1 a2) v)))
547                                               info h cntr) ) ) ]
548                                   [(3) (if rest
549                                            (lambda (v) 
550                                              (decorate
551                                               (lambda (a1 a2 a3 . r)
552                                                 (##core#app body (cons (vector a1 a2 a3 r) v)))
553                                               info h cntr) )
554                                            (lambda (v)
555                                              (decorate
556                                               (lambda (a1 a2 a3)
557                                                 (##core#app body (cons (vector a1 a2 a3) v)))
558                                               info h cntr) ) ) ]
559                                   [(4) (if rest
560                                            (lambda (v)
561                                              (decorate
562                                               (lambda (a1 a2 a3 a4 . r)
563                                                 (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
564                                               info h cntr) )
565                                            (lambda (v)
566                                              (decorate
567                                               (lambda (a1 a2 a3 a4)
568                                                 (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
569                                               info h cntr) ) ) ]
570                                   [else
571                                    (if rest
572                                        (lambda (v)
573                                          (decorate
574                                           (lambda as
575                                             (##core#app
576                                              body
577                                              (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
578                                           info h cntr) )
579                                        (lambda (v)
580                                          (decorate
581                                           (lambda as 
582                                             (let ([len (length as)])
583                                               (if (not (fx= len argc))
584                                                   (##sys#error "bad argument count" argc len)
585                                                   (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
586                                           info h cntr) ) ) ] ) ) ) ) ) ]
587
588                         ((let-syntax)
589                          (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
590                          (let ((se2 (append
591                                      (map (lambda (b)
592                                             (list
593                                              (car b)
594                                              se
595                                              (##sys#er-transformer
596                                               (eval/meta (cadr b)))))
597                                           (cadr x) ) 
598                                      se) ) )
599                            (compile
600                             (##sys#canonicalize-body (cddr x) se2 #f)
601                             e #f tf cntr se2)))
602                               
603                         ((letrec-syntax)
604                          (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
605                          (let* ((ms (map (lambda (b)
606                                            (list
607                                             (car b)
608                                             #f
609                                             (##sys#er-transformer
610                                              (eval/meta (cadr b)))))
611                                          (cadr x) ) )
612                                 (se2 (append ms se)) )
613                            (for-each
614                             (lambda (sb)
615                               (set-car! (cdr sb) se2) )
616                             ms) 
617                            (compile
618                             (##sys#canonicalize-body (cddr x) se2 #f)
619                             e #f tf cntr se2)))
620                               
621                         ((define-syntax define-compiled-syntax)
622                          (##sys#check-syntax
623                           'define-syntax x
624                           (if (and (pair? (cdr x)) (pair? (cadr x)))
625                               '(_ (variable . lambda-list) . #(_ 1))
626                               '(_ variable _))
627                           #f se)
628                          (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
629                                 (body (if (pair? (cadr x))
630                                           `(,(rename 'lambda se) ,(cdadr x) ,@(cddr x))
631                                           (caddr x)))
632                                 (name (rename var se)))
633                            (##sys#register-syntax-export 
634                             name (##sys#current-module)
635                             body)      ;*** not really necessary, it only shouldn't be #f
636                            (##sys#extend-macro-environment
637                             name
638                             (##sys#current-environment)
639                             (##sys#er-transformer (eval/meta body)))
640                            (compile '(##core#undefined) e #f tf cntr se) ) )
641
642                         ((##core#define-compiler-syntax)
643                          (compile '(##core#undefined) e #f tf cntr se))
644
645                         ((##core#let-compiler-syntax)
646                          (compile 
647                           (##sys#canonicalize-body (cddr x) se #f)
648                           e #f tf cntr se))
649
650                         ((##core#module)
651                          (let* ((name (##sys#strip-syntax (cadr x)))
652                                 (exports 
653                                  (or (eq? #t (caddr x))
654                                      (map (lambda (exp)
655                                             (cond ((symbol? exp) exp)
656                                                   ((and (pair? exp) 
657                                                         (let loop ((exp exp))
658                                                           (or (null? exp)
659                                                               (and (symbol? (car exp))
660                                                                    (loop (cdr exp))))))
661                                                    exp)
662                                                   (else
663                                                    (##sys#syntax-error-hook
664                                                     'module
665                                                     "invalid export syntax" exp name))))
666                                           (##sys#strip-syntax (caddr x))))))
667                            (when (##sys#current-module)
668                              (##sys#syntax-error-hook 'module "modules may not be nested" name))
669                            (parameterize ((##sys#current-module 
670                                            (##sys#register-module name exports))
671                                           (##sys#current-environment '())
672                                           (##sys#macro-environment ##sys#initial-macro-environment))
673                                (let loop ((body (cdddr x)) (xs '()))
674                                  (if (null? body)
675                                      (let ((xs (reverse xs)))
676                                        (##sys#finalize-module (##sys#current-module))
677                                        (lambda (v)
678                                          (let loop2 ((xs xs))
679                                            (if (null? xs)
680                                                (##sys#void)
681                                                (let ((n (##sys#slot xs 1)))
682                                                  (cond ((pair? n)
683                                                         ((##sys#slot xs 0) v)
684                                                         (loop2 n))
685                                                        (else
686                                                         ((##sys#slot xs 0) v))))))))
687                                      (loop 
688                                       (cdr body)
689                                       (cons (compile 
690                                              (car body) 
691                                              '() #f tf cntr 
692                                              (##sys#current-environment))
693                                             xs))))) ) )
694
695                         [(##core#loop-lambda)
696                          (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
697
698                         [(##core#named-lambda)
699                          (compile `(,(rename 'lambda se) ,@(cddr x)) e (cadr x) tf cntr se) ]
700
701                         [(##core#require-for-syntax)
702                          (let ([ids (map (lambda (x)
703                                            (eval/meta x))
704                                          (cdr x))])
705                            (apply ##sys#require ids)
706                            (let ([rs (##sys#lookup-runtime-requirements ids)])
707                              (compile
708                               (if (null? rs)
709                                   '(##core#undefined)
710                                   `(##sys#require ,@(map (lambda (x) `',x) rs)) )
711                               e #f tf cntr se) ) ) ]
712
713                         [(##core#require-extension)
714                          (let ((imp? (caddr x)))
715                            (compile
716                             (let loop ([ids (cadr x)])
717                               (if (null? ids)
718                                   '(##core#undefined)
719                                   (let-values ([(exp _)
720                                                 (##sys#do-the-right-thing (car ids) #f imp?)])
721                                     `(##core#begin ,exp ,(loop (cdr ids))) ) ) )
722                             e #f tf cntr se) ) ]
723
724                         [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
725                          (eval/meta (cadr x))
726                          (compile '(##core#undefined) e #f tf cntr se) ]
727
728                         [(##core#compiletimetoo)
729                          (compile (cadr x) e #f tf cntr se) ]
730
731                         [(##core#compiletimeonly ##core#callunit) 
732                          (compile '(##core#undefined) e #f tf cntr se) ]
733
734                         [(##core#declare)
735                          (if (memq #:compiling ##sys#features)
736                              (for-each (lambda (d) (##compiler#process-declaration d se)) (cdr x)) 
737                              (##sys#warn "declarations are ignored in interpreted code" x) )
738                          (compile '(##core#undefined) e #f tf cntr se) ]
739
740                         [(define-inline define-constant)
741                          (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
742                   
743                         [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
744                                            ##core#define-foreign-variable 
745                                            ##core#define-external-variable ##core#let-location
746                                            ##core#foreign-primitive
747                                            ##core#foreign-lambda* ##core#define-foreign-type)
748                          (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
749
750                         [(##core#app)
751                          (compile-call (cdr x) e tf cntr se) ]
752
753                         [else
754                          (cond [(eq? head 'location)
755                                 (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
756
757                                [else (compile-call x e tf cntr se)] ) ] ) ) ) ) ]
758             
759              [else
760               (emit-syntax-trace-info tf x cntr)
761               (compile-call x e tf cntr se)] ) )
762
763      (define (fudge-argument-list n alst)
764        (if (null? alst) 
765            (list alst)
766            (do ((n n (fx- n 1))
767                 (c 0 (fx+ c 1))
768                 (args alst 
769                       (if (eq? '() args)
770                           (##sys#error "bad argument count" n c)
771                           (##sys#slot args 1)))
772                 (last #f args) )
773                ((fx= n 0)
774                 (##sys#setslot last 1 (list args))
775                 alst) ) ) )
776
777      (define (checked-length lst)
778        (let loop ([lst lst] [n 0])
779          (cond [(null? lst) n]
780                [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
781                [else #f] ) ) )
782
783      (define (compile-call x e tf cntr se)
784        (let* ([fn (compile (##sys#slot x 0) e #f tf cntr se)]
785               [args (##sys#slot x 1)]
786               [argc (checked-length args)]
787               [info x] )
788          (case argc
789            [(#f) (##sys#syntax-error-hook "malformed expression" x)]
790            [(0) (lambda (v)
791                   (emit-trace-info tf info cntr)
792                   ((fn v)))]
793            [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
794                   (lambda (v)
795                     (emit-trace-info tf info cntr)
796                     ((##core#app fn v) (##core#app a1 v))) ) ]
797            [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
798                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
799                   (lambda (v)
800                     (emit-trace-info tf info cntr)
801                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
802            [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
803                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
804                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
805                   (lambda (v)
806                     (emit-trace-info tf info cntr)
807                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
808            [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
809                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
810                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] 
811                        [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
812                   (lambda (v)
813                     (emit-trace-info tf info cntr)
814                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
815            [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
816                    (lambda (v)
817                      (emit-trace-info tf info cntr)
818                      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
819
820      (compile exp env #f (fx> ##sys#eval-debug-level 0) cntr se) ) ) )
821
822(define ##sys#eval-handler 
823  (make-parameter
824   (lambda (x . env)
825     (let ([mut ##sys#environment-is-mutable]
826           [e #f] )
827       (when (pair? env)
828         (let ([env (car env)])
829           (when env
830             (##sys#check-structure env 'environment)
831             (set! e (##sys#slot env 1)) 
832             (set! mut (##sys#slot env 2)) ) ) )
833       ((fluid-let ([##sys#environment-is-mutable mut]
834                    [##sys#eval-environment e] )
835          (##sys#compile-to-closure x '() (##sys#current-environment)) )
836        '() ) ) ) ) )
837
838(define eval-handler ##sys#eval-handler)
839
840(define (eval x . env)
841  (apply (##sys#eval-handler) 
842         x
843         env) )
844
845;;; Split lambda-list into its parts:
846
847(define ##sys#decompose-lambda-list
848  (let ([reverse reverse])
849    (lambda (llist0 k)
850
851      (define (err)
852        (set! ##sys#syntax-error-culprit #f)
853        (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
854
855      (let loop ([llist llist0] [vars '()] [argc 0])
856        (cond [(eq? llist '()) (k (reverse vars) argc #f)]
857              [(not (##core#inline "C_blockp" llist)) (err)]
858              [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
859              [(not (##core#inline "C_pairp" llist)) (err)]
860              [else (loop (##sys#slot llist 1)
861                          (cons (##sys#slot llist 0) vars)
862                          (fx+ argc 1) ) ] ) ) ) ) )
863
864
865;;; Loading source/object files:
866
867(define load-verbose (make-parameter (##sys#fudge 13)))
868
869(define (##sys#abort-load) #f)
870(define ##sys#current-source-filename #f)
871(define ##sys#current-load-path "")
872(define ##sys#dload-disabled #f)
873
874(define-foreign-variable _dlerror c-string "C_dlerror")
875
876(define dynamic-load-mode)
877(define set-dynamic-load-mode!)                         ;DEPRECATED
878(let ()
879
880  (define (dynamic-load-flags->mode flags)
881    (and flags
882         (list (if (car flags) 'now 'lazy) (if (cadr flags) 'global 'local)) ) )
883
884  (define (dynamic-load-mode->flags mode)
885    (let ((mode (if (pair? mode) mode (list mode)))
886          (now #f)
887          (global #t) )
888      (let loop ((mode mode))
889        (when (pair? mode)
890          (case (car mode)
891            ((global) (set! global #t))
892            ((local)  (set! global #f))
893            ((lazy)   (set! now #f))
894            ((now)    (set! now #t))
895            (else
896             (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (car mode)) ) )
897          (loop (cdr mode)) ) )
898      (list now global) ) )
899
900  (set! dynamic-load-mode
901    (make-parameter (dynamic-load-flags->mode (##sys#dlopen-flags))
902      (lambda (x)
903        (cond ((or (pair? x) (symbol? x))
904               (apply ##sys#set-dlopen-flags! (dynamic-load-mode->flags x))
905               (dynamic-load-flags->mode (##sys#dlopen-flags)) )
906              (else
907                (dynamic-load-mode) ) ) ) ) )
908             
909  (set! set-dynamic-load-mode! (lambda (mode) (dynamic-load-mode mode) ) ) )
910
911(let ([read read]
912      [write write]
913      [display display]
914      [newline newline]
915      (flush-output flush-output)
916      [eval eval]
917      [open-input-file open-input-file]
918      [close-input-port close-input-port]
919      [string-append string-append] 
920      [load-verbose load-verbose]
921      [topentry (##sys#make-c-string "C_toplevel")] )
922  (define (has-sep? str)
923    (let loop ([i (fx- (##sys#size str) 1)])
924      (and (not (zero? i))
925           (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
926               i
927               (loop (fx- i 1)) ) ) ) )
928  (define (badfile x)
929    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
930  (set! ##sys#load 
931    (lambda (input evaluator pf #!optional timer printer)
932      (when (string? input) 
933        (set! input (##sys#expand-home-path input)) )
934      (let* ([isdir #f]
935             [fname 
936              (cond [(port? input) #f]
937                    [(not (string? input)) (badfile input)]
938                    [(and-let* ([info (##sys#file-info input)]
939                                [id (##sys#slot info 4)] )
940                       (set! isdir (eq? 1 id)) 
941                       (not isdir) )
942                     input]
943                    [else
944                     (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
945                       (if (and (not ##sys#dload-disabled)
946                                (##sys#fudge 24) ; dload?
947                                (##sys#file-info fname2))
948                           fname2
949                           (let ([fname3 (##sys#string-append input source-file-extension)])
950                             (if (##sys#file-info fname3)
951                                 fname3
952                                 (and (not isdir) input) ) ) ) ) ] ) ]
953             [evproc (or evaluator eval)] )
954        (cond [(and (string? input) (not fname))
955               (##sys#signal-hook #:file-error 'load "cannot open file" input) ]
956              [(and (load-verbose) fname)
957               (display "; loading ")
958               (display fname)
959               (display " ...\n") 
960               (flush-output)] )
961        (or (and fname
962                 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
963                     (and (not (has-sep? fname))
964                          (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
965            (call-with-current-continuation
966             (lambda (abrt)
967               (fluid-let ([##sys#read-error-with-line-number #t]
968                           [##sys#current-source-filename fname]
969                           [##sys#current-load-path
970                            (and fname
971                                 (let ((i (has-sep? fname)))
972                                   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
973                           [##sys#abort-load (lambda () (abrt #f))] )
974                 (let ([in (if fname (open-input-file fname) input)])
975                   (##sys#dynamic-wind
976                    (lambda () #f)
977                    (lambda ()
978                      (let ([c1 (peek-char in)])
979                        (when (char=? c1 (integer->char 127))
980                          (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
981                      (let ((x1 (read in)))
982                        (do ((x x1 (read in)))
983                            ((eof-object? x))
984                          (when printer (printer x))
985                          (##sys#call-with-values
986                           (lambda () 
987                             (if timer
988                                 (time (evproc x)) 
989                                 (evproc x) ) )
990                           (lambda results
991                             (when pf
992                               (for-each
993                                (lambda (r) 
994                                  (write r)
995                                  (newline) )
996                                results) ) ) ) ) ) )
997                    (lambda () (close-input-port in)) ) ) ) ) ) )
998        (##core#undefined) ) ) )
999  (set! load
1000    (lambda (filename . evaluator)
1001      (##sys#load filename (optional evaluator #f) #f) ) )
1002  (set! load-relative
1003    (lambda (filename . evaluator)
1004      (##sys#load
1005       (if (memq (string-ref filename 0) '(#\\ #\/))
1006           filename
1007           (##sys#string-append ##sys#current-load-path filename) )
1008       (optional evaluator #f) #f) ) )
1009  (set! load-noisily
1010    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
1011      (##sys#load filename evaluator #t time printer) ) ) )
1012
1013(define ##sys#load-library-extension    ; this is crude...
1014  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
1015        [(eq? (software-version) 'macosx) macosx-load-library-extension]
1016        [(and (eq? (software-version) 'hpux) 
1017              (eq? (machine-type) 'hppa)) hppa-load-library-extension]
1018        [else default-load-library-extension] ) )
1019
1020(define ##sys#load-dynamic-extension default-load-library-extension)
1021
1022(define ##sys#default-dynamic-load-libraries 
1023  (case (build-platform)
1024    ((cygwin) cygwin-default-dynamic-load-libraries)
1025    (else default-dynamic-load-libraries) ) )
1026
1027(define dynamic-load-libraries 
1028  (let ((ext
1029         (if (and (memq (software-version) '(linux netbsd openbsd freebsd))
1030                  (not (zero? binary-version))) ; allow "configless" build
1031             (string-append
1032              ##sys#load-library-extension
1033              "." 
1034              (number->string binary-version))
1035             ##sys#load-library-extension)))
1036    (define complete
1037      (cut ##sys#string-append <> ext))
1038    (make-parameter
1039     (map complete ##sys#default-dynamic-load-libraries)
1040     (lambda (x)
1041       (##sys#check-list x)
1042       x) ) ) )
1043
1044(define ##sys#load-library-0
1045  (let ([load-verbose load-verbose]
1046        [string-append string-append]
1047        [dynamic-load-libraries dynamic-load-libraries]
1048        [display display] )
1049    (lambda (uname lib)
1050      (let ([id (##sys#->feature-id uname)])
1051        (or (memq id ##sys#features)
1052            (let ([libs
1053                   (if lib
1054                       (##sys#list lib)
1055                       (cons (##sys#string-append (##sys#slot uname 1) ;symbol pname
1056                                                  ##sys#load-library-extension)
1057                             (dynamic-load-libraries) ) ) ]
1058                  [top 
1059                   (##sys#make-c-string
1060                    (string-append
1061                     "C_"
1062                     (##sys#string->c-identifier (##sys#slot uname 1)) 
1063                     "_toplevel") ) ] )
1064              (when (load-verbose)
1065                (display "; loading library ")
1066                (display uname)
1067                (display " ...\n") )
1068              (let loop ([libs libs])
1069                (cond [(null? libs) #f]
1070                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
1071                       ; Cannot be in features yet but check anyway
1072                       (unless (memq id ##sys#features)
1073                         (set! ##sys#features (cons id ##sys#features)) )
1074                       #t]
1075                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
1076
1077(define ##sys#load-library
1078  (lambda (uname . lib)
1079    (##sys#check-symbol uname 'load-library)
1080    (or (##sys#load-library-0 uname (and (pair? lib) (car lib)))
1081        (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
1082
1083(define load-library ##sys#load-library)
1084
1085(define (dynamic-library-load name)
1086  (##sys#check-string name 'dynamic-library-load)
1087  (or (##sys#dynamic-library-load name)
1088      (##sys#error 'dynamic-library-load "cannot load dynamic library" name _dlerror) ) )
1089
1090(define (loaded-libraries)
1091  ; Ignore the names of explicitly loaded library units
1092  (let loop ((ils (##sys#dynamic-library-names)) (ols '()))
1093    (if (null? ils)
1094        ols
1095        (let ((nam (car ils)))
1096          (loop (cdr ils) (if (member nam (dynamic-load-libraries)) ols (cons nam ols))) ) ) ) )
1097
1098;; (##sys#dynamic-library-procedure mname sname) => mname+sname-ptr
1099;; (##sys#dynamic-library-variable mname sname) => mname+sname-ptr
1100;;
1101;; Will attempt to load (global lazy) the library should the attempt to
1102;; resolve the symbol fail. Either this succeeds and the symbol is then
1103;; resolved, or an error will be signaled.
1104
1105(define ##sys#dynamic-library-procedure)
1106(define ##sys#dynamic-library-variable)
1107(let ()
1108
1109  (define (checked-pointer loc ptrfnc mname sname)
1110    (or (ptrfnc mname sname)
1111        (and (parameterize ((dynamic-load-mode '(lazy global))) (dynamic-library-load mname))
1112             (ptrfnc mname sname) )
1113        (##sys#error loc "cannot resolve dynamic library symbol" mname sname _dlerror) ) )
1114
1115  (set! ##sys#dynamic-library-procedure
1116    (lambda (mname sname)
1117      (checked-pointer 'dynamic-library-procedure
1118                       ##sys#dynamic-library-procedure-pointer mname sname) ) )
1119
1120  (set! ##sys#dynamic-library-variable
1121    (lambda (mname sname)
1122      (checked-pointer 'dynamic-library-variable
1123                        ##sys#dynamic-library-variable-pointer mname sname) ) ) )
1124
1125;; (dynamic-library-procedure mname sname handler) => procedure/n
1126;; (dynamic-library-variable mname sname handler) => procedure/n
1127;;
1128;; The 'procedure/n' invokes the handler on (mname sname mname+sname-ptr n-args).
1129;;
1130;; Will attempt to load (global lazy) the library should the attempt to
1131;; resolve the symbol fail. Either this succeeds and the symbol is then
1132;; resolved, or an error will be signaled.
1133
1134(define (dynamic-library-procedure mname sname handler)
1135  (##sys#check-string mname 'dynamic-library-procedure)
1136  (##sys#check-closure handler 'dynamic-library-procedure)
1137  (let ((prcnam (if (symbol? sname) (symbol->string sname) sname)))
1138    (##sys#check-string prcnam 'dynamic-library-procedure)
1139    (let ((ptr (##sys#dynamic-library-procedure mname sname handler)))
1140      (lambda args (handler mname sname ptr args)) ) ) )
1141
1142(define (dynamic-library-variable mname sname handler)
1143  (##sys#check-string mname 'dynamic-library-variable)
1144  (##sys#check-closure handler 'dynamic-library-variable)
1145  (let ((varnam (if (symbol? sname) (symbol->string sname) sname)))
1146    (##sys#check-string varnam 'dynamic-library-variable)
1147    (let ((ptr (##sys#dynamic-library-variable mname sname handler)))
1148      (lambda args (handler mname sname ptr args)) ) ) )
1149
1150;;; Extensions:
1151
1152(define ##sys#canonicalize-extension-path
1153  (let ([string-append string-append])
1154    (lambda (id loc)
1155      (define (err) (##sys#error loc "invalid extension path" id))
1156      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
1157      (let ([p (cond [(string? id) id]
1158                     [(symbol? id) (##sys#symbol->string id)]
1159                     [(list? id) 
1160                      (let loop ([id id])
1161                        (if (null? id)
1162                            ""
1163                            (string-append
1164                             (let ([id0 (##sys#slot id 0)])
1165                               (cond [(symbol? id0) (##sys#symbol->string id0)]
1166                                     [(string? id0) id0]
1167                                     [else (err)] ) )
1168                             (if (null? (##sys#slot id 1))
1169                                 ""
1170                                 "/")
1171                             (loop (##sys#slot id 1)) ) ) ) ] ) ] )
1172        (let check ([p p])
1173          (let ([n (##sys#size p)])
1174            (cond [(fx= 0 n) (err)]
1175                  [(sep? (string-ref p 0))
1176                   (check (##sys#substring p 1 n)) ]
1177                  [(sep? (string-ref p (fx- n 1)))
1178                   (check (##sys#substring p 0 (fx- n 1))) ]
1179                  [else p] ) ) ) ) ) ) )
1180
1181(define ##sys#repository-path
1182  (make-parameter 
1183   (or (get-environment-variable repository-environment-variable)
1184       (##sys#chicken-prefix 
1185        (##sys#string-append 
1186         "lib/chicken/"
1187         (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
1188       install-egg-home) ) )
1189
1190(define repository-path ##sys#repository-path)
1191
1192(define ##sys#setup-mode #f)
1193
1194(define ##sys#find-extension
1195  (let ((file-exists? file-exists?)
1196        (string-append string-append) )
1197    (lambda (p inc?)
1198      (let ((rp (##sys#repository-path)))
1199        (define (check path)
1200          (let ((p0 (string-append path "/" p)))
1201            (and (or (and rp
1202                          (not ##sys#dload-disabled)
1203                          (##sys#fudge 24) ; dload?
1204                          (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
1205                     (file-exists? (##sys#string-append p0 source-file-extension)) )
1206                 p0) ) )
1207          (let loop ((paths (##sys#append
1208                             (if ##sys#setup-mode '(".") '())
1209                             (if rp (list rp) '())
1210                             (if inc? ##sys#include-pathnames '())
1211                             (if ##sys#setup-mode '() '("."))) ))
1212            (and (pair? paths)
1213                 (let ((pa (##sys#slot paths 0)))
1214                   (or (check pa)
1215                       (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
1216
1217(define ##sys#loaded-extensions '())
1218
1219(define ##sys#load-extension
1220  (let ((string->symbol string->symbol))
1221    (lambda (id loc #!optional (err? #t))
1222      (cond ((string? id) (set! id (string->symbol id)))
1223            (else (##sys#check-symbol id loc)) )
1224      (let ([p (##sys#canonicalize-extension-path id loc)])
1225        (cond ((member p ##sys#loaded-extensions))
1226              ((memq id ##sys#core-library-modules)
1227               (or (##sys#load-library-0 id #f)
1228                   (and err?
1229                        (##sys#error loc "cannot load core library" id))))
1230              (else
1231               (let ([id2 (##sys#find-extension p #t)])
1232                 (cond (id2
1233                        (##sys#load id2 #f #f)
1234                        (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
1235                        #t)
1236                       (err? (##sys#error loc "cannot load extension" id))
1237                       (else #f) ) ) ) ) ) ) ) )
1238
1239(define (##sys#provide . ids)
1240  (for-each
1241   (lambda (id)
1242     (##sys#check-symbol id 'provide)
1243     (let ([p (##sys#canonicalize-extension-path id 'provide)])
1244       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
1245   ids) )
1246
1247(define provide ##sys#provide)
1248
1249(define (##sys#provided? id)
1250  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
1251       #t) )
1252
1253(define provided? ##sys#provided?)
1254
1255(define ##sys#require
1256  (lambda ids
1257    (for-each
1258     (cut ##sys#load-extension <> 'require) 
1259     ids) ) )
1260
1261(define require ##sys#require)
1262
1263(define ##sys#extension-information
1264  (let ([with-input-from-file with-input-from-file]
1265        [file-exists? file-exists?]
1266        [string-append string-append]
1267        [read read] )
1268    (lambda (id loc)
1269      (and-let* ((rp (##sys#repository-path)))
1270        (let* ((p (##sys#canonicalize-extension-path id loc))
1271               (rpath (string-append rp "/" p ".")) )
1272          (cond ((file-exists? (string-append rpath setup-file-extension))
1273                 => (cut with-input-from-file <> read) )
1274                (else #f) ) ) ) ) ))
1275
1276(define (extension-information ext)
1277  (##sys#extension-information ext 'extension-information) )
1278
1279(define ##sys#lookup-runtime-requirements 
1280  (let ([with-input-from-file with-input-from-file]
1281        [read read] )
1282    (lambda (ids)
1283      (let loop1 ([ids ids])
1284        (if (null? ids)
1285            '()
1286            (append
1287             (or (and-let* ([info (##sys#extension-information (car ids) #f)]
1288                            [a (assq 'require-at-runtime info)] )
1289                   (cdr a) )
1290                 '() )
1291             (loop1 (cdr ids)) ) ) ) ) ) )
1292
1293(define ##sys#do-the-right-thing
1294  (let ((vector->list vector->list))
1295    (lambda (id comp? imp?)
1296      (define (add-req id syntax?)
1297        (when comp?
1298          (##sys#hash-table-update!
1299           ##compiler#file-requirements
1300           (if syntax? 'dynamic/syntax 'dynamic)
1301           (cut lset-adjoin eq? <> id)  ;XXX assumes compiler has srfi-1 loaded
1302           (lambda () (list id)))))
1303      (define (impform x id builtin?)
1304        `(##core#begin
1305           ,x
1306           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
1307                 `((import ,id))        ;XXX make hygienic
1308                 '())))
1309      (define (doit id)
1310        (cond ((or (memq id builtin-features)
1311                   (if comp?
1312                       (memq id builtin-features/compiled)
1313                       (##sys#feature? id) ) )
1314               (values (impform '(##core#undefined) id #t) #t) )
1315              ((memq id ##sys#core-library-modules)
1316               (values
1317                (impform
1318                 (if comp?
1319                     `(##core#declare (uses ,id))
1320                     `(##sys#load-library ',id #f) )
1321                 id #t)
1322                #t) )
1323              ((memq id ##sys#explicit-library-modules)
1324               (let* ((info (##sys#extension-information id 'require-extension))
1325                      (s (assq 'syntax info)))
1326                 (values
1327                  `(##core#begin
1328                     ,@(if s `((##core#require-for-syntax ',id)) '())
1329                     ,(impform
1330                       (if comp?
1331                           `(##core#declare (uses ,id)) 
1332                           `(##sys#load-library ',id #f) )
1333                       id #f))
1334                  #t) ) )
1335              (else
1336               (let ((info (##sys#extension-information id 'require-extension)))
1337                 (cond (info
1338                        (let ((s (assq 'syntax info))
1339                              (rr (assq 'require-at-runtime info)) )
1340                          (when s (add-req id #t))
1341                          (values
1342                           (impform
1343                            `(##core#begin
1344                               ,@(if s `((##core#require-for-syntax ',id)) '())
1345                               ,@(if (and (not rr) s)
1346                                     '()
1347                                     `((##sys#require
1348                                        ,@(map (lambda (id) `',id)
1349                                               (cond (rr (cdr rr))
1350                                                     (else (list id)) ) ) ) ) ) )
1351                            id #f)
1352                           #t) ) )
1353                       (else
1354                        (add-req id #f)
1355                        (values
1356                         (impform
1357                          `(##sys#require ',id) 
1358                          id #f)
1359                         #f)))))))
1360      (if (and (pair? id) (symbol? (car id)))
1361          (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
1362            (if a
1363                (let ((a ((##sys#slot a 1) id)))
1364                  (cond ((string? a) (values `(load ,a) #f))
1365                        ((vector? a) 
1366                         (let loop ((specs (vector->list a))
1367                                    (exps '())
1368                                    (f #f) )
1369                           (if (null? specs)
1370                               (values `(##core#begin ,@(reverse exps)) f)
1371                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
1372                                 (loop (cdr specs)
1373                                       (cons exp exps)
1374                                       (or fi f) ) ) ) ) )
1375                        (else (##sys#do-the-right-thing a comp? imp?)) ) )
1376                (##sys#error "undefined extension specifier" id) ) )
1377          (if (symbol? id)
1378              (doit id) 
1379              (##sys#error "invalid extension specifier" id) ) ) ) ) )
1380
1381(define ##sys#extension-specifiers '())
1382
1383(define (set-extension-specifier! name proc)
1384  (##sys#check-symbol name 'set-extension-specifier!)
1385  (let ([a (assq name ##sys#extension-specifiers)])
1386    (if a
1387        (let ([old (##sys#slot a 1)])
1388          (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
1389        (set! ##sys#extension-specifiers
1390          (cons (cons name (lambda (spec) (proc spec #f)))
1391                ##sys#extension-specifiers)) ) ) )
1392
1393
1394;;; SRFI-55
1395
1396(set-extension-specifier!
1397 'srfi 
1398 (let ([list->vector list->vector])
1399   (lambda (spec old)
1400     (list->vector
1401      (let loop ([ids (cdr spec)])
1402        (if (null? ids)
1403            '()
1404            (let ([id (car ids)])
1405              (##sys#check-exact id 'require-extension)
1406              (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
1407                    (loop (cdr ids)) ) ) ) ) ) ) ) )
1408
1409
1410;;; Version checking
1411
1412(set-extension-specifier!
1413 'version
1414 (lambda (spec _)
1415   (define (->string x)
1416     (cond ((string? x) x)
1417           ((symbol? x) (##sys#slot x 1))
1418           ((number? x) (##sys#number->string x))
1419           (else (error "invalid extension version" x)) ) )
1420   (if (and (list? spec) (fx= 3 (length spec)))
1421       (let* ((info (extension-information (cadr spec)))
1422              (vv (and info (assq 'version info))) )
1423         (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
1424           (error "installed extension does not match required version" id vv (caddr spec)))
1425         id) 
1426       (##sys#syntax-error-hook "invalid version specification" spec)) ) )
1427
1428
1429;;; Convert string into valid C-identifier:
1430
1431(define ##sys#string->c-identifier
1432  (let ([string-copy string-copy])
1433    (lambda (str)
1434      (let* ([s2 (string-copy str)]
1435             [n (##sys#size s2)] )
1436        (do ([i 0 (fx+ i 1)])
1437            ((fx>= i n) s2)
1438          (let ([c (##core#inline "C_subchar" s2 i)])
1439            (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
1440              (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )
1441
1442
1443;;; Environments:
1444
1445(define ##sys#r4rs-environment (make-vector environment-table-size '()))
1446(define ##sys#r5rs-environment #f)
1447(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
1448
1449(define (##sys#environment? obj)
1450  (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
1451
1452(define ##sys#copy-env-table
1453  (lambda (e mff mf . args)
1454    (let ([syms (and (pair? args) (car args))])
1455      (let* ([s (##sys#size e)]
1456             [e2 (##sys#make-vector s '())] )
1457       (do ([i 0 (fx+ i 1)])
1458           ((fx>= i s) e2)
1459         (##sys#setslot 
1460          e2 i
1461          (let copy ([b (##sys#slot e i)])
1462            (if (null? b)
1463                '()
1464                (let ([bi (##sys#slot b 0)])
1465                  (let ([sym (##sys#slot bi 0)])
1466                    (if (or (not syms) (memq sym syms))
1467                      (cons (vector
1468                              sym
1469                              (##sys#slot bi 1)
1470                              (if mff mf (##sys#slot bi 2)))
1471                            (copy (##sys#slot b 1)))
1472                      (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
1473
1474(define ##sys#environment-symbols
1475  (lambda (env . args)
1476    (##sys#check-structure env 'environment)
1477    (let ([pred (and (pair? args) (car args))])
1478      (let ([envtbl (##sys#slot env 1)])
1479        (if envtbl
1480            ;then "real" environment
1481          (let ([envtblsiz (vector-length envtbl)])
1482            (do ([i 0 (fx+ i 1)]
1483                 [syms
1484                   '()
1485                   (let loop ([bucket (vector-ref envtbl i)] [syms syms])
1486                     (if (null? bucket)
1487                       syms
1488                       (let ([sym (vector-ref (car bucket) 0)])
1489                         (if (or (not pred) (pred sym))
1490                           (loop (cdr bucket) (cons sym syms))
1491                           (loop (cdr bucket) syms) ) ) ) )])
1492                ((fx>= i envtblsiz) syms) ) )
1493            ;else interaction-environment
1494          (let ([syms '()])
1495            (##sys#walk-namespace
1496              (lambda (sym)
1497                (when (or (not pred) (pred sym))
1498                  (set! syms (cons sym syms)) ) ) )
1499            syms ) ) ) ) ) )
1500
1501(define (interaction-environment) ##sys#interaction-environment)
1502
1503(define scheme-report-environment
1504  (lambda (n . mutable)
1505    (##sys#check-exact n 'scheme-report-environment)
1506    (let ([mf (and (pair? mutable) (car mutable))])
1507      (case n
1508        [(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
1509        [(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
1510        [else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )
1511
1512(define null-environment
1513  (let ([make-vector make-vector])
1514    (lambda (n . mutable)
1515      (##sys#check-exact n 'null-environment)
1516      (when (or (fx< n 4) (fx> n 5))
1517        (##sys#error 'null-environment "no support for version" n) )
1518      (##sys#make-structure
1519       'environment
1520       (make-vector environment-table-size '())
1521       (and (pair? mutable) (car mutable)) ) ) ) )
1522
1523(let ()
1524  (define (initb ht) 
1525    (lambda (b)
1526      (let ([loc (##sys#hash-table-location ht b #t)])
1527        (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
1528  (for-each
1529   (initb ##sys#r4rs-environment)
1530   '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
1531     cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
1532     cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
1533     append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
1534     number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
1535     max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
1536     exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
1537     string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
1538     char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
1539     char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
1540     string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
1541     make-string string-length string-ref string-set! string-append string-copy string->list 
1542     list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
1543     vector-length vector->list list->vector vector-fill! procedure? map for-each apply force 
1544     call-with-current-continuation input-port? output-port? current-input-port current-output-port
1545     call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
1546     close-output-port load read eof-object? read-char peek-char
1547     write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
1548     ##sys#values ##sys#dynamic-wind ##sys#void
1549     ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
1550  (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
1551  (for-each
1552   (initb ##sys#r5rs-environment)
1553   '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )
1554
1555
1556;;; Find included file:
1557
1558(define ##sys#include-pathnames 
1559  (let ((h (chicken-home)))
1560    (if h (list h) '())) )
1561
1562(define ##sys#resolve-include-filename
1563  (let ((string-append string-append) )
1564    (define (exists? fname)
1565      (let ([info (##sys#file-info fname)])
1566        (and info (not (eq? 1 (##sys#slot info 4)))) ) )
1567    (lambda (fname prefer-source #!optional repo)
1568      (define (test2 fname lst)
1569        (if (null? lst)
1570            (and (exists? fname) fname)
1571            (let ([fn (##sys#string-append fname (car lst))])
1572              (if (exists? fn)
1573                  fn
1574                  (test2 fname (cdr lst)) ) ) ) )
1575      (define (test fname)
1576        (test2 
1577         fname
1578         (cond ((not (##sys#fudge 24)) (list source-file-extension)) ; no dload?
1579               (prefer-source (list source-file-extension ##sys#load-dynamic-extension))
1580               (else (list ##sys#load-dynamic-extension source-file-extension) ) ) ))
1581      (or (test fname)
1582          (let loop ((paths (if repo
1583                                (##sys#append 
1584                                 ##sys#include-pathnames 
1585                                 (let ((rp (##sys#repository-path)))
1586                                   (if rp
1587                                       (list (##sys#repository-path))
1588                                       '())))
1589                                ##sys#include-pathnames) ) )
1590            (cond ((eq? paths '()) fname)
1591                  ((test (string-append (##sys#slot paths 0)
1592                                        "/"
1593                                        fname) ) )
1594                  (else (loop (##sys#slot paths 1))) ) ) ) ) ) )
1595
1596
1597;;; Print timing information (support for "time" macro):
1598
1599(define ##sys#display-times
1600  (let* ((display display)
1601         (spaces 
1602          (lambda (n)
1603            (do ((i n (fx- i 1)))
1604                ((fx<= i 0))
1605              (display #\space) ) ) )
1606         (display-rj 
1607          (lambda (x w)
1608            (let* ((xs (if (zero? x) "0" (number->string x)))
1609                   (xslen (##core#inline "C_block_size" xs)) )
1610              (spaces (fx- w xslen))
1611              (display xs) ) ) ) )
1612    (lambda (info)
1613      (display-rj (##sys#slot info 0) 8)
1614      (display " seconds elapsed\n") 
1615      (display-rj (##sys#slot info 1) 8)
1616      (display " seconds in (major) GC\n")
1617      (display-rj (##sys#slot info 2) 8)
1618      (display " mutations\n")
1619      (display-rj (##sys#slot info 3) 8)
1620      (display " minor GCs\n")
1621      (display-rj (##sys#slot info 4) 8)
1622      (display " major GCs\n") ) ) )
1623
1624
1625;;; SRFI-0 support code:
1626
1627(set! ##sys#features
1628  (append '(#:srfi-8 #:srfi-6 #:srfi-2 #:srfi-0 #:srfi-10 #:srfi-9 #:srfi-55 #:srfi-61) 
1629          ##sys#features))
1630
1631
1632;;;; Read-Eval-Print loop:
1633
1634(define ##sys#repl-eval-hook #f)
1635(define ##sys#repl-print-length-limit #f)
1636(define ##sys#repl-read-hook #f)
1637
1638(define (##sys#repl-print-hook x port)
1639  (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
1640  (##sys#write-char-0 #\newline port) )
1641
1642(define repl-prompt (make-parameter (lambda () "#;> ")))
1643
1644(define ##sys#read-prompt-hook
1645  (let ([repl-prompt repl-prompt])
1646    (lambda () 
1647      (##sys#print ((repl-prompt)) #f ##sys#standard-output)
1648      (##sys#flush-output ##sys#standard-output) ) ) )
1649
1650(define ##sys#clear-trace-buffer (foreign-lambda void "C_clear_trace_buffer"))
1651
1652(define repl
1653  (let ((eval eval)
1654        (read read)
1655        (call-with-current-continuation call-with-current-continuation)
1656        (print-call-chain print-call-chain)
1657        (flush-output flush-output)
1658        (load-verbose load-verbose)
1659        (reset reset) )
1660    (lambda ()
1661
1662      (define (write-err xs)
1663        (for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs) )
1664
1665      (define (write-results xs)
1666        (unless (or (null? xs) (eq? (##core#undefined) (car xs)))
1667          (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs) ) )
1668
1669      (let ((stdin ##sys#standard-input)
1670            (stdout ##sys#standard-output)
1671            (stderr ##sys#standard-error)
1672            (ehandler (##sys#error-handler))
1673            (rhandler (##sys#reset-handler)) 
1674            (lv #f)
1675            (uie ##sys#unbound-in-eval) )
1676
1677        (define (saveports)
1678          (set! stdin ##sys#standard-input)
1679          (set! stdout ##sys#standard-output)
1680          (set! stderr ##sys#standard-error) )
1681
1682        (define (resetports)
1683          (set! ##sys#standard-input stdin)
1684          (set! ##sys#standard-output stdout)
1685          (set! ##sys#standard-error stderr) )
1686
1687        (##sys#dynamic-wind
1688         (lambda ()
1689           (set! lv (load-verbose))
1690           (load-verbose #t)
1691           (##sys#error-handler
1692            (lambda (msg . args)
1693              (resetports)
1694              (##sys#print "\nError" #f ##sys#standard-error)
1695              (when msg
1696                (##sys#print ": " #f ##sys#standard-error)
1697                (##sys#print msg #f ##sys#standard-error) )
1698              (if (and (pair? args) (null? (cdr args)))
1699                  (begin
1700                    (##sys#print ": " #f ##sys#standard-error)
1701                    (write-err args) )
1702                  (begin
1703                    (##sys#write-char-0 #\newline ##sys#standard-error)
1704                    (write-err args) ) )
1705              (print-call-chain ##sys#standard-error)
1706              (flush-output ##sys#standard-error) ) ) )
1707         (lambda ()
1708           (let loop ()
1709             (saveports)
1710             (call-with-current-continuation
1711              (lambda (c)
1712                (##sys#reset-handler
1713                 (lambda ()
1714                   (set! ##sys#read-error-with-line-number #f)
1715                   (set! ##sys#enable-qualifiers #t)
1716                   (resetports)
1717                   (c #f) ) ) ) )
1718             (##sys#read-prompt-hook)
1719             (let ([exp ((or ##sys#repl-read-hook read))])
1720               (unless (eof-object? exp)
1721                 (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
1722                   (##sys#read-char-0 ##sys#standard-input) )
1723                 (##sys#clear-trace-buffer)
1724                 (set! ##sys#unbound-in-eval '())
1725                 (receive result ((or ##sys#repl-eval-hook eval) exp)
1726                   (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
1727                     (let loop ((vars ##sys#unbound-in-eval) (u '()))
1728                       (cond ((null? vars)
1729                              (when (pair? u)
1730                                (##sys#print 
1731                                 "Warning: the following toplevel variables are referenced but unbound:\n" 
1732                                 #f ##sys#standard-error)
1733                                (for-each
1734                                 (lambda (v)
1735                                   (##sys#print "  " #f ##sys#standard-error)
1736                                   (##sys#print (car v) #t ##sys#standard-error)
1737                                   (when (cdr v)
1738                                     (##sys#print " (in " #f ##sys#standard-error)
1739                                     (##sys#print (cdr v) #t ##sys#standard-error) 
1740                                     (##sys#write-char-0 #\) ##sys#standard-error) )
1741                                   (##sys#write-char-0 #\newline ##sys#standard-error) )
1742                                 u)
1743                                (##sys#flush-output ##sys#standard-error)))
1744                             ((or (memq (caar vars) u) 
1745                                  (##sys#symbol-has-toplevel-binding? (caar vars)) )
1746                              (loop (cdr vars) u) )
1747                             (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
1748                   (write-results result) 
1749                   (loop) ) ) ) ) )
1750         (lambda ()
1751           (load-verbose lv)
1752           (set! ##sys#unbound-in-eval uie)
1753           (##sys#error-handler ehandler)
1754           (##sys#reset-handler rhandler) ) ) ) ) ) )
1755
1756
1757;;; SRFI-10:
1758
1759(define ##sys#sharp-comma-reader-ctors (make-vector 301 '()))
1760
1761(define (define-reader-ctor spec proc)
1762  (##sys#check-symbol spec 'define-reader-ctor)
1763  (##sys#hash-table-set! ##sys#sharp-comma-reader-ctors spec proc) )
1764
1765(set! ##sys#user-read-hook
1766  (let ((old ##sys#user-read-hook)
1767        (read-char read-char)
1768        (read read) )
1769    (lambda (char port)
1770      (cond ((char=? char #\,)
1771             (read-char port)
1772             (let* ((exp (read port))
1773                    (err (lambda () (##sys#read-error port "invalid sharp-comma external form" exp))) )
1774               (if (or (null? exp) (not (list? exp)))
1775                   (err)
1776                   (let ([spec (##sys#slot exp 0)])
1777                     (if (not (symbol? spec))
1778                         (err) 
1779                         (let ((ctor (##sys#hash-table-ref ##sys#sharp-comma-reader-ctors spec)))
1780                           (if ctor
1781                               (apply ctor (##sys#slot exp 1))
1782                               (##sys#read-error port "undefined sharp-comma constructor" spec) ) ) ) ) ) ) )
1783            (else (old char port)) ) ) ) )
1784
1785
1786;;; Simple invocation API:
1787
1788(declare
1789  (hide last-error run-safe store-result store-string
1790        CHICKEN_yield CHICKEN_apply_to_string
1791        CHICKEN_eval CHICKEN_eval_string CHICKEN_eval_to_string CHICKEN_eval_string_to_string
1792        CHICKEN_apply CHICKEN_eval_apply CHICKEN_eval_to_string
1793        CHICKEN_read CHICKEN_load CHICKEN_get_error_message) )
1794       
1795(define last-error #f)
1796
1797(define (run-safe thunk)
1798  (set! last-error #f)
1799  (handle-exceptions ex 
1800      (let ((o (open-output-string)))
1801        (print-error-message ex o)
1802        (set! last-error (get-output-string o))
1803        #f)
1804    (thunk) ) )
1805
1806#>
1807#define C_store_result(x, ptr)   (*((C_word *)C_block_item(ptr, 0)) = (x), C_SCHEME_TRUE)
1808<#
1809
1810(define (store-result x result)
1811  (##sys#gc #f)
1812  (when result
1813    (##core#inline "C_store_result" x result) )
1814  #t)
1815
1816(define-external (CHICKEN_yield) bool
1817  (run-safe (lambda () (begin (thread-yield!) #t))) )
1818
1819(define-external (CHICKEN_eval (scheme-object exp) ((c-pointer "C_word") result)) bool
1820  (run-safe
1821   (lambda ()
1822     (store-result (eval exp) result) ) ) )
1823
1824(define-external (CHICKEN_eval_string (c-string str) ((c-pointer "C_word") result)) bool
1825  (run-safe
1826   (lambda ()
1827     (let ([i (open-input-string str)])
1828       (store-result (eval (read i)) result)) )))
1829
1830#>
1831#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)
1832<#
1833
1834(define (store-string str bufsize buf)
1835  (let ((len (##sys#size str)))
1836    (cond ((fx>= len bufsize)
1837           (set! last-error "Error: not enough room for result string")
1838           #f)
1839          (else (##core#inline "C_copy_result_string" str buf len)) ) ) )
1840
1841(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
1842                                          (int bufsize))
1843  bool
1844  (run-safe
1845   (lambda ()
1846     (let ([o (open-output-string)])
1847       (write (eval exp) o) 
1848       (store-string (get-output-string o) bufsize buf)) ) ) )
1849
1850(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
1851                                                 (int bufsize) ) 
1852  bool
1853  (run-safe
1854   (lambda ()
1855     (let ([o (open-output-string)])
1856       (write (eval (read (open-input-string str))) o)
1857       (store-string (get-output-string o) bufsize buf)) ) ) )
1858
1859(define-external (CHICKEN_apply (scheme-object func) (scheme-object args) 
1860                                 ((c-pointer "C_word") result))
1861  bool
1862  (run-safe (lambda () (store-result (apply func args) result))) )
1863
1864(define-external (CHICKEN_apply_to_string (scheme-object func) (scheme-object args) 
1865                                           ((c-pointer "char") buf) (int bufsize))
1866  bool
1867  (run-safe
1868   (lambda ()
1869     (let ([o (open-output-string)])
1870       (write (apply func args) o) 
1871       (store-string (get-output-string o) bufsize buf)) ) ) )
1872
1873(define-external (CHICKEN_read (c-string str) ((c-pointer "C_word") result)) bool
1874  (run-safe
1875   (lambda ()
1876     (let ([i (open-input-string str)])
1877       (store-result (read i) result) ) ) ) )
1878
1879(define-external (CHICKEN_load (c-string str)) bool
1880  (run-safe (lambda () (load str) #t)) )
1881
1882(define-external (CHICKEN_get_error_message ((c-pointer "char") buf) (int bufsize)) void
1883  (store-string (or last-error "No error") bufsize buf) )
1884
1885
1886;;; Create lambda-info object
1887
1888(define (##sys#make-lambda-info str)
1889  (let* ((sz (##sys#size str))
1890         (info (##sys#make-string sz)) )
1891    (##core#inline "C_copy_memory" info str sz)
1892    (##core#inline "C_string_to_lambdainfo" info)
1893    info) )
Note: See TracBrowser for help on using the repository browser.