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

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

strip module names

File size: 63.8 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 (set-dynamic-load-mode! mode)
877  (let ([mode (if (pair? mode) mode (list mode))]
878        [now #f]
879        [global #t] )
880    (let loop ([mode mode])
881      (when (pair? mode)
882        (case (##sys#slot mode 0)
883          [(global) (set! global #t)]
884          [(local) (set! global #f)]
885          [(lazy) (set! now #f)]
886          [(now) (set! now #t)]
887          [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
888        (loop (##sys#slot mode 1)) ) )
889    (##sys#set-dlopen-flags! now global) ) )
890
891(let ([read read]
892      [write write]
893      [display display]
894      [newline newline]
895      (flush-output flush-output)
896      [eval eval]
897      [open-input-file open-input-file]
898      [close-input-port close-input-port]
899      [string-append string-append] 
900      [load-verbose load-verbose]
901      [topentry (##sys#make-c-string "C_toplevel")] )
902  (define (has-sep? str)
903    (let loop ([i (fx- (##sys#size str) 1)])
904      (and (not (zero? i))
905           (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
906               i
907               (loop (fx- i 1)) ) ) ) )
908  (define (badfile x)
909    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
910  (set! ##sys#load 
911    (lambda (input evaluator pf #!optional timer printer)
912      (when (string? input) 
913        (set! input (##sys#expand-home-path input)) )
914      (let* ([isdir #f]
915             [fname 
916              (cond [(port? input) #f]
917                    [(not (string? input)) (badfile input)]
918                    [(and-let* ([info (##sys#file-info input)]
919                                [id (##sys#slot info 4)] )
920                       (set! isdir (eq? 1 id)) 
921                       (not isdir) )
922                     input]
923                    [else
924                     (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
925                       (if (and (not ##sys#dload-disabled)
926                                (##sys#fudge 24) ; dload?
927                                (##sys#file-info fname2))
928                           fname2
929                           (let ([fname3 (##sys#string-append input source-file-extension)])
930                             (if (##sys#file-info fname3)
931                                 fname3
932                                 (and (not isdir) input) ) ) ) ) ] ) ]
933             [evproc (or evaluator eval)] )
934        (cond [(and (string? input) (not fname))
935               (##sys#signal-hook #:file-error 'load "cannot open file" input) ]
936              [(and (load-verbose) fname)
937               (display "; loading ")
938               (display fname)
939               (display " ...\n") 
940               (flush-output)] )
941        (or (and fname
942                 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
943                     (and (not (has-sep? fname))
944                          (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
945            (call-with-current-continuation
946             (lambda (abrt)
947               (fluid-let ([##sys#read-error-with-line-number #t]
948                           [##sys#current-source-filename fname]
949                           [##sys#current-load-path
950                            (and fname
951                                 (let ((i (has-sep? fname)))
952                                   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
953                           [##sys#abort-load (lambda () (abrt #f))] )
954                 (let ([in (if fname (open-input-file fname) input)])
955                   (##sys#dynamic-wind
956                    (lambda () #f)
957                    (lambda ()
958                      (let ([c1 (peek-char in)])
959                        (when (char=? c1 (integer->char 127))
960                          (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
961                      (let ((x1 (read in)))
962                        (do ((x x1 (read in)))
963                            ((eof-object? x))
964                          (when printer (printer x))
965                          (##sys#call-with-values
966                           (lambda () 
967                             (if timer
968                                 (time (evproc x)) 
969                                 (evproc x) ) )
970                           (lambda results
971                             (when pf
972                               (for-each
973                                (lambda (r) 
974                                  (write r)
975                                  (newline) )
976                                results) ) ) ) ) ) )
977                    (lambda () (close-input-port in)) ) ) ) ) ) )
978        (##core#undefined) ) ) )
979  (set! load
980    (lambda (filename . evaluator)
981      (##sys#load filename (optional evaluator #f) #f) ) )
982  (set! load-relative
983    (lambda (filename . evaluator)
984      (##sys#load
985       (if (memq (string-ref filename 0) '(#\\ #\/))
986           filename
987           (##sys#string-append ##sys#current-load-path filename) )
988       (optional evaluator #f) #f) ) )
989  (set! load-noisily
990    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
991      (##sys#load filename evaluator #t time printer) ) ) )
992
993(define ##sys#load-library-extension    ; this is crude...
994  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
995        [(eq? (software-version) 'macosx) macosx-load-library-extension]
996        [(and (eq? (software-version) 'hpux) 
997              (eq? (machine-type) 'hppa)) hppa-load-library-extension]
998        [else default-load-library-extension] ) )
999
1000(define ##sys#load-dynamic-extension default-load-library-extension)
1001
1002(define ##sys#default-dynamic-load-libraries 
1003  (case (build-platform)
1004    ((cygwin) cygwin-default-dynamic-load-libraries)
1005    (else default-dynamic-load-libraries) ) )
1006
1007(define dynamic-load-libraries 
1008  (let ((ext
1009         (if (and (memq (software-version) '(linux netbsd openbsd freebsd))
1010                  (not (zero? binary-version))) ; allow "configless" build
1011             (string-append
1012              ##sys#load-library-extension
1013              "." 
1014              (number->string binary-version))
1015             ##sys#load-library-extension)))
1016    (define complete
1017      (cut ##sys#string-append <> ext))
1018    (make-parameter
1019     (map complete ##sys#default-dynamic-load-libraries)
1020     (lambda (x)
1021       (##sys#check-list x)
1022       x) ) ) )
1023
1024(define ##sys#load-library-0
1025  (let ([load-verbose load-verbose]
1026        [string-append string-append]
1027        [dynamic-load-libraries dynamic-load-libraries]
1028        [display display] )
1029    (lambda (uname lib)
1030      (let ([id (##sys#->feature-id uname)])
1031        (or (memq id ##sys#features)
1032            (let ([libs
1033                   (if lib
1034                       (##sys#list lib)
1035                       (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
1036                             (dynamic-load-libraries) ) ) ]
1037                  [top 
1038                   (##sys#make-c-string
1039                    (string-append
1040                     "C_"
1041                     (##sys#string->c-identifier (##sys#slot uname 1)) 
1042                     "_toplevel") ) ] )
1043              (when (load-verbose)
1044                (display "; loading library ")
1045                (display uname)
1046                (display " ...\n") )
1047              (let loop ([libs libs])
1048                (cond [(null? libs) #f]
1049                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
1050                       (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
1051                       #t]
1052                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
1053
1054(define ##sys#load-library
1055  (lambda (uname . lib)
1056    (##sys#check-symbol uname 'load-library)
1057    (or (##sys#load-library-0 uname (and (pair? lib) (car lib)))
1058        (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
1059
1060(define load-library ##sys#load-library)
1061
1062;; (loaded-libraries [COMBINE-ENTRIES?] [INCLUDE-SYSTEM-ENTRIES?])
1063;; COMBINE-ENTRIES? : a boolean, collapse all literal-frame entries for the
1064;; same library into a single entry, the default is #t.
1065;; INCLUDE-SYSTEM-ENTRIES? : a boolean, include entries for system libraries, the
1066;; default is #f.
1067;; => ((<pathname> <literal-frame-count> <ptable?>)...)
1068;; where <pathname> is #f (when runtime) or a string,
1069;; <literal-frame-count> is the total of entrypoints (toplevel),
1070;; and <ptable?> is a boolean indicating whether the lf has a ptable.
1071
1072(define (loaded-libraries #!optional (cmb? #t) (sys? #f))
1073  (let ((ls (##sys#literal-frame-info)))
1074    ; Everything wanted?
1075    (if (and (not cmb?) sys?)
1076        ; then everything it is
1077        ls
1078        ; else perform a "cull
1079        (let loop ((ils ls) (ols '()))
1080          (if (null? ils)
1081              ols
1082              (let* ((cur (car ils))
1083                     (nxt (cdr ils))
1084                     (nam (car cur))
1085                     ; Is this a wanted system entry or not a system entry?
1086                     (cur (and (or sys? (and nam (not (member nam (dynamic-load-libraries)))))
1087                               cur)) )
1088                (cond ((not cur)
1089                        (loop nxt ols) )
1090                      ; Combining entries?
1091                      (cmb?
1092                        (let ((ext (alist-ref nam ols equal?)))
1093                          (if ext
1094                             (begin
1095                               ; Accumulate frame count
1096                               (set-car! ext (+ (car ext) (cadr cur)))
1097                               ; Has any ptable then has a ptable
1098                               (when (and (not (cadr ext)) (caddr cur))
1099                                 (set-car! (cdr ext) #t) )
1100                               (loop nxt ols) )
1101                             (loop nxt (cons cur ols)) ) ) )
1102                      (else
1103                        (loop nxt (cons cur ols)) ) ) ) ) ) ) ) )
1104
1105(define (loaded-library-toplevel nam)
1106 (when nam (##sys#check-string nam 'loaded-library-toplevel))
1107 (##sys#literal-frame-toplevel (and nam (##sys#make-c-string nam))) )
1108
1109(define (loaded-library-ptable nam #!optional ptrs?)
1110 (when nam (##sys#check-string nam 'loaded-library-ptable))
1111 (##sys#literal-frame-ptable (and nam (##sys#make-c-string nam)) ptrs?) )
1112
1113
1114;;; Extensions:
1115
1116(define ##sys#canonicalize-extension-path
1117  (let ([string-append string-append])
1118    (lambda (id loc)
1119      (define (err) (##sys#error loc "invalid extension path" id))
1120      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
1121      (let ([p (cond [(string? id) id]
1122                     [(symbol? id) (##sys#symbol->string id)]
1123                     [(list? id) 
1124                      (let loop ([id id])
1125                        (if (null? id)
1126                            ""
1127                            (string-append
1128                             (let ([id0 (##sys#slot id 0)])
1129                               (cond [(symbol? id0) (##sys#symbol->string id0)]
1130                                     [(string? id0) id0]
1131                                     [else (err)] ) )
1132                             (if (null? (##sys#slot id 1))
1133                                 ""
1134                                 "/")
1135                             (loop (##sys#slot id 1)) ) ) ) ] ) ] )
1136        (let check ([p p])
1137          (let ([n (##sys#size p)])
1138            (cond [(fx= 0 n) (err)]
1139                  [(sep? (string-ref p 0))
1140                   (check (##sys#substring p 1 n)) ]
1141                  [(sep? (string-ref p (fx- n 1)))
1142                   (check (##sys#substring p 0 (fx- n 1))) ]
1143                  [else p] ) ) ) ) ) ) )
1144
1145(define ##sys#repository-path
1146  (make-parameter 
1147   (or (get-environment-variable repository-environment-variable)
1148       (##sys#chicken-prefix 
1149        (##sys#string-append 
1150         "lib/chicken/"
1151         (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
1152       install-egg-home) ) )
1153
1154(define repository-path ##sys#repository-path)
1155
1156(define ##sys#setup-mode #f)
1157
1158(define ##sys#find-extension
1159  (let ((file-exists? file-exists?)
1160        (string-append string-append) )
1161    (lambda (p inc?)
1162      (let ((rp (##sys#repository-path)))
1163        (define (check path)
1164          (let ((p0 (string-append path "/" p)))
1165            (and (or (and rp
1166                          (not ##sys#dload-disabled)
1167                          (##sys#fudge 24) ; dload?
1168                          (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
1169                     (file-exists? (##sys#string-append p0 source-file-extension)) )
1170                 p0) ) )
1171          (let loop ((paths (##sys#append
1172                             (if ##sys#setup-mode '(".") '())
1173                             (if rp (list rp) '())
1174                             (if inc? ##sys#include-pathnames '())
1175                             (if ##sys#setup-mode '() '("."))) ))
1176            (and (pair? paths)
1177                 (let ((pa (##sys#slot paths 0)))
1178                   (or (check pa)
1179                       (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
1180
1181(define ##sys#loaded-extensions '())
1182
1183(define ##sys#load-extension
1184  (let ((string->symbol string->symbol))
1185    (lambda (id loc #!optional (err? #t))
1186      (cond ((string? id) (set! id (string->symbol id)))
1187            (else (##sys#check-symbol id loc)) )
1188      (let ([p (##sys#canonicalize-extension-path id loc)])
1189        (cond ((member p ##sys#loaded-extensions))
1190              ((memq id ##sys#core-library-modules)
1191               (or (##sys#load-library-0 id #f)
1192                   (and err?
1193                        (##sys#error loc "cannot load core library" id))))
1194              (else
1195               (let ([id2 (##sys#find-extension p #t)])
1196                 (cond (id2
1197                        (##sys#load id2 #f #f)
1198                        (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
1199                        #t)
1200                       (err? (##sys#error loc "cannot load extension" id))
1201                       (else #f) ) ) ) ) ) ) ) )
1202
1203(define (##sys#provide . ids)
1204  (for-each
1205   (lambda (id)
1206     (##sys#check-symbol id 'provide)
1207     (let ([p (##sys#canonicalize-extension-path id 'provide)])
1208       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
1209   ids) )
1210
1211(define provide ##sys#provide)
1212
1213(define (##sys#provided? id)
1214  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
1215       #t) )
1216
1217(define provided? ##sys#provided?)
1218
1219(define ##sys#require
1220  (lambda ids
1221    (for-each
1222     (cut ##sys#load-extension <> 'require) 
1223     ids) ) )
1224
1225(define require ##sys#require)
1226
1227(define ##sys#extension-information
1228  (let ([with-input-from-file with-input-from-file]
1229        [file-exists? file-exists?]
1230        [string-append string-append]
1231        [read read] )
1232    (lambda (id loc)
1233      (and-let* ((rp (##sys#repository-path)))
1234        (let* ((p (##sys#canonicalize-extension-path id loc))
1235               (rpath (string-append rp "/" p ".")) )
1236          (cond ((file-exists? (string-append rpath setup-file-extension))
1237                 => (cut with-input-from-file <> read) )
1238                (else #f) ) ) ) ) ))
1239
1240(define (extension-information ext)
1241  (##sys#extension-information ext 'extension-information) )
1242
1243(define ##sys#lookup-runtime-requirements 
1244  (let ([with-input-from-file with-input-from-file]
1245        [read read] )
1246    (lambda (ids)
1247      (let loop1 ([ids ids])
1248        (if (null? ids)
1249            '()
1250            (append
1251             (or (and-let* ([info (##sys#extension-information (car ids) #f)]
1252                            [a (assq 'require-at-runtime info)] )
1253                   (cdr a) )
1254                 '() )
1255             (loop1 (cdr ids)) ) ) ) ) ) )
1256
1257(define ##sys#do-the-right-thing
1258  (let ((vector->list vector->list))
1259    (lambda (id comp? imp?)
1260      (define (add-req id syntax?)
1261        (when comp?
1262          (##sys#hash-table-update!
1263           ##compiler#file-requirements
1264           (if syntax? 'dynamic/syntax 'dynamic)
1265           (cut lset-adjoin eq? <> id)  ;XXX assumes compiler has srfi-1 loaded
1266           (lambda () (list id)))))
1267      (define (impform x id builtin?)
1268        `(##core#begin
1269           ,x
1270           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
1271                 `((import ,id))        ;XXX make hygienic
1272                 '())))
1273      (define (doit id)
1274        (cond ((or (memq id builtin-features)
1275                   (if comp?
1276                       (memq id builtin-features/compiled)
1277                       (##sys#feature? id) ) )
1278               (values (impform '(##core#undefined) id #t) #t) )
1279              ((memq id ##sys#core-library-modules)
1280               (values
1281                (impform
1282                 (if comp?
1283                     `(##core#declare (uses ,id))
1284                     `(##sys#load-library ',id #f) )
1285                 id #t)
1286                #t) )
1287              ((memq id ##sys#explicit-library-modules)
1288               (let* ((info (##sys#extension-information id 'require-extension))
1289                      (s (assq 'syntax info)))
1290                 (values
1291                  `(##core#begin
1292                     ,@(if s `((##core#require-for-syntax ',id)) '())
1293                     ,(impform
1294                       (if comp?
1295                           `(##core#declare (uses ,id)) 
1296                           `(##sys#load-library ',id #f) )
1297                       id #f))
1298                  #t) ) )
1299              (else
1300               (let ((info (##sys#extension-information id 'require-extension)))
1301                 (cond (info
1302                        (let ((s (assq 'syntax info))
1303                              (rr (assq 'require-at-runtime info)) )
1304                          (when s (add-req id #t))
1305                          (values
1306                           (impform
1307                            `(##core#begin
1308                               ,@(if s `((##core#require-for-syntax ',id)) '())
1309                               ,@(if (and (not rr) s)
1310                                     '()
1311                                     `((##sys#require
1312                                        ,@(map (lambda (id) `',id)
1313                                               (cond (rr (cdr rr))
1314                                                     (else (list id)) ) ) ) ) ) )
1315                            id #f)
1316                           #t) ) )
1317                       (else
1318                        (add-req id #f)
1319                        (values
1320                         (impform
1321                          `(##sys#require ',id) 
1322                          id #f)
1323                         #f)))))))
1324      (if (and (pair? id) (symbol? (car id)))
1325          (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
1326            (if a
1327                (let ((a ((##sys#slot a 1) id)))
1328                  (cond ((string? a) (values `(load ,a) #f))
1329                        ((vector? a) 
1330                         (let loop ((specs (vector->list a))
1331                                    (exps '())
1332                                    (f #f) )
1333                           (if (null? specs)
1334                               (values `(##core#begin ,@(reverse exps)) f)
1335                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
1336                                 (loop (cdr specs)
1337                                       (cons exp exps)
1338                                       (or fi f) ) ) ) ) )
1339                        (else (##sys#do-the-right-thing a comp? imp?)) ) )
1340                (##sys#error "undefined extension specifier" id) ) )
1341          (if (symbol? id)
1342              (doit id) 
1343              (##sys#error "invalid extension specifier" id) ) ) ) ) )
1344
1345(define ##sys#extension-specifiers '())
1346
1347(define (set-extension-specifier! name proc)
1348  (##sys#check-symbol name 'set-extension-specifier!)
1349  (let ([a (assq name ##sys#extension-specifiers)])
1350    (if a
1351        (let ([old (##sys#slot a 1)])
1352          (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
1353        (set! ##sys#extension-specifiers
1354          (cons (cons name (lambda (spec) (proc spec #f)))
1355                ##sys#extension-specifiers)) ) ) )
1356
1357
1358;;; SRFI-55
1359
1360(set-extension-specifier!
1361 'srfi 
1362 (let ([list->vector list->vector])
1363   (lambda (spec old)
1364     (list->vector
1365      (let loop ([ids (cdr spec)])
1366        (if (null? ids)
1367            '()
1368            (let ([id (car ids)])
1369              (##sys#check-exact id 'require-extension)
1370              (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
1371                    (loop (cdr ids)) ) ) ) ) ) ) ) )
1372
1373
1374;;; Version checking
1375
1376(set-extension-specifier!
1377 'version
1378 (lambda (spec _)
1379   (define (->string x)
1380     (cond ((string? x) x)
1381           ((symbol? x) (##sys#slot x 1))
1382           ((number? x) (##sys#number->string x))
1383           (else (error "invalid extension version" x)) ) )
1384   (if (and (list? spec) (fx= 3 (length spec)))
1385       (let* ((info (extension-information (cadr spec)))
1386              (vv (and info (assq 'version info))) )
1387         (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
1388           (error "installed extension does not match required version" id vv (caddr spec)))
1389         id) 
1390       (##sys#syntax-error-hook "invalid version specification" spec)) ) )
1391
1392
1393;;; Convert string into valid C-identifier:
1394
1395(define ##sys#string->c-identifier
1396  (let ([string-copy string-copy])
1397    (lambda (str)
1398      (let* ([s2 (string-copy str)]
1399             [n (##sys#size s2)] )
1400        (do ([i 0 (fx+ i 1)])
1401            ((fx>= i n) s2)
1402          (let ([c (##core#inline "C_subchar" s2 i)])
1403            (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
1404              (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )
1405
1406
1407;;; Environments:
1408
1409(define ##sys#r4rs-environment (make-vector environment-table-size '()))
1410(define ##sys#r5rs-environment #f)
1411(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
1412
1413(define (##sys#environment? obj)
1414  (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
1415
1416(define ##sys#copy-env-table
1417  (lambda (e mff mf . args)
1418    (let ([syms (and (pair? args) (car args))])
1419      (let* ([s (##sys#size e)]
1420             [e2 (##sys#make-vector s '())] )
1421       (do ([i 0 (fx+ i 1)])
1422           ((fx>= i s) e2)
1423         (##sys#setslot 
1424          e2 i
1425          (let copy ([b (##sys#slot e i)])
1426            (if (null? b)
1427                '()
1428                (let ([bi (##sys#slot b 0)])
1429                  (let ([sym (##sys#slot bi 0)])
1430                    (if (or (not syms) (memq sym syms))
1431                      (cons (vector
1432                              sym
1433                              (##sys#slot bi 1)
1434                              (if mff mf (##sys#slot bi 2)))
1435                            (copy (##sys#slot b 1)))
1436                      (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
1437
1438(define ##sys#environment-symbols
1439  (lambda (env . args)
1440    (##sys#check-structure env 'environment)
1441    (let ([pred (and (pair? args) (car args))])
1442      (let ([envtbl (##sys#slot env 1)])
1443        (if envtbl
1444            ;then "real" environment
1445          (let ([envtblsiz (vector-length envtbl)])
1446            (do ([i 0 (fx+ i 1)]
1447                 [syms
1448                   '()
1449                   (let loop ([bucket (vector-ref envtbl i)] [syms syms])
1450                     (if (null? bucket)
1451                       syms
1452                       (let ([sym (vector-ref (car bucket) 0)])
1453                         (if (or (not pred) (pred sym))
1454                           (loop (cdr bucket) (cons sym syms))
1455                           (loop (cdr bucket) syms) ) ) ) )])
1456                ((fx>= i envtblsiz) syms) ) )
1457            ;else interaction-environment
1458          (let ([syms '()])
1459            (##sys#walk-namespace
1460              (lambda (sym)
1461                (when (or (not pred) (pred sym))
1462                  (set! syms (cons sym syms)) ) ) )
1463            syms ) ) ) ) ) )
1464
1465(define (interaction-environment) ##sys#interaction-environment)
1466
1467(define scheme-report-environment
1468  (lambda (n . mutable)
1469    (##sys#check-exact n 'scheme-report-environment)
1470    (let ([mf (and (pair? mutable) (car mutable))])
1471      (case n
1472        [(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
1473        [(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
1474        [else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )
1475
1476(define null-environment
1477  (let ([make-vector make-vector])
1478    (lambda (n . mutable)
1479      (##sys#check-exact n 'null-environment)
1480      (when (or (fx< n 4) (fx> n 5))
1481        (##sys#error 'null-environment "no support for version" n) )
1482      (##sys#make-structure
1483       'environment
1484       (make-vector environment-table-size '())
1485       (and (pair? mutable) (car mutable)) ) ) ) )
1486
1487(let ()
1488  (define (initb ht) 
1489    (lambda (b)
1490      (let ([loc (##sys#hash-table-location ht b #t)])
1491        (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
1492  (for-each
1493   (initb ##sys#r4rs-environment)
1494   '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
1495     cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
1496     cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
1497     append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
1498     number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
1499     max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
1500     exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
1501     string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
1502     char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
1503     char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
1504     string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
1505     make-string string-length string-ref string-set! string-append string-copy string->list 
1506     list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
1507     vector-length vector->list list->vector vector-fill! procedure? map for-each apply force 
1508     call-with-current-continuation input-port? output-port? current-input-port current-output-port
1509     call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
1510     close-output-port load read eof-object? read-char peek-char
1511     write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
1512     ##sys#values ##sys#dynamic-wind ##sys#void
1513     ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
1514  (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
1515  (for-each
1516   (initb ##sys#r5rs-environment)
1517   '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )
1518
1519
1520;;; Find included file:
1521
1522(define ##sys#include-pathnames 
1523  (let ((h (chicken-home)))
1524    (if h (list h) '())) )
1525
1526(define ##sys#resolve-include-filename
1527  (let ((string-append string-append) )
1528    (define (exists? fname)
1529      (let ([info (##sys#file-info fname)])
1530        (and info (not (eq? 1 (##sys#slot info 4)))) ) )
1531    (lambda (fname prefer-source #!optional repo)
1532      (define (test2 fname lst)
1533        (if (null? lst)
1534            (and (exists? fname) fname)
1535            (let ([fn (##sys#string-append fname (car lst))])
1536              (if (exists? fn)
1537                  fn
1538                  (test2 fname (cdr lst)) ) ) ) )
1539      (define (test fname)
1540        (test2 
1541         fname
1542         (cond ((not (##sys#fudge 24)) (list source-file-extension)) ; no dload?
1543               (prefer-source (list source-file-extension ##sys#load-dynamic-extension))
1544               (else (list ##sys#load-dynamic-extension source-file-extension) ) ) ))
1545      (or (test fname)
1546          (let loop ((paths (if repo
1547                                (##sys#append 
1548                                 ##sys#include-pathnames 
1549                                 (let ((rp (##sys#repository-path)))
1550                                   (if rp
1551                                       (list (##sys#repository-path))
1552                                       '())))
1553                                ##sys#include-pathnames) ) )
1554            (cond ((eq? paths '()) fname)
1555                  ((test (string-append (##sys#slot paths 0)
1556                                        "/"
1557                                        fname) ) )
1558                  (else (loop (##sys#slot paths 1))) ) ) ) ) ) )
1559
1560
1561;;; Print timing information (support for "time" macro):
1562
1563(define ##sys#display-times
1564  (let* ((display display)
1565         (spaces 
1566          (lambda (n)
1567            (do ((i n (fx- i 1)))
1568                ((fx<= i 0))
1569              (display #\space) ) ) )
1570         (display-rj 
1571          (lambda (x w)
1572            (let* ((xs (if (zero? x) "0" (number->string x)))
1573                   (xslen (##core#inline "C_block_size" xs)) )
1574              (spaces (fx- w xslen))
1575              (display xs) ) ) ) )
1576    (lambda (info)
1577      (display-rj (##sys#slot info 0) 8)
1578      (display " seconds elapsed\n") 
1579      (display-rj (##sys#slot info 1) 8)
1580      (display " seconds in (major) GC\n")
1581      (display-rj (##sys#slot info 2) 8)
1582      (display " mutations\n")
1583      (display-rj (##sys#slot info 3) 8)
1584      (display " minor GCs\n")
1585      (display-rj (##sys#slot info 4) 8)
1586      (display " major GCs\n") ) ) )
1587
1588
1589;;; SRFI-0 support code:
1590
1591(set! ##sys#features
1592  (append '(#:srfi-8 #:srfi-6 #:srfi-2 #:srfi-0 #:srfi-10 #:srfi-9 #:srfi-55 #:srfi-61) 
1593          ##sys#features))
1594
1595
1596;;;; Read-Eval-Print loop:
1597
1598(define ##sys#repl-eval-hook #f)
1599(define ##sys#repl-print-length-limit #f)
1600(define ##sys#repl-read-hook #f)
1601
1602(define (##sys#repl-print-hook x port)
1603  (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
1604  (##sys#write-char-0 #\newline port) )
1605
1606(define repl-prompt (make-parameter (lambda () "#;> ")))
1607
1608(define ##sys#read-prompt-hook
1609  (let ([repl-prompt repl-prompt])
1610    (lambda () 
1611      (##sys#print ((repl-prompt)) #f ##sys#standard-output)
1612      (##sys#flush-output ##sys#standard-output) ) ) )
1613
1614(define ##sys#clear-trace-buffer (foreign-lambda void "C_clear_trace_buffer"))
1615
1616(define repl
1617  (let ((eval eval)
1618        (read read)
1619        (call-with-current-continuation call-with-current-continuation)
1620        (print-call-chain print-call-chain)
1621        (flush-output flush-output)
1622        (load-verbose load-verbose)
1623        (reset reset) )
1624    (lambda ()
1625
1626      (define (write-err xs)
1627        (for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs) )
1628
1629      (define (write-results xs)
1630        (unless (or (null? xs) (eq? (##core#undefined) (car xs)))
1631          (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs) ) )
1632
1633      (let ((stdin ##sys#standard-input)
1634            (stdout ##sys#standard-output)
1635            (stderr ##sys#standard-error)
1636            (ehandler (##sys#error-handler))
1637            (rhandler (##sys#reset-handler)) 
1638            (lv #f)
1639            (uie ##sys#unbound-in-eval) )
1640
1641        (define (saveports)
1642          (set! stdin ##sys#standard-input)
1643          (set! stdout ##sys#standard-output)
1644          (set! stderr ##sys#standard-error) )
1645
1646        (define (resetports)
1647          (set! ##sys#standard-input stdin)
1648          (set! ##sys#standard-output stdout)
1649          (set! ##sys#standard-error stderr) )
1650
1651        (##sys#dynamic-wind
1652         (lambda ()
1653           (set! lv (load-verbose))
1654           (load-verbose #t)
1655           (##sys#error-handler
1656            (lambda (msg . args)
1657              (resetports)
1658              (##sys#print "\nError" #f ##sys#standard-error)
1659              (when msg
1660                (##sys#print ": " #f ##sys#standard-error)
1661                (##sys#print msg #f ##sys#standard-error) )
1662              (if (and (pair? args) (null? (cdr args)))
1663                  (begin
1664                    (##sys#print ": " #f ##sys#standard-error)
1665                    (write-err args) )
1666                  (begin
1667                    (##sys#write-char-0 #\newline ##sys#standard-error)
1668                    (write-err args) ) )
1669              (print-call-chain ##sys#standard-error)
1670              (flush-output ##sys#standard-error) ) ) )
1671         (lambda ()
1672           (let loop ()
1673             (saveports)
1674             (call-with-current-continuation
1675              (lambda (c)
1676                (##sys#reset-handler
1677                 (lambda ()
1678                   (set! ##sys#read-error-with-line-number #f)
1679                   (set! ##sys#enable-qualifiers #t)
1680                   (resetports)
1681                   (c #f) ) ) ) )
1682             (##sys#read-prompt-hook)
1683             (let ([exp ((or ##sys#repl-read-hook read))])
1684               (unless (eof-object? exp)
1685                 (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
1686                   (##sys#read-char-0 ##sys#standard-input) )
1687                 (##sys#clear-trace-buffer)
1688                 (set! ##sys#unbound-in-eval '())
1689                 (receive result ((or ##sys#repl-eval-hook eval) exp)
1690                   (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
1691                     (let loop ((vars ##sys#unbound-in-eval) (u '()))
1692                       (cond ((null? vars)
1693                              (when (pair? u)
1694                                (##sys#print 
1695                                 "Warning: the following toplevel variables are referenced but unbound:\n" 
1696                                 #f ##sys#standard-error)
1697                                (for-each
1698                                 (lambda (v)
1699                                   (##sys#print "  " #f ##sys#standard-error)
1700                                   (##sys#print (car v) #t ##sys#standard-error)
1701                                   (when (cdr v)
1702                                     (##sys#print " (in " #f ##sys#standard-error)
1703                                     (##sys#print (cdr v) #t ##sys#standard-error) 
1704                                     (##sys#write-char-0 #\) ##sys#standard-error) )
1705                                   (##sys#write-char-0 #\newline ##sys#standard-error) )
1706                                 u)
1707                                (##sys#flush-output ##sys#standard-error)))
1708                             ((or (memq (caar vars) u) 
1709                                  (##sys#symbol-has-toplevel-binding? (caar vars)) )
1710                              (loop (cdr vars) u) )
1711                             (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
1712                   (write-results result) 
1713                   (loop) ) ) ) ) )
1714         (lambda ()
1715           (load-verbose lv)
1716           (set! ##sys#unbound-in-eval uie)
1717           (##sys#error-handler ehandler)
1718           (##sys#reset-handler rhandler) ) ) ) ) ) )
1719
1720
1721;;; SRFI-10:
1722
1723(define ##sys#sharp-comma-reader-ctors (make-vector 301 '()))
1724
1725(define (define-reader-ctor spec proc)
1726  (##sys#check-symbol spec 'define-reader-ctor)
1727  (##sys#hash-table-set! ##sys#sharp-comma-reader-ctors spec proc) )
1728
1729(set! ##sys#user-read-hook
1730  (let ((old ##sys#user-read-hook)
1731        (read-char read-char)
1732        (read read) )
1733    (lambda (char port)
1734      (cond ((char=? char #\,)
1735             (read-char port)
1736             (let* ((exp (read port))
1737                    (err (lambda () (##sys#read-error port "invalid sharp-comma external form" exp))) )
1738               (if (or (null? exp) (not (list? exp)))
1739                   (err)
1740                   (let ([spec (##sys#slot exp 0)])
1741                     (if (not (symbol? spec))
1742                         (err) 
1743                         (let ((ctor (##sys#hash-table-ref ##sys#sharp-comma-reader-ctors spec)))
1744                           (if ctor
1745                               (apply ctor (##sys#slot exp 1))
1746                               (##sys#read-error port "undefined sharp-comma constructor" spec) ) ) ) ) ) ) )
1747            (else (old char port)) ) ) ) )
1748
1749
1750;;; Simple invocation API:
1751
1752(declare
1753  (hide last-error run-safe store-result store-string
1754        CHICKEN_yield CHICKEN_apply_to_string
1755        CHICKEN_eval CHICKEN_eval_string CHICKEN_eval_to_string CHICKEN_eval_string_to_string
1756        CHICKEN_apply CHICKEN_eval_apply CHICKEN_eval_to_string
1757        CHICKEN_read CHICKEN_load CHICKEN_get_error_message) )
1758       
1759(define last-error #f)
1760
1761(define (run-safe thunk)
1762  (set! last-error #f)
1763  (handle-exceptions ex 
1764      (let ((o (open-output-string)))
1765        (print-error-message ex o)
1766        (set! last-error (get-output-string o))
1767        #f)
1768    (thunk) ) )
1769
1770#>
1771#define C_store_result(x, ptr)   (*((C_word *)C_block_item(ptr, 0)) = (x), C_SCHEME_TRUE)
1772<#
1773
1774(define (store-result x result)
1775  (##sys#gc #f)
1776  (when result
1777    (##core#inline "C_store_result" x result) )
1778  #t)
1779
1780(define-external (CHICKEN_yield) bool
1781  (run-safe (lambda () (begin (thread-yield!) #t))) )
1782
1783(define-external (CHICKEN_eval (scheme-object exp) ((c-pointer "C_word") result)) bool
1784  (run-safe
1785   (lambda ()
1786     (store-result (eval exp) result) ) ) )
1787
1788(define-external (CHICKEN_eval_string (c-string str) ((c-pointer "C_word") result)) bool
1789  (run-safe
1790   (lambda ()
1791     (let ([i (open-input-string str)])
1792       (store-result (eval (read i)) result)) )))
1793
1794#>
1795#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)
1796<#
1797
1798(define (store-string str bufsize buf)
1799  (let ((len (##sys#size str)))
1800    (cond ((fx>= len bufsize)
1801           (set! last-error "Error: not enough room for result string")
1802           #f)
1803          (else (##core#inline "C_copy_result_string" str buf len)) ) ) )
1804
1805(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
1806                                          (int bufsize))
1807  bool
1808  (run-safe
1809   (lambda ()
1810     (let ([o (open-output-string)])
1811       (write (eval exp) o) 
1812       (store-string (get-output-string o) bufsize buf)) ) ) )
1813
1814(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
1815                                                 (int bufsize) ) 
1816  bool
1817  (run-safe
1818   (lambda ()
1819     (let ([o (open-output-string)])
1820       (write (eval (read (open-input-string str))) o)
1821       (store-string (get-output-string o) bufsize buf)) ) ) )
1822
1823(define-external (CHICKEN_apply (scheme-object func) (scheme-object args) 
1824                                 ((c-pointer "C_word") result))
1825  bool
1826  (run-safe (lambda () (store-result (apply func args) result))) )
1827
1828(define-external (CHICKEN_apply_to_string (scheme-object func) (scheme-object args) 
1829                                           ((c-pointer "char") buf) (int bufsize))
1830  bool
1831  (run-safe
1832   (lambda ()
1833     (let ([o (open-output-string)])
1834       (write (apply func args) o) 
1835       (store-string (get-output-string o) bufsize buf)) ) ) )
1836
1837(define-external (CHICKEN_read (c-string str) ((c-pointer "C_word") result)) bool
1838  (run-safe
1839   (lambda ()
1840     (let ([i (open-input-string str)])
1841       (store-result (read i) result) ) ) ) )
1842
1843(define-external (CHICKEN_load (c-string str)) bool
1844  (run-safe (lambda () (load str) #t)) )
1845
1846(define-external (CHICKEN_get_error_message ((c-pointer "char") buf) (int bufsize)) void
1847  (store-string (or last-error "No error") bufsize buf) )
1848
1849
1850;;; Create lambda-info object
1851
1852(define (##sys#make-lambda-info str)
1853  (let* ((sz (##sys#size str))
1854         (info (##sys#make-string sz)) )
1855    (##core#inline "C_copy_memory" info str sz)
1856    (##core#inline "C_string_to_lambdainfo" info)
1857    info) )
Note: See TracBrowser for help on using the repository browser.