source: project/chicken/branches/release/eval.scm @ 7276

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

merged trunk

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