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

Last change on this file since 10992 was 10992, checked in by felix winkelmann, 12 years ago

fixed eval bug reported by Owen Arden (trac ticket #436)

File size: 81.4 KB
Line 
1;;;; eval.scm - Interpreter for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, 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  (disable-warning var)
31  (hide ##sys#unregister-macro ##sys#split-at-separator
32        ##sys#r4rs-environment ##sys#r5rs-environment 
33        ##sys#interaction-environment pds pdss pxss) )
34
35#>
36#ifndef C_INSTALL_EGG_HOME
37# define C_INSTALL_EGG_HOME    "."
38#endif
39
40#ifndef C_INSTALL_SHARE_HOME
41# define C_INSTALL_SHARE_HOME NULL
42#endif
43<#
44
45(cond-expand
46 [paranoia]
47 [else
48  (declare
49    (no-bound-checks)
50    (no-procedure-checks-for-usual-bindings)
51    (bound-to-procedure 
52     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#load-library
53     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#not-a-proper-list-error
54     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round 
55     ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
56     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure 
57     ##sys#make-structure ##sys#feature? ##sys#interpreter-toplevel-macroexpand-hook
58     ##sys#error-handler ##sys#hash-symbol ##sys#register-macro ##sys#check-syntax
59     ##sys#hash-table-ref ##sys#hash-table-set! ##sys#canonicalize-body ##sys#decompose-lambda-list
60     ##sys#make-c-string ##sys#resolve-include-filename ##sys#register-macro-2 
61     ##sys#load ##sys#error ##sys#warn ##sys#hash-table-location ##sys#expand-home-path
62     ##sys#make-flonum ##sys#make-pointer ##sys#null-pointer ##sys#address->pointer 
63     ##sys#pointer->address ##sys#compile-to-closure ##sys#make-string ##sys#make-lambda-info
64     ##sys#number? ##sys#symbol->qualified-string ##sys#decorate-lambda ##sys#string-append
65     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
66     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator ##sys#alias-global-hook
67     open-output-string get-output-string make-parameter software-type software-version machine-type
68     build-platform getenv set-extensions-specifier! ##sys#string->symbol list->vector
69     extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
70     ##sys#match-expression vector->list store-string open-input-string eval ##sys#gc
71     with-exception-handler print-error-message read-char read ##sys#read-error
72     ##sys#reset-handler call-with-current-continuation ##sys#peek-char-0 ##sys#read-char-0
73     ##sys#clear-trace-buffer ##sys#write-char-0 print-call-chain ##sys#with-print-length-limit
74     repl-prompt ##sys#flush-output ##sys#extended-lambda-list? keyword? get-line-number
75     symbol->string string-append display ##sys#repository-path ##sys#file-info make-vector
76     ##sys#make-vector string-copy vector->list ##sys#do-the-right-thing ##sys#->feature-id
77     ##sys#extension-information ##sys#symbol->string ##sys#canonicalize-extension-path
78     file-exists? ##sys#load-extension ##sys#find-extension ##sys#substring reverse
79     dynamic-load-libraries ##sys#string->c-identifier load-verbose ##sys#load ##sys#get-keyword
80     port? ##sys#file-info ##sys#signal-hook ##sys#dload open-input-file close-input-port
81     read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
82     map string->keyword ##sys#abort
83     ##sys#macroexpand-0 ##sys#macroexpand-1-local ##sys#hash-table-update!) ) ] )
84
85(cond-expand
86 [unsafe
87  (eval-when (compile)
88    (define-macro (##sys#check-structure . _) '(##core#undefined))
89    (define-macro (##sys#check-range . _) '(##core#undefined))
90    (define-macro (##sys#check-pair . _) '(##core#undefined))
91    (define-macro (##sys#check-list . _) '(##core#undefined))
92    (define-macro (##sys#check-symbol . _) '(##core#undefined))
93    (define-macro (##sys#check-string . _) '(##core#undefined))
94    (define-macro (##sys#check-char . _) '(##core#undefined))
95    (define-macro (##sys#check-exact . _) '(##core#undefined))
96    (define-macro (##sys#check-port . _) '(##core#undefined))
97    (define-macro (##sys#check-number . _) '(##core#undefined))
98    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
99 [else
100  (declare (emit-exports "eval.exports"))])
101
102
103(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
104(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
105
106(define ##sys#core-library-modules
107  '(extras lolevel utils tcp regex regex-extras posix match
108    data-structures ports srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69))
109
110(define ##sys#explicit-library-modules '())
111
112(define-constant macro-table-size 301)
113(define-constant default-dynamic-load-libraries '("libchicken"))
114(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
115(define-constant macosx-load-library-extension ".dylib")
116(define-constant windows-load-library-extension ".dll")
117(define-constant hppa-load-library-extension ".sl")
118(define-constant default-load-library-extension ".so")
119(define-constant environment-table-size 301)
120(define-constant source-file-extension ".scm")
121(define-constant setup-file-extension "setup-info")
122(define-constant repository-environment-variable "CHICKEN_REPOSITORY")
123(define-constant prefix-environment-variable "CHICKEN_PREFIX")
124(define-constant special-syntax-files '(chicken-ffi-macros chicken-more-macros))
125(define-constant default-binary-version 3)
126
127; these are actually in unit extras, but that is used by default
128; srfi-12 in unit library
129(define-constant builtin-features
130  '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39) )
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 (getenv prefix-environment-variable)))
137                  (##sys#string-append 
138                   p
139                   (if (memq (string-ref p (fx- (##sys#size p) 1)) '(#\\ #\/))
140                       "" "/") ) ) ) )
141    (lambda (#!optional dir)
142      (and prefix
143           (if dir (##sys#string-append prefix dir) prefix) ) ) ) )
144         
145
146;;; System settings
147
148(define chicken-home
149  (let ([getenv getenv])
150    (lambda ()
151      (or (##sys#chicken-prefix "share/chicken")
152          installation-home) ) ) )
153
154
155;;; Macro handling:
156
157(define ##sys#macro-environment (make-vector macro-table-size '()))
158
159(define (##sys#register-macro-2 name handler)
160  (##sys#hash-table-set! 
161   ##sys#macro-environment name
162   (lambda (form) (handler (##sys#slot form 1))) ) )
163
164(define ##sys#register-macro
165  (lambda (name handler)
166    (##sys#hash-table-set! 
167     ##sys#macro-environment name
168     (lambda (form) (apply handler (##sys#slot form 1))) ) ) )
169
170(define (##sys#copy-macro old new)
171  (##sys#hash-table-set! ##sys#macro-environment new (##sys#hash-table-ref ##sys#macro-environment old)) )
172
173(define (macro? sym)
174  (##sys#check-symbol sym 'macro?)
175  (and (##sys#hash-table-ref ##sys#macro-environment sym) #t) )
176
177(define (##sys#unregister-macro name)
178  (##sys#hash-table-set! ##sys#macro-environment name #f) )
179
180(define (undefine-macro! name)
181  (##sys#check-symbol name 'undefine-macro!)
182  (##sys#unregister-macro name) )
183
184
185;; The basic macro-expander
186
187(define ##sys#macroexpand-0
188  (let ([string-append string-append])
189    (lambda (exp me)
190
191      (define (call-handler name handler exp)
192        (handle-exceptions ex
193            (##sys#abort
194             (if (and (##sys#structure? ex 'condition)
195                      (memv 'exn (##sys#slot ex 1)) )
196                 (##sys#make-structure
197                  'condition
198                  (##sys#slot ex 1)
199                  (let copy ([ps (##sys#slot ex 2)])
200                    (if (null? ps)
201                        '()
202                        (let ([p (car ps)]
203                              [r (cdr ps)])
204                          (if (and (equal? '(exn . message) p)
205                                   (pair? r)
206                                   (string? (car r)) )
207                              (cons
208                               '(exn . message)
209                               (cons (string-append
210                                      "during expansion of (" (##sys#slot name 1) " ...) - "
211                                      (car r) )
212                                     (cdr r) ) )
213                              (copy r) ) ) ) ) )
214                 ex) )
215          (handler exp) ) )
216                                   
217      (define (expand exp head)
218        (cond [(assq head me) => (lambda (mdef) (values ((##sys#slot mdef 1) exp) #t))]
219              [(##sys#hash-table-ref ##sys#macro-environment head) 
220               => (lambda (handler)
221                    (cond-expand
222                     [unsafe (values (call-handler head handler exp) #t)]
223                     [else
224                      (let scan ([x exp])
225                        (cond [(null? x) (values (call-handler head handler exp) #t)]
226                              [(pair? x) (scan (##sys#slot x 1))]
227                              [else (##sys#syntax-error-hook "invalid syntax in macro form" exp)] ) ) ] ) ) ]
228              [else (values exp #f)] ) )
229
230      (if (pair? exp)
231          (let ([head (##sys#slot exp 0)]
232                [body (##sys#slot exp 1)] )
233            (if (symbol? head)
234                (cond [(eq? head 'let)
235                       (##sys#check-syntax 'let body '#(_ 2))
236                       (let ([bindings (car body)])
237                         (cond [(symbol? bindings)
238                                (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)))
239                                (let ([bs (cadr body)])
240                                  (values
241                                   `(##core#app
242                                     (letrec ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
243                                       ,bindings)
244                                     ,@(##sys#map cadr bs) )
245                                   #t) ) ]
246                               [else (values exp #f)] ) ) ]
247                      [(and (memq head '(set! ##core#set!))
248                            (pair? body)
249                            (pair? (##sys#slot body 0)) )
250                       (let ([dest (##sys#slot body 0)])
251                         (##sys#check-syntax 'set! body '(#(_ 1) _))
252                         (values
253                          (append (list (list '##sys#setter (##sys#slot dest 0)))
254                                  (##sys#slot dest 1)
255                                  (##sys#slot body 1) ) 
256                          #t) ) ]
257                      [else (expand exp head)] )
258                (values exp #f) ) )
259          (values exp #f) ) ) ) )
260
261
262;;; These are needed to hook other module/macro systems into the evaluator and compiler
263
264(define (##sys#compiler-toplevel-macroexpand-hook exp) exp)
265(define (##sys#interpreter-toplevel-macroexpand-hook exp) exp)
266(define (##sys#macroexpand-1-local exp me) (##sys#macroexpand-0 exp me))
267
268
269;;; For the compiler
270
271(define ##sys#enable-runtime-macros #f)
272
273
274;;; User-level macroexpansion
275
276(define (macroexpand exp . me)
277  (let ((me (if (pair? me) (car me) '())))
278    (let loop ([exp exp])
279      (let-values ([(exp2 m) (##sys#macroexpand-0 exp me)])
280        (if m
281            (loop exp2)
282            exp2) ) ) ) )
283
284(define (macroexpand-1 exp . me)
285  (##sys#macroexpand-0 exp (if (pair? me) (car me) '())) )
286
287
288;;; Extended (DSSSL-style) lambda lists
289;
290; Assumptions:
291;
292; 1) #!rest must come before #!key
293; 2) default values may refer to earlier variables
294; 3) optional/key args may be either variable or (variable default)
295; 4) an argument marker may not be specified more than once
296; 5) no special handling of extra keywords (no error)
297; 6) default value of optional/key args is #f
298; 7) mixing with dotted list syntax is allowed
299
300(define (##sys#extended-lambda-list? llist)
301  (let loop ([llist llist])
302    (and (pair? llist)
303         (case (##sys#slot llist 0)
304           [(#!rest #!optional #!key) #t]
305           [else (loop (##sys#slot llist 1))] ) ) ) )
306
307(define ##sys#expand-extended-lambda-list
308  (let ([reverse reverse]
309        [gensym gensym] )
310    (lambda (llist0 body errh)
311      (define (err msg) (errh msg llist0))
312      (define (->keyword s) (string->keyword (##sys#slot s 1)))
313      (let ([rvar #f]
314            [hasrest #f] )
315        (let loop ([mode 0]             ; req, opt, rest, key, end
316                   [req '()]
317                   [opt '()]
318                   [key '()] 
319                   [llist llist0] )
320          (cond [(null? llist)
321                 (values
322                  (if rvar (##sys#append (reverse req) rvar) (reverse req))
323                  (let ([body 
324                         (if (null? key)
325                             body
326                             `((let* ,(map (lambda (k)
327                                             (let ([s (car k)])
328                                               `[,s (##sys#get-keyword 
329                                                     ',(->keyword s) ,rvar
330                                                     ,@(if (pair? (cdr k)) 
331                                                           `((lambda () ,@(cdr k)))
332                                                           '() ) ) ] ) )
333                                           (reverse key) )
334                                 ,@body) ) ) ] )
335                    (cond [(null? opt) body]
336                          [(and (not hasrest) (null? key) (null? (cdr opt)))
337                           `((let ([,(caar opt) (:optional ,rvar ,(cadar opt))])
338                               ,@body) ) ]
339                          [(and (not hasrest) (null? key)) `((let-optionals ,rvar ,(reverse opt) ,@body))]
340                          [else
341                           `((let-optionals* ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar))) 
342                              ,@body))] ) ) ) ]
343                [(symbol? llist) 
344                 (if (fx> mode 2)
345                     (err "rest argument list specified more than once")
346                     (begin
347                       (if (not rvar) (set! rvar llist))
348                       (set! hasrest llist)
349                       (loop 4 req opt '() '()) ) ) ]
350                [(not (pair? llist))
351                 (err "invalid lambda list syntax") ]
352                [else
353                 (let ([x (##sys#slot llist 0)]
354                       [r (##sys#slot llist 1)])
355                   (case x
356                     [(#!optional)
357                      (if (not rvar) (set! rvar (gensym)))
358                      (if (eq? mode 0)
359                          (loop 1 req '() '() r)
360                          (err "`#!optional' argument marker in wrong context") ) ]
361                     [(#!rest)
362                      (if (fx<= mode 1)
363                          (if (and (pair? r) (symbol? (##sys#slot r 0)))
364                              (begin
365                                (if (not rvar) (set! rvar (##sys#slot r 0)))
366                                (set! hasrest (##sys#slot r 0))
367                                (loop 2 req opt '() (##sys#slot r 1)) )
368                              (err "invalid syntax of `#!rest' argument") ) 
369                          (err "`#!rest' argument marker in wrong context") ) ]
370                     [(#!key)
371                      (if (not rvar) (set! rvar (gensym)))
372                      (if (fx<= mode 3)
373                          (loop 3 req opt '() r)
374                          (err "`#!key' argument marker in wrong context") ) ]
375                     [else
376                      (cond [(symbol? x)
377                             (case mode
378                               [(0) (loop 0 (cons x req) '() '() r)]
379                               [(1) (loop 1 req (cons (list x #f) opt) '() r)]
380                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
381                               [else (loop 3 req opt (cons (list x) key) r)] ) ]
382                            [(and (list? x) (eq? 2 (length x)))
383                             (case mode
384                               [(0) (err "invalid required argument syntax")]
385                               [(1) (loop 1 req (cons x opt) '() r)]
386                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
387                               [else (loop 3 req opt (cons x key) r)] ) ]
388                            [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )
389
390
391;;; Expansion of bodies (and internal definitions)
392
393(define ##sys#canonicalize-body
394  (let ([reverse reverse]
395        [map map] )
396    (lambda (body lookup #!optional me container)
397      (define (fini vars vals mvars mvals body)
398        (if (and (null? vars) (null? mvars))
399            (let loop ([body2 body] [exps '()])
400              (if (not (pair? body2)) 
401                  `(begin ,@body) ; no more defines, otherwise we would have called `expand'
402                  (let ([x (##sys#slot body2 0)])
403                    (if (and (pair? x) (memq (##sys#slot x 0) `(define define-values)))
404                        `(begin . ,(##sys#append (reverse exps) (list (expand body2))))
405                        (loop (##sys#slot body2 1) (cons x exps)) ) ) ) )
406            (let ([vars (reverse vars)])
407              `(let ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined))) 
408                                (apply ##sys#append vars mvars) )
409                 ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
410                 ,@(map (lambda (vs x)
411                          (let ([tmps (##sys#map gensym vs)])
412                            `(##sys#call-with-values
413                              (lambda () ,x)
414                              (lambda ,tmps 
415                                ,@(map (lambda (v t) `(##core#set! ,v ,t)) vs tmps) ) ) ) ) 
416                        (reverse mvars)
417                        (reverse mvals) )
418                 ,@body) ) ) )
419      (define (expand body)
420        (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
421          (if (not (pair? body))
422              (fini vars vals mvars mvals body)
423              (let* ([x (##sys#slot body 0)]
424                     [rest (##sys#slot body 1)] 
425                     [head (and (pair? x) (##sys#slot x 0))] )
426                (cond [(not head) (fini vars vals mvars mvals body)]
427                      [(and (symbol? head) (lookup head))
428                       (fini vars vals mvars mvals body) ]
429                      [(eq? 'define head)
430                       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f)
431                       (let loop2 ([x x])
432                         (let ([head (cadr x)])
433                           (cond [(not (pair? head))
434                                  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f)
435                                  (loop rest (cons head vars)
436                                        (cons (if (pair? (cddr x))
437                                                  (caddr x)
438                                                  '(##sys#void) )
439                                              vals)
440                                        mvars mvals) ]
441                                 [(pair? (##sys#slot head 0))
442                                  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f)
443                                  (loop2 (cons 'define (##sys#expand-curried-define head (cddr x)))) ]
444                                 [else
445                                  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f)
446                                  (loop rest
447                                        (cons (##sys#slot head 0) vars)
448                                        (cons `(lambda ,(##sys#slot head 1) ,@(cddr x)) vals)
449                                        mvars mvals) ] ) ) ) ]
450                      [(eq? 'define-values head)
451                       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f)
452                       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
453                      [(eq? 'begin head)
454                       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
455                       (loop (##sys#append (##sys#slot x 1) rest) vars vals mvars mvals) ]
456                      [else
457                       (let ([x2 (##sys#macroexpand-0 x me)])
458                         (if (eq? x x2)
459                             (fini vars vals mvars mvals body)
460                             (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
461      (expand body) ) ) )
462
463
464;;; A simple expression matcher
465
466(define ##sys#match-expression
467  (lambda (exp pat vars)
468    (let ((env '()))
469      (define (mwalk x p)
470        (cond ((or (not (##core#inline "C_blockp" p)) (not (##core#inline "C_pairp" p)))
471               (cond ((assq p env) => (lambda (a) (equal? x (##sys#slot a 1))))
472                     ((memq p vars)
473                      (set! env (cons (cons p x) env))
474                      #t)
475                     (else (eq? x p)) ) )
476              ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x))) #f)
477              ((mwalk (##sys#slot x 0) (##sys#slot p 0))
478               (mwalk (##sys#slot x 1) (##sys#slot p 1)) )
479              (else #f) ) )
480      (and (mwalk exp pat) env) ) ) )
481
482
483;;; Expand "curried" lambda-list syntax for `define'
484
485(define (##sys#expand-curried-define head body)
486  (let* ([name #f])
487    (define (loop head body)
488      (if (symbol? (##sys#slot head 0))
489          (begin
490            (set! name (##sys#slot head 0))
491            `(lambda ,(##sys#slot head 1) ,@body) )
492          (loop (##sys#slot head 0) `((lambda ,(##sys#slot head 1) ,@body)) ) ))
493    (let ([exp (loop head body)])
494      (list name exp) ) ) )
495
496
497;;; Lo-level hashtable support:
498
499;; Note:
500;;
501;; - Keys are compared using 'eq?'.
502;; - The fixed "not found" value is #f. So booleans as values are suspect.
503
504(define ##sys#hash-symbol
505  (let ([cache-s #f]
506        [cache-h #f] )
507    (lambda (s n)
508      (if (eq? s cache-s)
509          (##core#inline "C_fixnum_modulo" cache-h n)
510          (let ([h (##core#inline "C_hash_string" (##sys#slot s 1))])
511            (set! cache-s s)
512            (set! cache-h h)
513            (##core#inline "C_fixnum_modulo" h n) ) ) ) ) )
514
515(define (##sys#hash-table-ref ht key)
516  (let ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht))))
517    (let loop ((bucket (##sys#slot ht k)))
518      (if (eq? bucket '())
519          #f
520          (let ((b (##sys#slot bucket 0)))
521            (if (eq? key (##sys#slot b 0))
522                (##sys#slot b 1)
523                (loop (##sys#slot bucket 1)) ) ) ) ) ) )
524
525(define (##sys#hash-table-set! ht key val)
526  (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
527         (bucket0 (##sys#slot ht k)) )
528    (let loop ((bucket bucket0))
529      (if (eq? bucket '())
530          (##sys#setslot ht k (cons (cons key val) bucket0))
531          (let ((b (##sys#slot bucket 0)))
532            (if (eq? key (##sys#slot b 0))
533                (##sys#setslot b 1 val)
534                (loop (##sys#slot bucket 1)) ) ) ) ) ) )
535
536(define (##sys#hash-table-update! ht key updtfunc valufunc)
537  (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) )
538
539(define (##sys#hash-table-for-each p ht)
540  (let ((len (##core#inline "C_block_size" ht)))
541    (do ((i 0 (fx+ i 1)))
542        ((fx>= i len))
543      (##sys#for-each (lambda (bucket) 
544                        (p (##sys#slot bucket 0) (##sys#slot bucket 1) ) )
545                      (##sys#slot ht i) ) ) ) )
546
547(define (##sys#hash-table->alist ht)
548  (let ([len (##core#inline "C_block_size" ht)] )
549    (let loop ([i 0] [lst '()])
550      (if (fx>= i len)
551          lst
552          (let loop2 ([bucket (##sys#slot vec i)]
553                      [lst lst])
554            (if (null? bucket)
555                (loop (fx+ i 1) lst)
556                (loop2 (##sys#slot bucket 1)
557                       (let ([x (##sys#slot bucket 0)])
558                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
559
560(define ##sys#hash-table-location
561  (let ([unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)])
562    (lambda (ht key addp)
563      (let* ([k (##sys#hash-symbol key (##sys#size ht))]
564             [bucket0 (##sys#slot ht k)] )
565        (let loop ([bucket bucket0])
566          (if (null? bucket)
567              (and addp
568                   (let ([p (vector key unbound #t)])
569                     (##sys#setslot ht k (cons p bucket0))
570                     p) )
571              (let ([b (##sys#slot bucket 0)])
572                (if (eq? key (##sys#slot b 0))
573                    b
574                    (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )
575
576
577;;; Compile lambda to closure:
578
579(define ##sys#eval-environment #f)
580(define ##sys#environment-is-mutable #f)
581
582(define (##sys#eval-decorator p ll h cntr)
583  (##sys#decorate-lambda
584   p 
585   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
586   (lambda (p i)
587     (##sys#setslot 
588      p i 
589      (##sys#make-lambda-info 
590       (let ((o (open-output-string)))
591         (write ll o)
592         (get-output-string o))))
593     p) ) )
594
595(define ##sys#unbound-in-eval #f)
596(define ##sys#eval-debug-level 1)
597(define (##sys#alias-global-hook s) s)
598
599(define ##sys#compile-to-closure
600  (let ([macro? macro?]
601        [write write]
602        [cadadr cadadr]
603        [reverse reverse]
604        [open-output-string open-output-string]
605        [get-output-string get-output-string] 
606        [with-input-from-file with-input-from-file]
607        [unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
608        [display display] )
609    (lambda (exp env me . cntr)
610
611      (define (lookup var e)
612        (let loop ((envs e) (ei 0))
613          (cond ((null? envs) (values #f var))
614                ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
615                (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) )
616
617      (define (defined? var e)
618        (receive (i j) (lookup var e) i) )
619
620      (define (undefine vars e)
621        (let loop ([envs e])
622          (if (null? envs)
623              '()
624              (let ([envi (##sys#slot envs 0)])
625                (cons
626                 (let delq ([ee envi])
627                   (if (null? ee)
628                       '()
629                       (let ([h (##sys#slot ee 0)]
630                             [r (##sys#slot ee 1)] )
631                         (if (memq h vars)
632                             r
633                             (cons h (delq r)) ) ) ) )
634                 (loop (##sys#slot envs 1)) ) ) ) ) )
635
636      (define (posq x lst)
637        (let loop ((lst lst) (i 0))
638          (cond ((null? lst) #f)
639                ((eq? x (##sys#slot lst 0)) i)
640                (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
641
642      (define (macroexpand-1-checked x e)
643        (let ([x2 (##sys#macroexpand-1-local x '())])
644          (if (pair? x2)
645              (let ([h (##sys#slot x2 0)])
646                (if (and (eq? h 'let) (not (defined? 'let e)))
647                    (let ([next (##sys#slot x2 1)])
648                      (if (and (pair? next) (symbol? (##sys#slot next 0)))
649                          (macroexpand-1-checked x2 e)
650                          x2) )
651                    x2) )
652              x2) ) )
653
654      (define (emit-trace-info tf info cntr) 
655        (when tf
656          (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )
657
658      (define (emit-syntax-trace-info tf info cntr) 
659        (when tf
660          (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
661       
662      (define (decorate p ll h cntr)
663        (##sys#eval-decorator p ll h cntr) )
664
665      (define (compile x e h tf cntr)
666        (cond [(symbol? x)
667               (receive (i j) (lookup x e)
668                 (cond [(not i)
669                        (let ((x (##sys#alias-global-hook x)))
670                          (if ##sys#eval-environment
671                              (let ([loc (##sys#hash-table-location ##sys#eval-environment x #t)])
672                                (unless loc (##sys#syntax-error-hook "reference to undefined identifier" x))
673                                (cond-expand 
674                                 [unsafe (lambda v (##sys#slot loc 1))]
675                                 [else
676                                  (lambda v 
677                                    (let ([val (##sys#slot loc 1)])
678                                      (if (eq? unbound val)
679                                          (##sys#error "unbound variable" x)
680                                          val) ) ) ] ) )
681                              (cond-expand
682                               [unsafe (lambda v (##core#inline "C_slot" x 0))]
683                               [else
684                                (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? x)))
685                                  (set! ##sys#unbound-in-eval (cons (cons x cntr) ##sys#unbound-in-eval)) )
686                                (lambda v (##core#inline "C_retrieve" x))] ) ) ) ]
687                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
688                       [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) ]
689              [(##sys#number? x)
690               (case x
691                 [(-1) (lambda v -1)]
692                 [(0) (lambda v 0)]
693                 [(1) (lambda v 1)]
694                 [(2) (lambda v 2)]
695                 [else (lambda v x)] ) ]
696              [(boolean? x)
697               (if x
698                   (lambda v #t)
699                   (lambda v #f) ) ]
700              [(or (char? x)
701                   (eof-object? x)
702                   (string? x) )
703               (lambda v x) ]
704              [(not (pair? x)) (##sys#syntax-error-hook "illegal non-atomic object" x)]
705              [(symbol? (##sys#slot x 0))
706               (emit-syntax-trace-info tf x cntr)
707               (let ([head (##sys#slot x 0)])
708                 (if (defined? head e)
709                     (compile-call x e tf cntr)
710                     (let ([x2 (macroexpand-1-checked x e)])
711                       (if (eq? x2 x)
712                           (case head
713
714                             [(quote)
715                              (##sys#check-syntax 'quote x '(quote _) #f)
716                              (let* ([c (cadr x)])
717                                (case c
718                                  [(-1) (lambda v -1)]
719                                  [(0) (lambda v 0)]
720                                  [(1) (lambda v 1)]
721                                  [(2) (lambda v 2)]
722                                  [(#t) (lambda v #t)]
723                                  [(#f) (lambda v #f)]
724                                  [(()) (lambda v '())]
725                                  [else (lambda v c)] ) ) ]
726
727                             [(##core#global-ref)
728                              (let ([var (cadr x)])
729                                (if ##sys#eval-environment
730                                    (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
731                                      (lambda v (##sys#slot loc 1)) )
732                                    (lambda v (##core#inline "C_slot" var 0)) ) ) ]
733
734                             [(##core#check)
735                              (compile (cadr x) e h tf cntr) ]
736
737                             [(##core#immutable)
738                              (compile (cadr x) e #f tf cntr) ]
739                   
740                             [(##core#undefined) (lambda (v) (##core#undefined))]
741
742                             [(if)
743                              (##sys#check-syntax 'if x '(if _ _ . #(_)) #f)
744                              (let* ([test (compile (cadr x) e #f tf cntr)]
745                                     [cns (compile (caddr x) e #f tf cntr)]
746                                     [alt (if (pair? (cdddr x))
747                                              (compile (cadddr x) e #f tf cntr)
748                                              (compile '(##core#undefined) e #f tf cntr) ) ] )
749                                (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
750
751                             [(begin)
752                              (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
753                              (let* ([body (##sys#slot x 1)]
754                                     [len (length body)] )
755                                (case len
756                                  [(0) (compile '(##core#undefined) e #f tf cntr)]
757                                  [(1) (compile (##sys#slot body 0) e #f tf cntr)]
758                                  [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr)]
759                                              [x2 (compile (cadr body) e #f tf cntr)] )
760                                         (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
761                                  [else
762                                   (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr)]
763                                          [x2 (compile (cadr body) e #f tf cntr)] 
764                                          [x3 (compile `(begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr)] )
765                                     (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
766
767                             [(set! ##core#set!)
768                              (##sys#check-syntax 'set! x '(_ variable _) #f)
769                              (let ((var (cadr x)))
770                                (receive (i j) (lookup var e)
771                                  (let ((val (compile (caddr x) e var tf cntr)))
772                                    (cond [(not i)
773                                           (let ([var (##sys#alias-global-hook var)])
774                                             (if ##sys#eval-environment
775                                                 (let ([loc (##sys#hash-table-location
776                                                             ##sys#eval-environment 
777                                                             var
778                                                             ##sys#environment-is-mutable) ] )
779                                                   (unless loc (##sys#error "assignment of undefined identifier" var))
780                                                   (if (##sys#slot loc 2)
781                                                       (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
782                                                       (lambda v (##sys#error "assignment to immutable variable" var)) ) )
783                                                 (lambda (v)
784                                                   (##sys#setslot var 0 (##core#app val v))) ) ) ]
785                                          [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
786                                          [else
787                                           (lambda (v)
788                                             (##sys#setslot
789                                              (##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
790
791                             [(let)
792                              (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f)
793                              (let* ([bindings (cadr x)]
794                                     [n (length bindings)] 
795                                     [vars (map (lambda (x) (car x)) bindings)] 
796                                     [e2 (cons vars e)]
797                                     [body (##sys#compile-to-closure
798                                            (##sys#canonicalize-body (cddr x) (cut defined? <> e2) me cntr)
799                                            e2
800                                            me
801                                            cntr) ] )
802                                (case n
803                                  [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr)])
804                                         (lambda (v)
805                                           (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
806                                  [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr)]
807                                             [val2 (compile (cadadr bindings) e (cadr vars) tf cntr)] )
808                                         (lambda (v)
809                                           (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
810                                  [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr)]
811                                              [val2 (compile (cadadr bindings) e (cadr vars) tf cntr)] 
812                                              [t (cddr bindings)]
813                                              [val3 (compile (cadar t) e (caddr vars) tf cntr)] )
814                                         (lambda (v)
815                                           (##core#app 
816                                            body
817                                            (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
818                                  [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr)]
819                                              [val2 (compile (cadadr bindings) e (cadr vars) tf cntr)] 
820                                              [t (cddr bindings)]
821                                              [val3 (compile (cadar t) e (caddr vars) tf cntr)] 
822                                              [val4 (compile (cadadr t) e (cadddr vars) tf cntr)] )
823                                         (lambda (v)
824                                           (##core#app 
825                                            body
826                                            (cons (vector (##core#app val1 v)
827                                                          (##core#app val2 v)
828                                                          (##core#app val3 v)
829                                                          (##core#app val4 v))
830                                                  v)) ) ) ]
831                                  [else
832                                   (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr)) bindings)])
833                                     (lambda (v)
834                                       (let ([v2 (##sys#make-vector n)])
835                                         (do ([i 0 (fx+ i 1)]
836                                              [vlist vals (##sys#slot vlist 1)] )
837                                             ((fx>= i n))
838                                           (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
839                                         (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
840
841                             [(lambda)
842                              (##sys#check-syntax 'lambda x '(lambda lambda-list . #(_ 1)) #f)
843                              (let* ([llist (cadr x)]
844                                     [body (cddr x)] 
845                                     [info (cons (or h '?) llist)] )
846                                (when (##sys#extended-lambda-list? llist)
847                                  (set!-values 
848                                   (llist body) 
849                                   (##sys#expand-extended-lambda-list 
850                                    llist body
851                                    ##sys#syntax-error-hook) ) ) 
852                                (##sys#decompose-lambda-list
853                                 llist
854                                 (lambda (vars argc rest)
855                                   (let* ((e2 (cons vars e))
856                                          (body 
857                                           (##sys#compile-to-closure
858                                            (##sys#canonicalize-body body (cut defined? <> e2) me (or h cntr))
859                                            e2
860                                            me
861                                            (or h cntr) ) ) )
862                                     (case argc
863                                       [(0) (if rest
864                                                (lambda (v)
865                                                  (decorate
866                                                   (lambda r
867                                                     (##core#app body (cons (vector r) v)))
868                                                   info h cntr) )
869                                                (lambda (v)
870                                                  (decorate
871                                                   (lambda () (##core#app body (cons #f v)))
872                                                   info h cntr) ) ) ]
873                                       [(1) (if rest
874                                                (lambda (v)
875                                                  (decorate
876                                                   (lambda (a1 . r)
877                                                     (##core#app body (cons (vector a1 r) v)))
878                                                   info h cntr) ) 
879                                                (lambda (v)
880                                                  (decorate 
881                                                   (lambda (a1)
882                                                     (##core#app body (cons (vector a1) v)))
883                                                   info h cntr) ) ) ]
884                                       [(2) (if rest
885                                                (lambda (v) 
886                                                  (decorate
887                                                   (lambda (a1 a2 . r)
888                                                     (##core#app body (cons (vector a1 a2 r) v)))
889                                                   info h cntr) )
890                                                (lambda (v)
891                                                  (decorate
892                                                   (lambda (a1 a2)
893                                                     (##core#app body (cons (vector a1 a2) v)))
894                                                   info h cntr) ) ) ]
895                                       [(3) (if rest
896                                                (lambda (v) 
897                                                  (decorate
898                                                   (lambda (a1 a2 a3 . r)
899                                                     (##core#app body (cons (vector a1 a2 a3 r) v)))
900                                                   info h cntr) )
901                                                (lambda (v)
902                                                  (decorate
903                                                   (lambda (a1 a2 a3)
904                                                     (##core#app body (cons (vector a1 a2 a3) v)))
905                                                   info h cntr) ) ) ]
906                                       [(4) (if rest
907                                                (lambda (v)
908                                                  (decorate
909                                                   (lambda (a1 a2 a3 a4 . r)
910                                                     (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
911                                                   info h cntr) )
912                                                (lambda (v)
913                                                  (decorate
914                                                   (lambda (a1 a2 a3 a4)
915                                                     (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
916                                                   info h cntr) ) ) ]
917                                       [else
918                                        (if rest
919                                            (lambda (v)
920                                              (decorate
921                                               (lambda as
922                                                 (##core#app
923                                                  body
924                                                  (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
925                                               info h cntr) )
926                                            (lambda (v)
927                                              (decorate
928                                               (lambda as 
929                                                 (let ([len (length as)])
930                                                   (if (not (fx= len argc))
931                                                       (##sys#error "bad argument count" argc len)
932                                                       (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
933                                               info h cntr) ) ) ] ) ) ) ) ) ]
934                               
935                             [(##core#loop-lambda)
936                              (compile `(lambda ,@(cdr x)) e #f tf cntr) ]
937
938                             [(##core#named-lambda)
939                              (compile `(lambda ,@(cddr x)) e (cadr x) tf cntr) ]
940
941                             [(##core#require-for-syntax)
942                              (let ([ids (map (lambda (x) ((##sys#compile-to-closure x '() '()) '() #f)) (cdr x))])
943                                (apply ##sys#require ids)
944                                (let ([rs (##sys#lookup-runtime-requirements ids)])
945                                  (compile
946                                   (if (null? rs)
947                                       '(##core#undefined)
948                                       `(##sys#require ,@(map (lambda (x) `',x) rs)) )
949                                   e #f tf cntr) ) ) ]
950
951                             [(##core#require-extension)
952                              (compile
953                               (let loop ([ids (cdr x)])
954                                 (if (null? ids)
955                                     '(##core#undefined)
956                                     (let-values ([(exp _) (##sys#do-the-right-thing (cadar ids) #f)])
957                                       `(begin ,exp ,(loop (cdr ids))) ) ) )
958                               e #f tf cntr) ]
959
960                             [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
961                              (##core#app (##sys#compile-to-closure (cadr x) '() '() #f) '())
962                              (compile '(##core#undefined) e #f tf cntr) ]
963
964                             [(##core#compiletimetoo)
965                              (compile (cadr x) e #f tf cntr) ]
966
967                             [(##core#compiletimeonly ##core#callunit) 
968                              (compile '(##core#undefined) e #f tf cntr) ]
969
970                             [(##core#declare)
971                              (if (memq #:compiling ##sys#features)
972                                  (for-each (lambda (d) (##compiler#process-declaration (cadr d))) (cdr x)) 
973                                  (##sys#warn "declarations are ignored in interpreted code" x) )
974                              (compile '(##core#undefined) e #f tf cntr) ]
975
976                             [(##core#define-inline ##core#define-constant)
977                              (compile `(set! ,(cadadr x) ,@(cddr x)) e #f tf cntr) ]
978                   
979                             [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
980                                                ##core#define-foreign-variable 
981                                                ##core#define-external-variable ##core#let-location
982                                                ##core#foreign-primitive
983                                                ##core#foreign-lambda* ##core#define-foreign-type)
984                              (##sys#syntax-error-hook "can not evaluate compiler-special-form" x) ]
985
986                             [(##core#app)
987                              (compile-call (cdr x) e tf cntr) ]
988
989                             [else
990                              (cond [(eq? head 'location)
991                                     (##sys#syntax-error-hook "can not evaluate compiler-special-form" x) ]
992
993                                    [else (compile-call x e tf cntr)] ) ] )
994
995                           (compile x2 e h tf cntr) ) ) ) ) ]
996
997              [else
998               (emit-syntax-trace-info tf x cntr)
999               (compile-call x e tf cntr)] ) )
1000
1001      (define (fudge-argument-list n alst)
1002        (if (null? alst) 
1003            (list alst)
1004            (do ((n n (fx- n 1))
1005                 (c 0 (fx+ c 1))
1006                 (args alst 
1007                       (if (eq? '() args)
1008                           (##sys#error "bad argument count" n c)
1009                           (##sys#slot args 1)))
1010                 (last #f args) )
1011                ((fx= n 0)
1012                 (##sys#setslot last 1 (list args))
1013                 alst) ) ) )
1014
1015      (define (checked-length lst)
1016        (let loop ([lst lst] [n 0])
1017          (cond [(null? lst) n]
1018                [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
1019                [else #f] ) ) )
1020
1021      (define (compile-call x e tf cntr)
1022        (let* ([fn (compile (##sys#slot x 0) e #f tf cntr)]
1023               [args (##sys#slot x 1)]
1024               [argc (checked-length args)]
1025               [info x] )
1026          (case argc
1027            [(#f) (##sys#syntax-error-hook "malformed expression" x)]
1028            [(0) (lambda (v)
1029                   (emit-trace-info tf info cntr)
1030                   ((fn v)))]
1031            [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr)])
1032                   (lambda (v)
1033                     (emit-trace-info tf info cntr)
1034                     ((##core#app fn v) (##core#app a1 v))) ) ]
1035            [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr)]
1036                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr)] )
1037                   (lambda (v)
1038                     (emit-trace-info tf info cntr)
1039                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
1040            [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr)]
1041                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr)]
1042                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr)] )
1043                   (lambda (v)
1044                     (emit-trace-info tf info cntr)
1045                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
1046            [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr)]
1047                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr)]
1048                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr)] 
1049                        [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr)] )
1050                   (lambda (v)
1051                     (emit-trace-info tf info cntr)
1052                     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
1053            [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr)) args)])
1054                    (lambda (v)
1055                      (emit-trace-info tf info cntr)
1056                      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
1057
1058      (compile exp env #f (fx> ##sys#eval-debug-level 0) (:optional cntr #f)) ) ) )
1059
1060(define ##sys#eval-handler 
1061  (make-parameter
1062   (lambda (x . env)
1063     (let ([mut ##sys#environment-is-mutable]
1064           [e #f] )
1065       (when (pair? env)
1066         (let ([env (car env)])
1067           (when env
1068             (##sys#check-structure env 'environment)
1069             (set! e (##sys#slot env 1)) 
1070             (set! mut (##sys#slot env 2)) ) ) )
1071       ((fluid-let ([##sys#environment-is-mutable mut]
1072                    [##sys#eval-environment e] )
1073          (##sys#compile-to-closure x '() '()) )
1074        '() ) ) ) ) )
1075
1076(define eval-handler ##sys#eval-handler)
1077
1078(define (eval x . env)
1079  (apply (##sys#eval-handler) 
1080         (##sys#interpreter-toplevel-macroexpand-hook x)
1081         env) )
1082
1083;;; Split lambda-list into its parts:
1084
1085(define ##sys#decompose-lambda-list
1086  (let ([reverse reverse])
1087    (lambda (llist0 k)
1088
1089      (define (err)
1090        (set! ##sys#syntax-error-culprit #f)
1091        (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
1092
1093      (let loop ([llist llist0] [vars '()] [argc 0])
1094        (cond [(eq? llist '()) (k (reverse vars) argc #f)]
1095              [(not (##core#inline "C_blockp" llist)) (err)]
1096              [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
1097              [(not (##core#inline "C_pairp" llist)) (err)]
1098              [else (loop (##sys#slot llist 1)
1099                          (cons (##sys#slot llist 0) vars)
1100                          (fx+ argc 1) ) ] ) ) ) ) )
1101
1102
1103;;; Loading source/object files:
1104
1105(define load-verbose (make-parameter (##sys#fudge 13)))
1106
1107(define (##sys#abort-load) #f)
1108(define ##sys#current-source-filename #f)
1109(define ##sys#current-load-path "")
1110
1111(define-foreign-variable _dlerror c-string "C_dlerror")
1112
1113(define (set-dynamic-load-mode! mode)
1114  (let ([mode (if (pair? mode) mode (list mode))]
1115        [now #f]
1116        [global #t] )
1117    (let loop ([mode mode])
1118      (when (pair? mode)
1119        (case (##sys#slot mode 0)
1120          [(global) (set! global #t)]
1121          [(local) (set! global #f)]
1122          [(lazy) (set! now #f)]
1123          [(now) (set! now #t)]
1124          [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
1125        (loop (##sys#slot mode 1)) ) )
1126    (##sys#set-dlopen-flags! now global) ) )
1127
1128(let ([read read]
1129      [write write]
1130      [display display]
1131      [newline newline]
1132      [eval eval]
1133      [open-input-file open-input-file]
1134      [close-input-port close-input-port]
1135      [string-append string-append] 
1136      [load-verbose load-verbose]
1137      [topentry (##sys#make-c-string "C_toplevel")] )
1138  (define (has-sep? str)
1139    (let loop ([i (fx- (##sys#size str) 1)])
1140      (and (not (zero? i))
1141           (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
1142               i
1143               (loop (fx- i 1)) ) ) ) )
1144  (define (badfile x)
1145    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
1146  (set! ##sys#load 
1147    (lambda (input evaluator pf #!optional timer printer)
1148      (when (string? input) 
1149        (set! input (##sys#expand-home-path input)) )
1150      (let* ([isdir #f]
1151             [fname 
1152             (cond [(port? input) #f]
1153                   [(not (string? input)) (badfile input)]
1154                   [(and-let* ([info (##sys#file-info input)]
1155                               [id (##sys#slot info 4)] )
1156                      (set! isdir (eq? 1 id)) 
1157                      (not id) )
1158                    input]
1159                   [else
1160                    (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
1161                      (if (##sys#file-info fname2)
1162                          fname2
1163                          (let ([fname3 (##sys#string-append input source-file-extension)])
1164                            (if (##sys#file-info fname3)
1165                                fname3
1166                                (and (not isdir) input) ) ) ) ) ] ) ]
1167            [evproc (or evaluator eval)] )
1168        (cond [(and (string? input) (not fname))
1169               (##sys#signal-hook #:file-error 'load "can not open file" input) ]
1170              [(and (load-verbose) fname)
1171               (display "; loading ")
1172               (display fname)
1173               (display " ...\n") ] )
1174        (or (and fname
1175                 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
1176                     (and (not (has-sep? fname))
1177                          (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
1178            (call-with-current-continuation
1179             (lambda (abrt)
1180               (fluid-let ([##sys#read-error-with-line-number #t]
1181                           [##sys#current-source-filename fname]
1182                           [##sys#current-load-path
1183                            (and fname
1184                                 (let ((i (has-sep? fname)))
1185                                   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
1186                           [##sys#abort-load (lambda () (abrt #f))] )
1187                 (let ([in (if fname (open-input-file fname) input)])
1188                   (##sys#dynamic-wind
1189                    (lambda () #f)
1190                    (lambda ()
1191                      (let ([c1 (peek-char in)])
1192                        (when (char=? c1 (integer->char 127))
1193                          (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
1194                      (let ((x1 (read in)))
1195                        (do ((x x1 (read in)))
1196                            ((eof-object? x))
1197                          (when printer (printer x))
1198                          (##sys#call-with-values
1199                           (lambda () 
1200                             (if timer
1201                                 (time (evproc x)) 
1202                                 (evproc x) ) )
1203                           (lambda results
1204                             (when pf
1205                               (for-each
1206                                (lambda (r) 
1207                                  (write r)
1208                                  (newline) )
1209                                results) ) ) ) ) ) )
1210                    (lambda () (close-input-port in)) ) ) ) ) ) )
1211        (##core#undefined) ) ) )
1212  (set! load
1213    (lambda (filename . evaluator)
1214      (##sys#load filename (:optional evaluator #f) #f) ) )
1215  (set! load-relative
1216    (lambda (filename . evaluator)
1217      (##sys#load
1218       (if (memq (string-ref filename 0) '(#\\ #\/))
1219           filename
1220           (##sys#string-append ##sys#current-load-path filename) )
1221       (:optional evaluator #f) #f) ) )
1222  (set! load-noisily
1223    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
1224      (##sys#load filename evaluator #t time printer) ) ) )
1225
1226(define ##sys#load-library-extension    ; this is crude...
1227  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
1228        [(eq? (software-version) 'macosx) macosx-load-library-extension]
1229        [(and (eq? (software-version) 'hpux) 
1230              (eq? (machine-type) 'hppa)) hppa-load-library-extension]
1231        [else default-load-library-extension] ) )
1232
1233(define ##sys#load-dynamic-extension default-load-library-extension)
1234
1235(define ##sys#default-dynamic-load-libraries 
1236  (case (build-platform)
1237    ((cygwin) cygwin-default-dynamic-load-libraries)
1238    (else default-dynamic-load-libraries) ) )
1239
1240(define dynamic-load-libraries 
1241  (make-parameter
1242   (map (cut ##sys#string-append <> ##sys#load-library-extension) ##sys#default-dynamic-load-libraries)
1243   (lambda (x)
1244     (##sys#check-list x)
1245     x) ) )
1246
1247(define ##sys#load-library
1248  (let ([load-verbose load-verbose]
1249        [string-append string-append]
1250        [dynamic-load-libraries dynamic-load-libraries]
1251        [display display] )
1252    (lambda (uname lib)
1253      (let ([id (##sys#->feature-id uname)])
1254        (or (memq id ##sys#features)
1255            (let ([libs
1256                   (if lib
1257                       (##sys#list lib)
1258                       (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
1259                             (dynamic-load-libraries) ) ) ]
1260                  [top 
1261                   (##sys#make-c-string
1262                    (string-append
1263                     "C_"
1264                     (##sys#string->c-identifier (##sys#slot uname 1)) 
1265                     "_toplevel") ) ] )
1266              (when (load-verbose)
1267                (display "; loading library ")
1268                (display uname)
1269                (display " ...\n") )
1270              (let loop ([libs libs])
1271                (cond [(null? libs) #f]
1272                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
1273                       (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
1274                       #t]
1275                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
1276
1277(define load-library
1278  (lambda (uname . lib)
1279    (##sys#check-symbol uname 'load-library)
1280    (or (##sys#load-library uname (and (pair? lib) (car lib)))
1281        (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
1282
1283(define ##sys#split-at-separator
1284  (let ([reverse reverse] )
1285    (lambda (str sep)
1286      (let ([len (##sys#size str)])
1287        (let loop ([items '()] [i 0] [j 0])
1288          (cond [(fx>= i len)
1289                 (reverse (cons (##sys#substring str j len) items)) ]
1290                [(char=? (##core#inline "C_subchar" str i) sep)
1291                 (let ([i2 (fx+ i 1)])
1292                   (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
1293                [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
1294
1295
1296;;; Extensions:
1297
1298(define ##sys#canonicalize-extension-path
1299  (let ([string-append string-append])
1300    (lambda (id loc)
1301      (define (err) (##sys#error loc "invalid extension path" id))
1302      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
1303      (let ([p (cond [(string? id) id]
1304                     [(symbol? id) (##sys#symbol->string id)]
1305                     [(list? id) 
1306                      (let loop ([id id])
1307                        (if (null? id)
1308                            ""
1309                            (string-append
1310                             (let ([id0 (##sys#slot id 0)])
1311                               (cond [(symbol? id0) (##sys#symbol->string id0)]
1312                                     [(string? id0) id0]
1313                                     [else (err)] ) )
1314                             (if (null? (##sys#slot id 1))
1315                                 ""
1316                                 "/")
1317                             (loop (##sys#slot id 1)) ) ) ) ] ) ] )
1318        (let check ([p p])
1319          (let ([n (##sys#size p)])
1320            (cond [(fx= 0 n) (err)]
1321                  [(sep? (string-ref p 0))
1322                   (check (##sys#substring p 1 n)) ]
1323                  [(sep? (string-ref p (fx- n 1)))
1324                   (check (##sys#substring p 0 (fx- n 1))) ]
1325                  [else p] ) ) ) ) ) ) )
1326
1327(define ##sys#repository-path
1328  (make-parameter 
1329   (or (getenv repository-environment-variable)
1330       (##sys#chicken-prefix 
1331        (##sys#string-append 
1332         "lib/chicken/"
1333         (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
1334       install-egg-home) ) )
1335
1336(define repository-path ##sys#repository-path)
1337
1338(define ##sys#find-extension
1339  (let ([file-exists? file-exists?]
1340        [string-append string-append] )
1341    (lambda (p inc?)
1342        (define (check path)
1343          (let ([p0 (string-append path "/" p)])
1344            (and (or (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension))
1345                     (file-exists? (##sys#string-append p0 source-file-extension)) )
1346                 p0) ) )
1347        (let loop ([paths (##sys#append (list (##sys#repository-path))
1348                                        (if inc? (##sys#append ##sys#include-pathnames '(".")) '()) ) ] )
1349          (and (pair? paths)
1350               (let ([pa (##sys#slot paths 0)])
1351                 (or (check pa)
1352                     (loop (##sys#slot paths 1)) ) ) ) ) ) ) )
1353
1354(define ##sys#loaded-extensions '())
1355
1356(define ##sys#load-extension
1357  (let ((string->symbol string->symbol))
1358    (lambda (id loc . err?)
1359      (cond ((string? id) (set! id (string->symbol id)))
1360            (else (##sys#check-symbol id loc)) )
1361      (let ([p (##sys#canonicalize-extension-path id loc)])
1362        (cond ((member p ##sys#loaded-extensions))
1363              ((memq id ##sys#core-library-modules)
1364               (##sys#load-library id #f) )
1365              (else
1366               (let ([id2 (##sys#find-extension p #t)])
1367                 (cond (id2
1368                        (##sys#load id2 #f #f)
1369                        (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
1370                        #t)
1371                       ((:optional err? #t) (##sys#error loc "can not load extension" id))
1372                       (else #f) ) ) ) ) ) ) ) )
1373
1374(define (##sys#provide . ids)
1375  (for-each
1376   (lambda (id)
1377     (##sys#check-symbol id 'provide)
1378     (let ([p (##sys#canonicalize-extension-path id 'provide)])
1379       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
1380   ids) )
1381
1382(define provide ##sys#provide)
1383
1384(define (##sys#provided? id)
1385  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
1386       #t) )
1387
1388(define provided? ##sys#provided?)
1389
1390(define ##sys#require
1391  (lambda ids
1392    (for-each
1393     (cut ##sys#load-extension <> 'require) 
1394     ids) ) )
1395
1396(define require ##sys#require)
1397
1398(define ##sys#extension-information
1399  (let ([with-input-from-file with-input-from-file]
1400        [file-exists? file-exists?]
1401        [string-append string-append]
1402        [read read] )
1403    (lambda (id loc)
1404      (let* ((p (##sys#canonicalize-extension-path id loc))
1405             (rpath (string-append (##sys#repository-path) "/" p ".")) )
1406        (cond ((file-exists? (string-append rpath setup-file-extension))
1407               => (cut with-input-from-file <> read) )
1408              (else #f) ) ) ) ) )
1409
1410(define (extension-information ext)
1411  (##sys#extension-information ext 'extension-information) )
1412
1413(define ##sys#lookup-runtime-requirements 
1414  (let ([with-input-from-file with-input-from-file]
1415        [read read] )
1416    (lambda (ids)
1417      (let loop1 ([ids ids])
1418        (if (null? ids)
1419            '()
1420            (append
1421             (or (and-let* ([info (##sys#extension-information (car ids) #f)]
1422                            [a (assq 'require-at-runtime info)] )
1423                   (cdr a) )
1424                 '() )
1425             (loop1 (cdr ids)) ) ) ) ) ) )
1426
1427(define ##sys#do-the-right-thing
1428  (let ((vector->list vector->list))
1429    (lambda (id comp?)
1430      (define (add-req id)
1431        (when comp?
1432          (##sys#hash-table-update!
1433           ##compiler#file-requirements
1434           'syntax-requirements
1435           (cut lset-adjoin eq? <> id) 
1436           (lambda () (list id)))))
1437      (define (doit id)
1438        (cond ((or (memq id builtin-features)
1439                   (if comp?
1440                       (memq id builtin-features/compiled)
1441                       (##sys#feature? id) ) )
1442               (values '(##sys#void) #t) )
1443              ((memq id special-syntax-files)
1444               (let ((fid (##sys#->feature-id id)))
1445                 (unless (memq fid ##sys#features)
1446                   (##sys#load (##sys#resolve-include-filename (##sys#symbol->string id) #t) #f #f) 
1447                   (set! ##sys#features (cons fid ##sys#features)) )
1448                 (values '(##sys#void) #t) ) )
1449              ((memq id ##sys#core-library-modules)
1450               (values
1451                (if comp?
1452                    `(##core#declare '(uses ,id))
1453                    `(load-library ',id) )
1454                #t) )
1455              ((memq id ##sys#explicit-library-modules)
1456               (let* ((info (##sys#extension-information id 'require-extension))
1457                      (s (assq 'syntax info)))
1458                 (values
1459                  `(begin
1460                     ,@(if s `((##core#require-for-syntax ',id)) '())
1461                     ,(if comp?
1462                          `(##core#declare '(uses ,id)) 
1463                          `(load-library ',id) ) )
1464                  #t) ) )
1465              (else
1466               (let ((info (##sys#extension-information id 'require-extension)))
1467                 (cond (info
1468                        (let ((s (assq 'syntax info))
1469                              (rr (assq 'require-at-runtime info)) )
1470                          (when s (add-req id))
1471                          (values
1472                           `(begin
1473                              ,@(if s `((##core#require-for-syntax ',id)) '())
1474                              ,@(if (and (not rr) s)
1475                                   '()
1476                                   `((##sys#require
1477                                      ,@(map (lambda (id) `',id)
1478                                             (cond (rr (cdr rr))
1479                                                   (else (list id)) ) ) ) ) ) )
1480                           #t) ) )
1481                       (else
1482                        (add-req id)
1483                        (values `(##sys#require ',id) #f)) ) ) ) ) )
1484      (if (and (pair? id) (symbol? (car id)))
1485          (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
1486            (if a
1487                (let ((a ((##sys#slot a 1) id)))
1488                  (cond ((string? a) (values `(load ,a) #f))
1489                        ((vector? a) 
1490                         (let loop ((specs (vector->list a))
1491                                    (exps '())
1492                                    (f #f) )
1493                           (if (null? specs)
1494                               (values `(begin ,@(reverse exps)) f)
1495                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp?)))
1496                                 (loop (cdr specs)
1497                                       (cons exp exps)
1498                                       (or fi f) ) ) ) ) )
1499                        (else (##sys#do-the-right-thing a comp?)) ) )
1500                (##sys#error "undefined extension specifier" id) ) )
1501          (if (symbol? id)
1502              (doit id) 
1503              (##sys#error "invalid extension specifier" id) ) ) ) ) )
1504
1505(define ##sys#extension-specifiers '())
1506
1507(define (set-extension-specifier! name proc)
1508  (##sys#check-symbol name 'set-extension-specifier!)
1509  (let ([a (assq name ##sys#extension-specifiers)])
1510    (if a
1511        (let ([old (##sys#slot a 1)])
1512          (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
1513        (set! ##sys#extension-specifiers
1514          (cons (cons name (lambda (spec) (proc spec #f)))
1515                ##sys#extension-specifiers)) ) ) )
1516
1517
1518;;; SRFI-55
1519
1520(set-extension-specifier!
1521 'srfi 
1522 (let ([list->vector list->vector])
1523   (lambda (spec old)
1524     (list->vector
1525      (let loop ([ids (cdr spec)])
1526        (if (null? ids)
1527            '()
1528            (let ([id (car ids)])
1529              (##sys#check-exact id 'require-extension)
1530              (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
1531                    (loop (cdr ids)) ) ) ) ) ) ) ) )
1532
1533
1534;;; Version checking
1535
1536(set-extension-specifier!
1537 'version
1538 (lambda (spec _)
1539   (define (->string x)
1540     (cond ((string? x) x)
1541           ((symbol? x) (##sys#slot x 1))
1542           ((number? x) (##sys#number->string x))
1543           (else (error "invalid extension version" x)) ) )
1544   (match spec
1545     (('version id v)
1546      (let* ((info (extension-information id))
1547             (vv (and info (assq 'version info))) )
1548        (unless (and vv (string>=? (->string (car vv)) (->string v)))
1549          (error "installed extension does not match required version" id vv v) )
1550        id) )
1551     (_ (syntax-error 'require-extension "invalid version specification" spec)) ) ) )
1552
1553
1554;;; Convert string into valid C-identifier:
1555
1556(define ##sys#string->c-identifier
1557  (let ([string-copy string-copy])
1558    (lambda (str)
1559      (let* ([s2 (string-copy str)]
1560             [n (##sys#size s2)] )
1561        (do ([i 0 (fx+ i 1)])
1562            ((fx>= i n) s2)
1563          (let ([c (##core#inline "C_subchar" s2 i)])
1564            (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
1565              (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )
1566
1567
1568;;; Environments:
1569
1570(define ##sys#r4rs-environment (make-vector environment-table-size '()))
1571(define ##sys#r5rs-environment #f)
1572(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
1573
1574(define ##sys#copy-env-table
1575  (lambda (e mff mf . args)
1576    (let ([syms (and (pair? args) (car args))])
1577      (let* ([s (##sys#size e)]
1578             [e2 (##sys#make-vector s '())] )
1579       (do ([i 0 (fx+ i 1)])
1580           ((fx>= i s) e2)
1581         (##sys#setslot 
1582          e2 i
1583          (let copy ([b (##sys#slot e i)])
1584            (if (null? b)
1585                '()
1586                (let ([bi (##sys#slot b 0)])
1587                  (let ([sym (##sys#slot bi 0)])
1588                    (if (or (not syms) (memq sym syms))
1589                      (cons (vector
1590                              sym
1591                              (##sys#slot bi 1)
1592                              (if mff mf (##sys#slot bi 2)))
1593                            (copy (##sys#slot b 1)))
1594                      (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
1595
1596(define ##sys#environment-symbols
1597  (lambda (env . args)
1598    (##sys#check-structure env 'environment)
1599    (let ([pred (and (pair? args) (car args))])
1600      (let ([envtbl (##sys#slot env 1)])
1601        (if envtbl
1602            ;then "real" environment
1603          (let ([envtblsiz (vector-length envtbl)])
1604            (do ([i 0 (fx+ i 1)]
1605                 [syms
1606                   '()
1607                   (let loop ([bucket (vector-ref envtbl i)] [syms syms])
1608                     (if (null? bucket)
1609                       syms
1610                       (let ([sym (vector-ref (car bucket) 0)])
1611                         (if (or (not pred) (pred sym))
1612                           (loop (cdr bucket) (cons sym syms))
1613                           (loop (cdr bucket) syms) ) ) ) )])
1614                ((fx>= i envtblsiz) syms) ) )
1615            ;else interaction-environment
1616          (let ([syms '()])
1617            (##sys#walk-namespace
1618              (lambda (sym)
1619                (when (or (not pred) (pred sym))
1620                  (set! syms (cons sym syms)) ) ) )
1621            syms ) ) ) ) ) )
1622
1623(define (interaction-environment) ##sys#interaction-environment)
1624
1625(define scheme-report-environment
1626  (lambda (n . mutable)
1627    (##sys#check-exact n 'scheme-report-environment)
1628    (let ([mf (and (pair? mutable) (car mutable))])
1629      (case n
1630        [(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
1631        [(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
1632        [else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )
1633
1634(define null-environment
1635  (let ([make-vector make-vector])
1636    (lambda (n . mutable)
1637      (##sys#check-exact n 'null-environment)
1638      (when (or (fx< n 4) (fx> n 5))
1639        (##sys#error 'null-environment "no support for version" n) )
1640      (##sys#make-structure
1641       'environment
1642       (make-vector environment-table-size '())
1643       (and (pair? mutable) (car mutable)) ) ) ) )
1644
1645(let ()
1646  (define (initb ht) 
1647    (lambda (b)
1648      (let ([loc (##sys#hash-table-location ht b #t)])
1649        (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
1650  (for-each
1651   (initb ##sys#r4rs-environment)
1652   '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
1653     cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
1654     cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
1655     append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
1656     number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
1657     max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
1658     exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
1659     string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
1660     char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
1661     char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
1662     string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
1663     make-string string-length string-ref string-set! string-append string-copy string->list 
1664     list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
1665     vector-length vector->list list->vector vector-fill! procedure? map for-each apply force 
1666     call-with-current-continuation input-port? output-port? current-input-port current-output-port
1667     call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
1668     close-output-port load read eof-object? read-char peek-char
1669     write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
1670     ##sys#values ##sys#dynamic-wind ##sys#void
1671     ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
1672  (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
1673  (for-each
1674   (initb ##sys#r5rs-environment)
1675   '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )
1676
1677
1678;;; Find included file:
1679
1680(define ##sys#include-pathnames 
1681  (let ((h (chicken-home)))
1682    (if h (list h) '())) )
1683
1684(define ##sys#resolve-include-filename
1685  (let ((string-append string-append) )
1686    (define (exists? fname)
1687      (let ([info (##sys#file-info fname)])
1688        (and info (not (eq? 1 (##sys#slot info 4)))) ) )
1689    (lambda (fname prefer-source #!optional repo)
1690      (define (test2 fname lst)
1691        (if (null? lst)
1692            (and (exists? fname) fname)
1693            (let ([fn (##sys#string-append fname (car lst))])
1694              (if (exists? fn)
1695                  fn
1696                  (test2 fname (cdr lst)) ) ) ) )
1697      (define (test fname)
1698        (test2 
1699         fname 
1700         (if prefer-source
1701             (list source-file-extension ##sys#load-dynamic-extension)
1702             (list ##sys#load-dynamic-extension source-file-extension) ) ) )
1703      (or (test fname)
1704          (let loop ((paths (if repo
1705                                (##sys#append ##sys#include-pathnames (list (##sys#repository-path)))
1706                                ##sys#include-pathnames) ) )
1707            (cond ((eq? paths '()) fname)
1708                  ((test (string-append (##sys#slot paths 0)
1709                                        "/"
1710                                        fname) ) )
1711                  (else (loop (##sys#slot paths 1))) ) ) ) ) ) )
1712
1713
1714;;; Print timing information (support for "time" macro):
1715
1716(define ##sys#display-times
1717  (let* ((display display)
1718         (spaces 
1719          (lambda (n)
1720            (do ((i n (fx- i 1)))
1721                ((fx<= i 0))
1722              (display #\space) ) ) )
1723         (display-rj 
1724          (lambda (x w)
1725            (let* ((xs (if (zero? x) "0" (number->string x)))
1726                   (xslen (##core#inline "C_block_size" xs)) )
1727              (spaces (fx- w xslen))
1728              (display xs) ) ) ) )
1729    (lambda (info)
1730      (display-rj (##sys#slot info 0) 8)
1731      (display " seconds elapsed\n") 
1732      (display-rj (##sys#slot info 1) 8)
1733      (display " seconds in (major) GC\n")
1734      (display-rj (##sys#slot info 2) 8)
1735      (display " mutations\n")
1736      (display-rj (##sys#slot info 3) 8)
1737      (display " minor GCs\n")
1738      (display-rj (##sys#slot info 4) 8)
1739      (display " major GCs\n") ) ) )
1740
1741
1742;;; General syntax checking routine:
1743
1744(define ##sys#line-number-database #f)
1745(define (##sys#syntax-error-hook . args) (apply ##sys#signal-hook #:syntax-error args))
1746(define ##sys#syntax-error-culprit #f)
1747
1748(define syntax-error ##sys#syntax-error-hook)
1749
1750(define (get-line-number sexp)
1751  (and ##sys#line-number-database
1752       (pair? sexp)
1753       (let ([head (##sys#slot sexp 0)])
1754         (and (symbol? head)
1755              (cond [(##sys#hash-table-ref ##sys#line-number-database head)
1756                     => (lambda (pl)
1757                          (let ([a (assq sexp pl)])
1758                            (and a (##sys#slot a 1)) ) ) ]
1759                    [else #f] ) ) ) ) )
1760
1761(define ##sys#check-syntax
1762  (let ([string-append string-append]
1763        [keyword? keyword?]
1764        [get-line-number get-line-number]
1765        [symbol->string symbol->string] )
1766    (lambda (id exp pat . culprit)
1767
1768      (define (test x pred msg)
1769        (unless (pred x) (err msg)) )
1770
1771      (define (err msg)
1772        (let* ([sexp ##sys#syntax-error-culprit]
1773               [ln (get-line-number sexp)] )
1774          (##sys#syntax-error-hook
1775           (if ln 
1776               (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
1777               (string-append "(" (symbol->string id) ") " msg) )
1778           exp) ) )
1779
1780      (define (lambda-list? x)
1781        (or (##sys#extended-lambda-list? x)
1782            (let loop ((x x))
1783              (cond ((eq? x '()))
1784                    ((not (##core#inline "C_blockp" x)) #f)
1785                    ((##core#inline "C_symbolp" x) (not (keyword? x)))
1786                    ((##core#inline "C_pairp" x)
1787                     (let ((s (##sys#slot x 0)))
1788                       (if (or (not (##core#inline "C_blockp" s)) (not (##core#inline "C_symbolp" s)))
1789                           #f
1790                           (loop (##sys#slot x 1)) ) ) ) 
1791                    (else #f) ) ) ) )
1792
1793      (define (proper-list? x)
1794        (let loop ((x x))
1795          (cond ((eq? x '()))
1796                ((and (##core#inline "C_blockp" x) (##core#inline "C_pairp" x)) (loop (##sys#slot x 1)))
1797                (else #f) ) ) )
1798
1799      (when (pair? culprit) (set! ##sys#syntax-error-culprit (car culprit)))
1800      (let walk ((x exp) (p pat))
1801        (cond ((and (##core#inline "C_blockp" p) (##core#inline "C_vectorp" p))
1802               (let* ((p2 (##sys#slot p 0))
1803                      (vlen (##core#inline "C_block_size" p))
1804                      (min (if (fx> vlen 1) 
1805                               (##sys#slot p 1)
1806                               0) )
1807                      (max (cond ((eq? vlen 1) 1)
1808                                 ((fx> vlen 2) (##sys#slot p 2))
1809                                 (else 99999) ) ) )
1810                 (do ((x x (##sys#slot x 1))
1811                      (n 0 (fx+ n 1)) )
1812                     ((eq? x '())
1813                      (if (fx< n min)
1814                          (err "not enough arguments") ) )
1815                   (cond ((fx>= n max) 
1816                          (err "too many arguments") )
1817                         ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
1818                          (err "not a proper list") )
1819                         (else (walk (##sys#slot x 0) p2) ) ) ) ) )
1820              ((not (##core#inline "C_blockp" p))
1821               (if (not (eq? p x)) (err "unexpected object")) )
1822              ((##core#inline "C_symbolp" p)
1823               (case p
1824                 ((_) #t)
1825                 ((pair) (test x pair? "pair expected"))
1826                 ((variable) (test x (lambda (x) (and (symbol? x))) "identifier expected"))
1827                 ((symbol) (test x symbol? "symbol expected"))
1828                 ((list) (test x proper-list? "proper list expected"))
1829                 ((number) (test x number? "number expected"))
1830                 ((string) (test x string? "string expected"))
1831                 ((lambda-list) (test x lambda-list? "lambda-list expected"))
1832                 (else (test x (lambda (y) (eq? y p)) "missing keyword")) ) )
1833              ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
1834               (err "incomplete form") )
1835              (else
1836               (walk (##sys#slot x 0) (##sys#slot p 0))
1837               (walk (##sys#slot x 1) (##sys#slot p 1)) ) ) ) ) ) )
1838
1839
1840;;; Macro definitions:
1841
1842(##sys#register-macro-2
1843 'define
1844 (lambda (form)
1845   (let loop ([form form])
1846     (let ((head (car form))
1847           (body (cdr form)) )
1848       (cond ((not (pair? head))
1849              (##sys#check-syntax 'define head 'symbol)
1850              (##sys#check-syntax 'define body '#(_ 0 1))
1851              `(##core#set! ,head ,(if (pair? body) (car body) '(##sys#void))) )
1852             ((pair? (##sys#slot head 0))
1853              (##sys#check-syntax 'define head '(_ . lambda-list))
1854              (##sys#check-syntax 'define body '#(_ 1))
1855              (loop (##sys#expand-curried-define head body)) )
1856             (else
1857              (##sys#check-syntax 'define head '(symbol . lambda-list))
1858              (##sys#check-syntax 'define body '#(_ 1))
1859              `(##core#set! ,(car head) (lambda ,(cdr head) ,@body)) ) ) ) ) ) )
1860
1861(##sys#register-macro-2
1862 'and
1863 (lambda (body)
1864   (if (eq? body '())
1865       #t
1866       (let ((rbody (##sys#slot body 1))
1867             (hbody (##sys#slot body 0)) )
1868         (if (eq? rbody '())
1869             hbody
1870             `(if ,hbody (and ,@rbody) #f) ) ) ) ) )
1871
1872(##sys#register-macro-2
1873 'or 
1874 (let ((gensym gensym))
1875   (lambda (body)
1876     (if (eq? body '())
1877         #f
1878         (let ((rbody (##sys#slot body 1))
1879               (hbody (##sys#slot body 0)) )
1880           (if (eq? rbody '())
1881               hbody
1882               (let ((tmp (gensym)))
1883                 `(let ((,tmp ,hbody))
1884                    (if ,tmp ,tmp (or ,@rbody)) ) ) ) ) ) ) ) )
1885
1886(##sys#register-macro-2
1887 'cond
1888 (let ((gensym gensym))
1889   (lambda (body)
1890     (let expand ((clauses body))
1891       (if (not (pair? clauses))
1892           '(##core#undefined)
1893           (let ((clause (##sys#slot clauses 0))
1894                 (rclauses (##sys#slot clauses 1)) )
1895             (##sys#check-syntax 'cond clause '#(_ 1))
1896             (cond ((eq? 'else (car clause)) `(begin ,@(cdr clause)))
1897                   ((eq? (cdr clause) '()) `(or ,(car clause) ,(expand rclauses)))
1898                   ((eq? '=> (cadr clause))
1899                    (let ((tmp (gensym)))
1900                      `(let ((,tmp ,(car clause)))
1901                         (if ,tmp
1902                             (,(caddr clause) ,tmp)
1903                             ,(expand rclauses) ) ) ) )
1904                   ((and (list? clause) (fx= (length clause) 4) (eq? '=> (caddr clause)))
1905                    (let ((tmp (gensym)))
1906                      `(##sys#call-with-values
1907                        (lambda () ,(car clause))
1908                        (lambda ,tmp
1909                          (if (##sys#apply ,(cadr clause) ,tmp)
1910                              (##sys#apply ,(cadddr clause) ,tmp)
1911                              ,(expand rclauses) ) ) ) ) )
1912                   (else `(if ,(car clause) 
1913                              (begin ,@(cdr clause))
1914                              ,(expand rclauses) ) ) ) ) ) ) ) ) )
1915
1916(##sys#register-macro-2
1917 'case
1918 (let ((gensym gensym))
1919   (lambda (form)
1920     (let ((exp (car form))
1921           (body (cdr form)) )
1922       (let ((tmp (gensym)))
1923         `(let ((,tmp ,exp))
1924            ,(let expand ((clauses body))
1925               (if (not (pair? clauses))
1926                   '(##core#undefined)
1927                   (let ((clause (##sys#slot clauses 0))
1928                         (rclauses (##sys#slot clauses 1)) )
1929                     (##sys#check-syntax 'case clause '#(_ 1))
1930                     (if (eq? 'else (car clause))
1931                         `(begin ,@(cdr clause))
1932                         `(if (or ,@(##sys#map (lambda (x) `(eqv? ,tmp ',x)) (car clause)))
1933                              (begin ,@(cdr clause)) 
1934                              ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
1935
1936(##sys#register-macro-2
1937 'let*
1938 (lambda (form)
1939   (let ((bindings (car form))
1940         (body (cdr form)) )
1941     (##sys#check-syntax 'let* bindings '#((symbol _) 0))
1942     (##sys#check-syntax 'let* body '#(_ 1))
1943     (let expand ((bs bindings))
1944       (if (eq? bs '())
1945           `(let () ,@body)
1946           `(let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) )
1947
1948(##sys#register-macro-2
1949 'letrec
1950 (lambda (form)
1951   (let ((bindings (car form))
1952         (body (cdr form)) )
1953     (##sys#check-syntax 'letrec bindings '#((symbol _) 0))
1954     (##sys#check-syntax 'letrec body '#(_ 1))
1955     `(let ,(##sys#map (lambda (b) (list (car b) '(##core#undefined))) bindings)
1956        ,@(##sys#map (lambda (b) `(##core#set! ,(car b) ,(cadr b))) bindings)
1957        (let () ,@body) ) ) ) )
1958
1959(##sys#register-macro
1960 'do
1961 (let ((gensym gensym))
1962   (lambda (bindings test . body)
1963     (##sys#check-syntax 'do bindings '#((symbol _ . #(_)) 0))
1964     (##sys#check-syntax 'do test '#(_ 1))
1965     (let ((dovar (gensym "do")))
1966       `(let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
1967             (if ,(car test)
1968                 ,(let ((tbody (cdr test)))
1969                    (if (eq? tbody '())
1970                        '(##core#undefined)
1971                        `(begin ,@tbody) ) )
1972                 (begin
1973                   ,(if (eq? body '())
1974                        '(##core#undefined)
1975                        `(let () ,@body) )
1976                   (##core#app
1977                    ,dovar ,@(##sys#map (lambda (b) 
1978                                          (if (eq? (cdr (cdr b)) '())
1979                                              (car b)
1980                                              (car (cdr (cdr b))) ) )
1981                                        bindings) ) ) ) ) ) ) ) )
1982
1983(##sys#register-macro
1984 'quasiquote
1985 (let ((vector->list vector->list))
1986   (lambda (form)
1987     
1988     (define (walk x n) (simplify (walk1 x n)))
1989
1990     (define (walk1 x n)
1991       (if (##core#inline "C_blockp" x)
1992           (cond ((##core#inline "C_vectorp" x)
1993                  `(##sys#list->vector ,(walk (vector->list x) n)) )
1994                 ((not (##core#inline "C_pairp" x)) `(quote ,x))
1995                 (else
1996                  (let ((head (##sys#slot x 0))
1997                        (tail (##sys#slot x 1)) )
1998                    (case head
1999                      ((unquote)
2000                       (if (and (##core#inline "C_blockp" tail) (##core#inline "C_pairp" tail))
2001                           (let ((hx (##sys#slot tail 0)))
2002                             (if (eq? n 0)
2003                                 hx
2004                                 (list '##sys#list '(quote unquote)
2005                                       (walk hx (fx- n 1)) ) ) )
2006                           '(quote unquote) ) )
2007                      ((quasiquote)
2008                       (if (and (##core#inline "C_blockp" tail) (##core#inline "C_pairp" tail))
2009                           `(##sys#list (quote quasiquote) 
2010                                   ,(walk (##sys#slot tail 0) (fx+ n 1)) ) 
2011                           (list '##sys#cons (list 'quote 'quasiquote) (walk tail n)) ) )
2012                      (else
2013                       (if (and (##core#inline "C_blockp" head) (##core#inline "C_pairp" head))
2014                           (let ((hx (##sys#slot head 0))
2015                                 (tx (##sys#slot head 1)) )
2016                             (if (and (eq? hx 'unquote-splicing)
2017                                      (##core#inline "C_blockp" tx)
2018                                      (##core#inline "C_pairp" tx) )
2019                                 (let ((htx (##sys#slot tx 0)))
2020                                   (if (eq? n 0)
2021                                       `(##sys#append ,htx
2022                                                 ,(walk tail n) )
2023                                       `(##sys#cons (##sys#list 'unquote-splicing
2024                                                        ,(walk htx (fx- n 1)) )
2025                                               ,(walk tail n) ) ) )
2026                                 `(##sys#cons ,(walk head n) ,(walk tail n)) ) )
2027                           `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
2028           `(quote ,x) ) )
2029
2030     (define (simplify x)
2031       (cond ((##sys#match-expression x '(##sys#cons a '()) '(a))
2032              => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
2033             ((##sys#match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
2034              => (lambda (env)
2035                   (let ([bxs (assq 'b env)])
2036                     (if (fx< (length bxs) 32)
2037                         (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
2038                                            ,@(##sys#slot bxs 1) ) ) 
2039                         x) ) ) )
2040             ((##sys#match-expression x '(##sys#append a '()) '(a))
2041              => (lambda (env) (##sys#slot (assq 'a env) 1)) )
2042             (else x) ) )
2043     
2044     (walk form 0) ) ) )
2045
2046(##sys#register-macro
2047 'delay
2048 (lambda (x) `(##sys#make-promise (lambda () ,x))) )
2049
2050(##sys#register-macro-2
2051 'cond-expand
2052   (lambda (clauses)
2053
2054     (define (err x) 
2055       (##sys#error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
2056
2057     (define (test fx)
2058       (cond ((symbol? fx) (##sys#feature? fx))
2059             ((not (pair? fx)) (err fx))
2060             (else
2061              (let ((rest (##sys#slot fx 1)))
2062                (case (##sys#slot fx 0)
2063                  ((and)
2064                   (or (eq? rest '())
2065                       (if (pair? rest)
2066                           (and (test (##sys#slot rest 0))
2067                                (test `(and ,@(##sys#slot rest 1))) )
2068                           (err fx) ) ) )
2069                  ((or) 
2070                   (and (not (eq? rest '()))
2071                        (if (pair? rest)
2072                            (or (test (##sys#slot rest 0))
2073                                (test `(or ,@(##sys#slot rest 1))) )
2074                            (err fx) ) ) )
2075                  ((not) (not (test (cadr fx))))
2076                  (else (err fx)) ) ) ) ) )
2077
2078     (let expand ((cls clauses))
2079       (cond ((eq? cls '())
2080              (##sys#apply
2081               ##sys#error "no matching clause in `cond-expand' form" 
2082               (map (lambda (x) (car x)) clauses) ) )
2083             ((not (pair? cls)) (err cls))
2084             (else
2085              (let ((clause (##sys#slot cls 0))
2086                    (rclauses (##sys#slot cls 1)) )
2087                (if (not (pair? clause)) 
2088                    (err clause)
2089                    (let ((id (##sys#slot clause 0)))
2090                      (cond ((eq? id 'else)
2091                             (let ((rest (##sys#slot clause 1)))
2092                               (if (eq? rest '())
2093                                   '(##core#undefined)
2094                                   `(begin ,@rest) ) ) )
2095                            ((test id) `(begin ,@(##sys#slot clause 1)))
2096                            (else (expand rclauses)) ) ) ) ) ) ) ) ) )
2097
2098
2099;;; SRFI-0 support code:
2100
2101(set! ##sys#features
2102  (append '(#:srfi-8 #:srfi-6 #:srfi-2 #:srfi-0 #:srfi-10 #:srfi-9 #:srfi-55 #:srfi-61) 
2103          ##sys#features))
2104
2105
2106;;;; Read-Eval-Print loop:
2107
2108(define ##sys#repl-eval-hook #f)
2109(define ##sys#repl-print-length-limit #f)
2110(define ##sys#repl-read-hook #f)
2111
2112(define (##sys#repl-print-hook x port)
2113  (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
2114  (##sys#write-char-0 #\newline port) )
2115
2116(define repl-prompt (make-parameter (lambda () "#;> ")))
2117
2118(define ##sys#read-prompt-hook
2119  (let ([repl-prompt repl-prompt])
2120    (lambda () 
2121      (##sys#print ((repl-prompt)) #f ##sys#standard-output)
2122      (##sys#flush-output ##sys#standard-output) ) ) )
2123
2124(define ##sys#clear-trace-buffer (foreign-lambda void "C_clear_trace_buffer"))
2125
2126(define repl
2127  (let ((eval eval)
2128        (read read)
2129        (call-with-current-continuation call-with-current-continuation)
2130        (print-call-chain print-call-chain)
2131        (flush-output flush-output)
2132        (load-verbose load-verbose)
2133        (reset reset) )
2134    (lambda ()
2135
2136      (define (write-err xs)
2137        (for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs) )
2138
2139      (define (write-results xs)
2140        (unless (or (null? xs) (eq? (##core#undefined) (car xs)))
2141          (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs) ) )
2142
2143      (let ((stdin ##sys#standard-input)
2144            (stdout ##sys#standard-output)
2145            (stderr ##sys#standard-error)
2146            (ehandler (##sys#error-handler))
2147            (rhandler (##sys#reset-handler)) 
2148            (lv #f)
2149            (uie ##sys#unbound-in-eval) )
2150
2151        (define (saveports)
2152          (set! stdin ##sys#standard-input)
2153          (set! stdout ##sys#standard-output)
2154          (set! stderr ##sys#standard-error) )
2155
2156        (define (resetports)
2157          (set! ##sys#standard-input stdin)
2158          (set! ##sys#standard-output stdout)
2159          (set! ##sys#standard-error stderr) )
2160
2161        (##sys#dynamic-wind
2162         (lambda ()
2163           (set! lv (load-verbose))
2164           (load-verbose #t)
2165           (##sys#error-handler
2166            (lambda (msg . args)
2167              (resetports)
2168              (##sys#print "Error" #f ##sys#standard-error)
2169              (when msg
2170                (##sys#print ": " #f ##sys#standard-error)
2171                (##sys#print msg #f ##sys#standard-error) )
2172              (if (and (pair? args) (null? (cdr args)))
2173                  (begin
2174                    (##sys#print ": " #f ##sys#standard-error)
2175                    (write-err args) )
2176                  (begin
2177                    (##sys#write-char-0 #\newline ##sys#standard-error)
2178                    (write-err args) ) )
2179              (print-call-chain ##sys#standard-error)
2180              (flush-output ##sys#standard-error) ) ) )
2181         (lambda ()
2182           (let loop ()
2183             (saveports)
2184             (call-with-current-continuation
2185              (lambda (c)
2186                (##sys#reset-handler
2187                 (lambda ()
2188                   (set! ##sys#read-error-with-line-number #f)
2189                   (set! ##sys#enable-qualifiers #t)
2190                   (resetports)
2191                   (c #f) ) ) ) )
2192             (##sys#read-prompt-hook)
2193             (let ([exp ((or ##sys#repl-read-hook read))])
2194               (unless (eof-object? exp)
2195                 (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
2196                   (##sys#read-char-0 ##sys#standard-input) )
2197                 (##sys#clear-trace-buffer)
2198                 (set! ##sys#unbound-in-eval '())
2199                 (receive result ((or ##sys#repl-eval-hook eval) exp)
2200                   (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
2201                     (let loop ((vars ##sys#unbound-in-eval) (u '()))
2202                       (cond ((null? vars)
2203                              (when (pair? u)
2204                                (##sys#print 
2205                                 "Warning: the following toplevel variables are referenced but unbound:\n" 
2206                                 #f ##sys#standard-error)
2207                                (for-each
2208                                 (lambda (v)
2209                                   (##sys#print "  " #f ##sys#standard-error)
2210                                   (##sys#print (car v) #t ##sys#standard-error)
2211                                   (when (cdr v)
2212                                     (##sys#print " (in " #f ##sys#standard-error)
2213                                     (##sys#print (cdr v) #t ##sys#standard-error) 
2214                                     (##sys#write-char-0 #\) ##sys#standard-error) )
2215                                   (##sys#write-char-0 #\newline ##sys#standard-error) )
2216                                 u) ) )
2217                             ((or (memq (caar vars) u) 
2218                                  (##sys#symbol-has-toplevel-binding? (caar vars)) )
2219                              (loop (cdr vars) u) )
2220                             (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
2221                   (write-results result) 
2222                   (loop) ) ) ) ) )
2223         (lambda ()
2224           (load-verbose lv)
2225           (set! ##sys#unbound-in-eval uie)
2226           (##sys#error-handler ehandler)
2227           (##sys#reset-handler rhandler) ) ) ) ) ) )
2228
2229
2230;;; SRFI-10:
2231
2232(define ##sys#sharp-comma-reader-ctors (make-vector 301 '()))
2233
2234(define (define-reader-ctor spec proc)
2235  (##sys#check-symbol spec 'define-reader-ctor)
2236  (##sys#hash-table-set! ##sys#sharp-comma-reader-ctors spec proc) )
2237
2238(set! ##sys#user-read-hook
2239  (let ([old ##sys#user-read-hook]
2240        [read-char read-char]
2241        [read read] )
2242    (lambda (char port)
2243      (cond [(char=? char #\,)
2244             (read-char port)
2245             (let* ([exp (read port)]
2246                    [err (lambda () (##sys#read-error port "invalid sharp-comma external form" exp))] )
2247               (if (or (null? exp) (not (list? exp)))
2248                   (err)
2249                   (let ([spec (##sys#slot exp 0)])
2250                     (if (not (symbol? spec))
2251                         (err) 
2252                         (let ([ctor (##sys#hash-table-ref ##sys#sharp-comma-reader-ctors spec)])
2253                           (if ctor
2254                               (apply ctor (##sys#slot exp 1))
2255                               (##sys#read-error port "undefined sharp-comma constructor" spec) ) ) ) ) ) ) ]
2256            [else (old char port)] ) ) ) )
2257
2258
2259;;; Handy to have by default:
2260
2261(##sys#register-macro
2262 'define-macro
2263 (lambda (head . body)
2264   (define (expand name val)
2265     (let ((m2 (and (pair? val) (eq? 'lambda (car val))
2266                    (pair? (cdr val)) (symbol? (cadr val))) ))
2267       `(,(if ##sys#enable-runtime-macros '##core#elaborationtimetoo '##core#elaborationtimeonly)
2268         ,(cond (m2 `(##sys#register-macro-2 ',name (lambda (,(cadr val)) ,@(cddr val))))
2269                ((symbol? val) `(##sys#copy-macro ',val ',name))
2270                (else `(##sys#register-macro ',name ,val) ) ) ) ) )
2271   (cond ((symbol? head)
2272          (##sys#check-syntax 'define-macro body '(_))
2273          (expand head (car body)) )
2274         (else
2275          (##sys#check-syntax 'define-macro head '(symbol . lambda-list))
2276          (##sys#check-syntax 'define-macro body '#(_ 1)) 
2277          (expand (car head) `(lambda ,(cdr head) ,@body))))))
2278
2279(##sys#register-macro
2280 'require-extension
2281 (lambda ids
2282   (##sys#check-syntax 'require-extension ids '#(_ 0))
2283   `(##core#require-extension ,@(map (lambda (x) (list 'quote x)) ids) ) ) )
2284
2285
2286;;; To catch common errors:
2287
2288(##sys#register-macro-2
2289 'define-syntax
2290 (lambda (form)
2291   (##sys#syntax-error-hook 'define-syntax "highlevel macros are not supported")))
2292
2293(##sys#register-macro-2
2294 'module
2295 (lambda (form)
2296   (##sys#syntax-error-hook 'module "modules are not supported")))
2297
2298
2299;;; Simple invocation API:
2300
2301(declare
2302  (hide last-error run-safe store-result store-string
2303        CHICKEN_yield CHICKEN_apply_to_string
2304        CHICKEN_eval CHICKEN_eval_string CHICKEN_eval_to_string CHICKEN_eval_string_to_string
2305        CHICKEN_apply CHICKEN_eval_apply CHICKEN_eval_to_string
2306        CHICKEN_read CHICKEN_load CHICKEN_get_error_message) )
2307       
2308(define last-error #f)
2309
2310(define (run-safe thunk)
2311  (set! last-error #f)
2312  (handle-exceptions ex 
2313      (let ((o (open-output-string)))
2314        (print-error-message ex o)
2315        (set! last-error (get-output-string o))
2316        #f)
2317    (thunk) ) )
2318
2319#>
2320#define C_store_result(x, ptr)   (*((C_word *)C_block_item(ptr, 0)) = (x), C_SCHEME_TRUE)
2321<#
2322
2323(define (store-result x result)
2324  (##sys#gc #f)
2325  (when result
2326    (##core#inline "C_store_result" x result) )
2327  #t)
2328
2329(define-external (CHICKEN_yield) bool
2330  (run-safe (lambda () (begin (thread-yield!) #t))) )
2331
2332(define-external (CHICKEN_eval (scheme-object exp) ((c-pointer "C_word") result)) bool
2333  (run-safe
2334   (lambda ()
2335     (store-result (eval exp) result) ) ) )
2336
2337(define-external (CHICKEN_eval_string (c-string str) ((c-pointer "C_word") result)) bool
2338  (run-safe
2339   (lambda ()
2340     (let ([i (open-input-string str)])
2341       (store-result (eval (read i)) result)) )))
2342
2343#>
2344#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)
2345<#
2346
2347(define (store-string str bufsize buf)
2348  (let ((len (##sys#size str)))
2349    (cond ((fx>= len bufsize)
2350           (set! last-error "Error: not enough room for result string")
2351           #f)
2352          (else (##core#inline "C_copy_result_string" str buf len)) ) ) )
2353
2354(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
2355                                          (int bufsize))
2356  bool
2357  (run-safe
2358   (lambda ()
2359     (let ([o (open-output-string)])
2360       (write (eval exp) o) 
2361       (store-string (get-output-string o) bufsize buf)) ) ) )
2362
2363(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
2364                                                 (int bufsize) ) 
2365  bool
2366  (run-safe
2367   (lambda ()
2368     (let ([o (open-output-string)])
2369       (write (eval (read (open-input-string str))) o)
2370       (store-string (get-output-string o) bufsize buf)) ) ) )
2371
2372(define-external (CHICKEN_apply (scheme-object func) (scheme-object args) 
2373                                 ((c-pointer "C_word") result))
2374  bool
2375  (run-safe (lambda () (store-result (apply func args) result))) )
2376
2377(define-external (CHICKEN_apply_to_string (scheme-object func) (scheme-object args) 
2378                                           ((c-pointer "char") buf) (int bufsize))
2379  bool
2380  (run-safe
2381   (lambda ()
2382     (let ([o (open-output-string)])
2383       (write (apply func args) o) 
2384       (store-string (get-output-string o) bufsize buf)) ) ) )
2385
2386(define-external (CHICKEN_read (c-string str) ((c-pointer "C_word") result)) bool
2387  (run-safe
2388   (lambda ()
2389     (let ([i (open-input-string str)])
2390       (store-result (read i) result) ) ) ) )
2391
2392(define-external (CHICKEN_load (c-string str)) bool
2393  (run-safe (lambda () (load str) #t)) )
2394
2395(define-external (CHICKEN_get_error_message ((c-pointer "char") buf) (int bufsize)) void
2396  (store-string (or last-error "No error") bufsize buf) )
2397
2398
2399;;; Create lambda-info object
2400
2401(define (##sys#make-lambda-info str)
2402  (let* ((sz (##sys#size str))
2403         (info (##sys#make-string sz)) )
2404    (##core#inline "C_copy_memory" info str sz)
2405    (##core#inline "C_string_to_lambdainfo" info)
2406    info) )
Note: See TracBrowser for help on using the repository browser.