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

Last change on this file since 6428 was 6428, checked in by Kon Lovett, 12 years ago

srfi-12 is ok.

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