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

Last change on this file since 13677 was 13677, checked in by Kon Lovett, 11 years ago

Moved 'apropos' out. Added routines to encapsulate information the new apropos extension needs

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