~ chicken-core (master) /eval.scm

   1;;;; eval.scm - Interpreter for CHICKEN
   2;
   3; Copyright (c) 2008-2022, The CHICKEN Team
   4; Copyright (c) 2000-2007, Felix L. Winkelmann
   5; All rights reserved.
   6;
   7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   8; conditions are met:
   9;
  10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  11;     disclaimer.
  12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  13;     disclaimer in the documentation and/or other materials provided with the distribution.
  14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  15;     products derived from this software without specific prior written permission.
  16;
  17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  25; POSSIBILITY OF SUCH DAMAGE.
  26
  27
  28(declare
  29  (unit eval)
  30  (uses modules)
  31  (not inline ##sys#alias-global-hook ##sys#user-read-hook ##sys#syntax-error-hook))
  32
  33#>
  34#ifndef C_INSTALL_EGG_HOME
  35# define C_INSTALL_EGG_HOME    "."
  36#endif
  37
  38#ifndef C_INSTALL_SHARE_HOME
  39# define C_INSTALL_SHARE_HOME NULL
  40#endif
  41
  42#ifndef C_BINARY_VERSION
  43# define C_BINARY_VERSION      0
  44#endif
  45<#
  46
  47(module chicken.eval
  48  (eval-handler module-environment)
  49
  50(import scheme
  51	chicken.base
  52	chicken.bytevector
  53	chicken.fixnum
  54	chicken.internal
  55	chicken.keyword
  56	chicken.syntax
  57	chicken.type
  58        chicken.foreign)
  59(import (only (scheme base) make-parameter open-output-string get-output-string port?))
  60
  61(include "common-declarations.scm")
  62
  63(define-syntax d (syntax-rules () ((_ . _) (void))))
  64
  65
  66;;; Compile lambda to closure:
  67
  68(define (eval-decorator p ll h cntr)
  69  (##sys#decorate-lambda
  70   p
  71   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
  72   (lambda (p i)
  73     (##sys#setslot
  74      p i
  75      (##sys#make-lambda-info
  76       (let ((o (open-output-string)))
  77	 (write ll o)
  78	 (get-output-string o))))
  79     p) ) )
  80
  81(define ##sys#unbound-in-eval #f)
  82(define ##sys#eval-debug-level (make-parameter 1))
  83
  84(define compile-to-closure
  85  (let ((reverse reverse))
  86    (lambda (exp env #!optional cntr evalenv static tl?)
  87      (define-syntax thread-id
  88        (syntax-rules ()
  89          ((_ t) (##sys#slot t 14))))
  90
  91      (define (find-id id se)		; ignores macro bindings
  92	(cond ((null? se) #f)
  93	      ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
  94	      (else (find-id id (cdr se)))))
  95
  96      (define (rename var)
  97	(cond ((find-id var (##sys#current-environment)))
  98	      ((##sys#get var '##core#macro-alias) symbol? => values)
  99	      (else var)))
 100
 101      (define (lookup var0 e)
 102	(let ((var (rename var0)))
 103	  (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map (lambda (x) (car x)) (##sys#current-environment))))
 104	  (let loop ((envs e) (ei 0))
 105	    (cond ((null? envs) (values #f var))
 106		  ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
 107		  (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
 108
 109      (define (posq x lst)
 110	(let loop ((lst lst) (i 0))
 111	  (cond ((null? lst) #f)
 112		((eq? x (##sys#slot lst 0)) i)
 113		(else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
 114
 115      (define (emit-trace-info tf ln info cntr e v)
 116	(when tf
 117	  (##core#inline "C_emit_trace_info"
 118	   ln
 119	   info
 120	   (##sys#make-structure 'frameinfo cntr e v)
 121	   (thread-id ##sys#current-thread) ) ) )
 122
 123      (define (emit-syntax-trace-info tf info cntr)
 124	(when tf
 125	  (##core#inline "C_emit_trace_info"
 126	   (or (get-line-number info) "<syntax>")
 127	   info
 128	   cntr
 129           (thread-id ##sys#current-thread) ) ) )
 130
 131      (define (decorate p ll h cntr)
 132	(eval-decorator p ll h cntr))
 133
 134      (define (handle-expansion-result outer-ln)
 135	(lambda (input output)
 136	  (and-let* (((not (eq? input output)))
 137		     (ln (or (get-line-number input) outer-ln)))
 138	    (##sys#update-line-number-database! output ln))
 139	  output))
 140
 141      (define (include-file x ci e tf cntr tl?)
 142        (##sys#include-forms-from-file
 143          (cadr x) (caddr x) ci
 144	  (lambda (forms path)
 145            (let ((code (if (pair? (cdddr x)) ; body?
 146                            (##sys#canonicalize-body
 147                              (append forms (cadddr x))
 148                              (##sys#current-environment))
 149                            `(##core#begin ,@forms))))
 150	      (fluid-let ((##sys#current-source-filename path))
 151                (compile code e #f tf cntr tl?))))))
 152
 153      (define (compile x e h tf cntr tl?)
 154	(cond ((keyword? x) (lambda v x))
 155	      ((symbol? x)
 156	       (receive (i j) (lookup x e)
 157		 (cond ((not i)
 158			(let ((var (cond ((not (symbol? j)) x) ; syntax?
 159					 ((assq x (##sys#current-environment)) j)
 160					 ((not static)
 161                                          (##sys#alias-global-hook j #f cntr))
 162                                         ((not (eq? x j)) j) ; has macro-alias
 163                                         (else #f))))
 164			  (when (and ##sys#unbound-in-eval
 165				     (or (not var)
 166					 (not (##sys#symbol-has-toplevel-binding? var))))
 167			    (set! ##sys#unbound-in-eval
 168			      (cons (cons var cntr) ##sys#unbound-in-eval)) )
 169			  (cond ((not var)
 170				 (lambda (v)
 171				   (##sys#error "unbound variable" x)))
 172				((##sys#symbol-has-toplevel-binding? var)
 173				 (lambda v (##sys#slot var 0)))
 174				(else
 175				 (lambda v (##core#inline "C_fast_retrieve" var))))))
 176                      (else
 177                       (case i
 178                         ((0) (lambda (v)
 179                                (##sys#slot (##sys#slot v 0) j)))
 180                         ((1) (lambda (v)
 181                                (##sys#slot (##sys#slot (##sys#slot v 1) 0) j)))
 182                         ((2) (lambda (v)
 183                                (##sys#slot
 184                                 (##sys#slot (##sys#slot (##sys#slot v 1) 1) 0)
 185                                 j)))
 186                         ((3) (lambda (v)
 187                                (##sys#slot
 188                                 (##sys#slot
 189                                  (##sys#slot (##sys#slot (##sys#slot v 1) 1) 1)
 190                                  0)
 191                                 j)))
 192                         (else
 193                          (lambda (v)
 194                            (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))))))))
 195	      [(number? x)
 196	       (case x
 197		 [(-1) (lambda v -1)]
 198		 [(0) (lambda v 0)]
 199		 [(1) (lambda v 1)]
 200		 [(2) (lambda v 2)]
 201		 [else (lambda v x)] ) ]
 202	      [(boolean? x)
 203	       (if x
 204		   (lambda v #t)
 205		   (lambda v #f) ) ]
 206	      ((or (char? x)
 207		   (eof-object? x)
 208		   (bwp-object? x)
 209		   (string? x)
 210		   (bytevector? x)
 211		   (vector? x)
 212		   (##sys#srfi-4-vector? x))
 213	       (lambda v x) )
 214	      [(not (pair? x))
 215	       (##sys#syntax-error/context "illegal non-atomic object" x)]
 216	      [(symbol? (##sys#slot x 0))
 217	       (emit-syntax-trace-info tf x cntr)
 218	       (let* ((ln (get-line-number x))
 219		      (x2 (fluid-let ((chicken.syntax#expansion-result-hook
 220				       (handle-expansion-result ln)))
 221			    (expand x (##sys#current-environment)))))
 222		 (d `(EVAL/EXPANDED: ,x2))
 223		 (if (not (eq? x2 x))
 224		     (compile x2 e h tf cntr tl?)
 225		     (let ((head (rename (##sys#slot x 0))))
 226		       ;; here we did't resolve ##core#primitive, but that is done in compile-call (via
 227		       ;; a normal walking of the operator)
 228		       (case head
 229
 230			 [(##core#quote)
 231			  (let* ((c (strip-syntax (cadr x))))
 232			    (case c
 233			      [(-1) (lambda v -1)]
 234			      [(0) (lambda v 0)]
 235			      [(1) (lambda v 1)]
 236			      [(2) (lambda v 2)]
 237			      [(#t) (lambda v #t)]
 238			      [(#f) (lambda v #f)]
 239			      [(()) (lambda v '())]
 240			      [else (lambda v c)] ) ) ]
 241
 242			 ((##core#syntax)
 243			  (let ((c (cadr x)))
 244			    (lambda v c)))
 245
 246			 [(##core#check)
 247			  (compile (cadr x) e h tf cntr #f) ]
 248
 249			 [(##core#immutable)
 250			  (compile (cadr x) e #f tf cntr #f) ]
 251
 252			 [(##core#undefined) (lambda (v) (##core#undefined))]
 253
 254			 [(##core#if)
 255			  (let* ((test (compile (cadr x) e #f tf cntr #f))
 256				 (cns (compile (caddr x) e #f tf cntr #f))
 257				 (alt (if (pair? (cdddr x))
 258					  (compile (cadddr x) e #f tf cntr #f)
 259					  (compile '(##core#undefined) e #f tf cntr #f) ) ) )
 260			    (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
 261
 262			 [(##core#begin)
 263			  (let* ((body (##sys#slot x 1))
 264				 (len (length body)) )
 265			    (case len
 266			      ((0) (compile '(##core#undefined) e #f tf cntr tl?))
 267			      ((1) (compile (##sys#slot body 0) e #f tf cntr tl?))
 268			      ((2) (let* ((x1 (compile (##sys#slot body 0) e #f tf cntr tl?))
 269					  (x2 (compile (cadr body) e #f tf cntr tl?)) )
 270				     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) )
 271			      (else
 272			       (let* ((x1 (compile (##sys#slot body 0) e #f tf cntr tl?))
 273				      (x2 (compile (cadr body) e #f tf cntr tl?))
 274				      (x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr tl?)) )
 275				 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ) ) ) ]
 276
 277			 ((##core#ensure-toplevel-definition)
 278			  (unless tl?
 279			    (##sys#error "toplevel definition in non-toplevel context for variable" (cadr x)))
 280                          (##sys#put/restore! (cadr x) '##sys#override 'value)
 281			  (compile
 282			   '(##core#undefined) e #f tf cntr #f))
 283
 284			 [(##core#set!)
 285			  (let ((var (cadr x)))
 286			    (receive (i j) (lookup var e)
 287			      (let ((val (compile (caddr x) e var tf cntr #f)))
 288				(cond ((not i)
 289				       (when ##sys#notices-enabled
 290					 (and-let* ((a (assq var (##sys#current-environment)))
 291						    ((symbol? (cdr a))))
 292					   (##sys#notice "assignment to imported value binding" var)))
 293				       (if static
 294					   (lambda (v)
 295					     (##sys#error 'eval "environment is not mutable" evalenv var)) ;XXX var?
 296					   (let ((var (##sys#alias-global-hook j #t cntr)))
 297					     (lambda (v)
 298					       (let ((result (##core#app val v)))
 299						 (##core#inline "C_i_persist_symbol" var)
 300						 (##sys#setslot var 0 result))))))
 301				      ((zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v))))
 302				      (else
 303				       (lambda (v)
 304					 (##sys#setslot
 305					  (##core#inline "C_u_i_list_ref" v i) j (##core#app val v))))))))]
 306
 307			 [(##core#let)
 308			  (let* ((bindings (cadr x))
 309				 (n (length bindings))
 310				 (vars (map (lambda (x) (car x)) bindings))
 311				 (aliases (map gensym vars))
 312				 (e2 (cons aliases e))
 313				 (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
 314				 (body (parameterize ((##sys#current-environment se2))
 315					 (compile-to-closure
 316					  (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
 317					  e2 cntr evalenv static #f)) ) )
 318			    (case n
 319			      ((1) (let ([val (compile (cadar bindings) e (car vars) tf cntr #f)])
 320				     (lambda (v)
 321				       (##core#app body (cons (vector (##core#app val v)) v)) ) ) )
 322			      ((2) (let ((val1 (compile (cadar bindings) e (car vars) tf cntr #f))
 323					 (val2 (compile (cadadr bindings) e (cadr vars) tf cntr #f)) )
 324				     (lambda (v)
 325				       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) )
 326			      ((3) (let* ((val1 (compile (cadar bindings) e (car vars) tf cntr #f))
 327					  (val2 (compile (cadadr bindings) e (cadr vars) tf cntr #f))
 328					  (t (cddr bindings))
 329					  (val3 (compile (cadar t) e (caddr vars) tf cntr #f)) )
 330				     (lambda (v)
 331				       (##core#app
 332					body
 333					(cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) )
 334			      ((4) (let* ((val1 (compile (cadar bindings) e (car vars) tf cntr #f))
 335					  (val2 (compile (cadadr bindings) e (cadr vars) tf cntr #f))
 336					  (t (cddr bindings))
 337					  (val3 (compile (cadar t) e (caddr vars) tf cntr #f))
 338					  (val4 (compile (cadadr t) e (cadddr vars) tf cntr #f)) )
 339				     (lambda (v)
 340				       (##core#app
 341					body
 342					(cons (vector (##core#app val1 v)
 343						      (##core#app val2 v)
 344						      (##core#app val3 v)
 345						      (##core#app val4 v))
 346					      v)) ) ) )
 347			      [else
 348			       (let ((vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr #f)) bindings)))
 349				 (lambda (v)
 350				   (let ([v2 (##sys#make-vector n)])
 351				     (do ([i 0 (fx+ i 1)]
 352					  [vlist vals (##sys#slot vlist 1)] )
 353					 ((fx>= i n))
 354				       (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
 355				     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
 356
 357			 ((##core#letrec*)
 358			  (let ((bindings (cadr x))
 359				(body (cddr x)) )
 360			    (compile
 361			     `(##core#let
 362			       ,(##sys#map (lambda (b)
 363					     (list (car b) '(##core#undefined)))
 364					   bindings)
 365			       ,@(##sys#map (lambda (b)
 366					      `(##core#set! ,(car b) ,(cadr b)))
 367					    bindings)
 368			       (##core#let () ,@body) )
 369			     e h tf cntr #f)))
 370
 371			((##core#letrec)
 372			 (let* ((bindings (cadr x))
 373				(vars (map car bindings))
 374				(tmps (map gensym vars))
 375				(body (cddr x)) )
 376			   (compile
 377			    `(##core#let
 378			      ,(map (lambda (b)
 379				      (list (car b) '(##core#undefined)))
 380				    bindings)
 381			      (##core#let ,(map (lambda (t b) (list t (cadr b))) tmps bindings)
 382					  ,@(map (lambda (v t)
 383						   `(##core#set! ,v ,t))
 384						 vars tmps)
 385					  (##core#let () ,@body) ) )
 386			      e h tf cntr #f)))
 387
 388			 [(##core#lambda)
 389			  (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f (##sys#current-environment))
 390			  (let* ([llist (cadr x)]
 391				 [body (cddr x)]
 392				 [info (cons (or h '?) llist)] )
 393			    (when (##sys#extended-lambda-list? llist)
 394			      (set!-values
 395			       (llist body)
 396			       (##sys#expand-extended-lambda-list
 397				llist body ##sys#syntax-error (##sys#current-environment)) ) )
 398			    (##sys#decompose-lambda-list
 399			     llist
 400			     (lambda (vars argc rest)
 401			       (let* ((aliases (map gensym vars))
 402				      (se2 (##sys#extend-se (##sys#current-environment) vars aliases))
 403				      (e2 (cons aliases e))
 404				      (body
 405				       (parameterize ((##sys#current-environment se2))
 406					 (compile-to-closure
 407					  (##sys#canonicalize-body body se2 #f)
 408					  e2 (or h cntr) evalenv static #f)) ) )
 409				 (case argc
 410				   [(0) (if rest
 411					    (lambda (v)
 412					      (decorate
 413					       (lambda r
 414						 (##core#app body (cons (vector r) v)))
 415					       info h cntr) )
 416					    (lambda (v)
 417					      (decorate
 418					       (lambda () (##core#app body (cons #f v)))
 419					       info h cntr) ) ) ]
 420				   [(1) (if rest
 421					    (lambda (v)
 422					      (decorate
 423					       (lambda (a1 . r)
 424						 (##core#app body (cons (vector a1 r) v)))
 425					       info h cntr) )
 426					    (lambda (v)
 427					      (decorate
 428					       (lambda (a1)
 429						 (##core#app body (cons (vector a1) v)))
 430					       info h cntr) ) ) ]
 431				   [(2) (if rest
 432					    (lambda (v)
 433					      (decorate
 434					       (lambda (a1 a2 . r)
 435						 (##core#app body (cons (vector a1 a2 r) v)))
 436					       info h cntr) )
 437					    (lambda (v)
 438					      (decorate
 439					       (lambda (a1 a2)
 440						 (##core#app body (cons (vector a1 a2) v)))
 441					       info h cntr) ) ) ]
 442				   [(3) (if rest
 443					    (lambda (v)
 444					      (decorate
 445					       (lambda (a1 a2 a3 . r)
 446						 (##core#app body (cons (vector a1 a2 a3 r) v)))
 447					       info h cntr) )
 448					    (lambda (v)
 449					      (decorate
 450					       (lambda (a1 a2 a3)
 451						 (##core#app body (cons (vector a1 a2 a3) v)))
 452					       info h cntr) ) ) ]
 453				   [(4) (if rest
 454					    (lambda (v)
 455					      (decorate
 456					       (lambda (a1 a2 a3 a4 . r)
 457						 (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
 458					       info h cntr) )
 459					    (lambda (v)
 460					      (decorate
 461					       (lambda (a1 a2 a3 a4)
 462						 (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
 463					       info h cntr) ) ) ]
 464				   [else
 465				    (if rest
 466					(lambda (v)
 467					  (decorate
 468					   (lambda as
 469					     (##core#app
 470					      body
 471					      (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
 472					   info h cntr) )
 473					(lambda (v)
 474					  (decorate
 475					   (lambda as
 476					     (let ([len (length as)])
 477					       (if (not (fx= len argc))
 478						   (##sys#error "bad argument count" argc len)
 479						   (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
 480					   info h cntr) ) ) ] ) ) ) ) ) ]
 481
 482			 ((##core#let-syntax)
 483			  (parameterize
 484			      ((##sys#current-environment
 485				(append
 486				 (map (lambda (b)
 487					(list
 488					 (car b)
 489					 (##sys#current-environment)
 490					 (##sys#ensure-transformer
 491					  (##sys#eval/meta (cadr b))
 492					  (strip-syntax (car b)))))
 493				      (cadr x) )
 494				 (##sys#current-environment)) ) )
 495			    (compile
 496			     (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
 497			     e #f tf cntr #f)))
 498
 499			 ((##core#letrec-syntax)
 500			  (let* ((ms (map (lambda (b)
 501					    (list
 502					     (car b)
 503					     #f
 504					     (##sys#ensure-transformer
 505					      (##sys#eval/meta (cadr b))
 506					      (strip-syntax (car b)))))
 507					  (cadr x) ) )
 508				 (se2 (append ms (##sys#current-environment))) )
 509			    (for-each
 510			     (lambda (sb)
 511			       (set-car! (cdr sb) se2) )
 512			     ms)
 513			    (parameterize ((##sys#current-environment se2))
 514			     (compile
 515			      (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
 516			      e #f tf cntr #f))))
 517
 518			 ((##core#define-syntax)
 519			  (let* ((var (cadr x))
 520				 (body (caddr x))
 521				 (name (rename var)))
 522			    (when (and static (not (assq var (##sys#current-environment))))
 523			      (##sys#error 'eval "environment is not mutable" evalenv var))
 524                            (##sys#put/restore! name '##sys#override 'syntax)
 525			    (##sys#register-syntax-export
 526			     name (##sys#current-module)
 527			     body)	; not really necessary, it only shouldn't be #f
 528			    (##sys#extend-macro-environment
 529			     name
 530			     (##sys#current-environment)
 531			     (##sys#eval/meta body))
 532			    (compile '(##core#undefined) e #f tf cntr #f) ) )
 533
 534			 ((##core#define-compiler-syntax)
 535			  (compile '(##core#undefined) e #f tf cntr #f))
 536
 537			 ((##core#let-compiler-syntax)
 538			  (compile
 539			   (##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
 540			   e #f tf cntr #f))
 541
 542			 ((##core#include)
 543			  (include-file x #f e tf cntr tl?))
 544
 545			 ((##core#include-ci)
 546			  (include-file x #t e tf cntr tl?))
 547
 548                         ((##core#let-module-alias)
 549			  (##sys#with-module-aliases
 550			   (map (lambda (b)
 551				  (##sys#check-syntax 'functor b '(symbol symbol))
 552				  (strip-syntax b))
 553				(cadr x))
 554			   (lambda ()
 555			     (compile `(##core#begin ,@(cddr x)) e #f tf cntr tl?))))
 556
 557			 ((##core#module)
 558			  (let* ((x (strip-syntax x))
 559				 (name (cadr x))
 560				 (exports
 561				  (or (eq? #t (caddr x))
 562				      (map (lambda (exp)
 563					     (cond ((symbol? exp) exp)
 564						   ((and (pair? exp)
 565							 (let loop ((exp exp))
 566							   (or (null? exp)
 567							       (and (symbol? (car exp))
 568								    (loop (cdr exp))))))
 569						    exp)
 570						   (else
 571						    (##sys#syntax-error
 572						     'module
 573						     "invalid export syntax" exp name))))
 574					   (caddr x)))))
 575			    (when (##sys#current-module)
 576			      (##sys#syntax-error 'module "modules may not be nested" name))
 577			    (parameterize ((##sys#current-module
 578					    (##sys#register-module name #f exports))
 579					   (##sys#current-environment '())
 580					   (##sys#macro-environment
 581					    ##sys#initial-macro-environment)
 582					   (##sys#module-alias-environment
 583					    (##sys#module-alias-environment)))
 584			      (##sys#with-property-restore
 585			       (lambda ()
 586				 (let loop ((body (cdddr x)) (xs '()))
 587				   (if (null? body)
 588				       (let ((xs (reverse xs)))
 589					 (##sys#finalize-module (##sys#current-module))
 590					 (##sys#provide (module-requirement name))
 591					 (lambda (v)
 592					   (let loop2 ((xs xs))
 593					     (if (null? xs)
 594						 (##sys#void)
 595						 (let ((n (cdr xs)))
 596						   (cond ((pair? n)
 597							  ((car xs) v)
 598							  (loop2 n))
 599							 (else
 600							  ((car xs) v))))))))
 601				       (loop
 602					(cdr body)
 603					(cons (compile
 604					       (car body)
 605					       '() #f tf cntr
 606					       #t) ; reset back to toplevel!
 607					      xs))))) ) )))
 608
 609			 [(##core#loop-lambda)
 610			  (compile `(,(rename 'lambda) ,@(cdr x)) e #f tf cntr #f) ]
 611
 612			 [(##core#provide)
 613			  (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr #f)]
 614
 615			 [(##core#require-for-syntax)
 616			  (chicken.load#load-extension (cadr x) #f #f)
 617			  (compile '(##core#undefined) e #f tf cntr #f)]
 618
 619			 [(##core#require)
 620			  (let ((lib (cadr x))
 621				(mod (and (pair? (cddr x)) (caddr x))))
 622			    (compile (##sys#process-require lib mod #f) e #f tf cntr #f))]
 623
 624			 [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
 625			  (##sys#eval/meta (cadr x))
 626			  (compile '(##core#undefined) e #f tf cntr tl?) ]
 627
 628			 [(##core#compiletimetoo)
 629			  (compile (cadr x) e #f tf cntr tl?) ]
 630
 631			 [(##core#compiletimeonly ##core#callunit ##core#local-specialization)
 632			  (compile '(##core#undefined) e #f tf cntr tl?) ]
 633
 634			 [(##core#declare)
 635			  (##sys#notice "declarations are ignored in interpreted code" x)
 636			  (compile '(##core#undefined) e #f tf cntr #f) ]
 637
 638			 [(##core#define-inline ##core#define-constant)
 639			  (compile `(,(rename 'define) ,@(cdr x)) e #f tf cntr tl?) ]
 640
 641			 [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
 642					    ##core#define-foreign-variable
 643					    ##core#define-external-variable ##core#let-location
 644					    ##core#foreign-primitive ##core#location
 645					    ##core#foreign-lambda* ##core#define-foreign-type)
 646			  (##sys#syntax-error "cannot evaluate compiler-special-form" x) ]
 647
 648			 [(##core#app)
 649			  (compile-call (cdr x) e tf cntr (##sys#current-environment)) ]
 650
 651			 ((##core#the)
 652			  (compile (cadddr x) e h tf cntr tl?))
 653
 654			 ((##core#typecase)
 655			  ;; drops exp and requires "else" clause
 656			  (cond ((assq 'else (strip-syntax (cdddr x))) =>
 657				 (lambda (cl)
 658				   (compile (cadr cl) e h tf cntr tl?)))
 659				(else
 660				 (##sys#syntax-error
 661				  'compiler-typecase
 662				  "no `else-clause' in unresolved `compiler-typecase' form"
 663				  x))))
 664
 665			 (else
 666			  (fluid-let ((##sys#syntax-context (cons head ##sys#syntax-context)))
 667			    (compile-call x e tf cntr (##sys#current-environment))))))))]
 668
 669	      [else
 670	       (emit-syntax-trace-info tf x cntr)
 671	       (compile-call x e tf cntr (##sys#current-environment))] ) )
 672
 673      (define (fudge-argument-list n alst)
 674	(if (null? alst)
 675	    (list alst)
 676	    (do ((n n (fx- n 1))
 677		 (c 0 (fx+ c 1))
 678		 (args alst
 679		       (if (eq? '() args)
 680			   (##sys#error "bad argument count" n c)
 681			   (##sys#slot args 1)))
 682		 (last #f args) )
 683		((fx= n 0)
 684		 (##sys#setslot last 1 (list args))
 685		 alst) ) ) )
 686
 687      (define (checked-length lst)
 688	(let loop ([lst lst] [n 0])
 689	  (cond [(null? lst) n]
 690		[(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
 691		[else #f] ) ) )
 692
 693      (define (compile-call x e tf cntr se)
 694	(let* ((head (##sys#slot x 0))
 695	       (fn (if (procedure? head)
 696		       (lambda _ head)
 697		       (compile (##sys#slot x 0) e #f tf cntr #f)))
 698	       (args (##sys#slot x 1))
 699	       (argc (checked-length args))
 700	       (info x)
 701	       (ln (or (get-line-number info) "<eval>")))
 702	  (case argc
 703	    ((#f) (##sys#syntax-error/context "malformed expression" x))
 704	    ((0) (lambda (v)
 705		   (emit-trace-info tf ln info cntr e v)
 706		   ((##core#app fn v))))
 707	    ((1) (let ((a1 (compile (##sys#slot args 0) e #f tf cntr #f)))
 708		   (lambda (v)
 709		     (emit-trace-info tf ln info cntr e v)
 710		     ((##core#app fn v) (##core#app a1 v))) ) )
 711	    ((2) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr #f))
 712			(a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr #f)) )
 713		   (lambda (v)
 714		     (emit-trace-info tf ln info cntr e v)
 715		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) )
 716	    ((3) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr #f))
 717			(a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr #f))
 718			(a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr #f)) )
 719		   (lambda (v)
 720		     (emit-trace-info tf ln info cntr e v)
 721		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) )
 722	    ((4) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr #f))
 723			(a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr #f))
 724			(a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr #f))
 725			(a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr #f)) )
 726		   (lambda (v)
 727		     (emit-trace-info tf ln info cntr e v)
 728		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) )
 729	    (else (let ((as (##sys#map (lambda (a) (compile a e #f tf cntr #f)) args)))
 730		    (lambda (v)
 731		      (emit-trace-info tf ln info cntr e v)
 732		      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ) ) ) )
 733
 734      (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr tl?) ) ) )
 735
 736
 737;;; evaluate in the macro-expansion/compile-time environment
 738(define (##sys#eval/meta form)
 739  (parameterize ((##sys#current-module #f)
 740		 (##sys#macro-environment (##sys#meta-macro-environment))
 741		 (##sys#current-environment (##sys#current-meta-environment)))
 742    (dynamic-wind
 743	void
 744	(lambda ()
 745	  ((compile-to-closure
 746	    form
 747	    '()
 748	    #f #f #f
 749	    #t)				; toplevel.
 750	   '()) )
 751	(lambda ()
 752	  ;; Just before restoring the parameters, update "meta"
 753	  ;; environments to receive a copy of the current
 754	  ;; environments one level "down".  We don't support more
 755	  ;; than two evaluation phase levels currently.
 756	  (##sys#current-meta-environment (##sys#current-environment))
 757	  (##sys#meta-macro-environment (##sys#macro-environment))))))
 758
 759(define eval-handler
 760  (make-parameter
 761   (lambda (x #!optional env)
 762     (let ((se (##sys#current-environment)))
 763       ;; When se is empty, it's the first time eval was called:
 764       ;; ensure an active default environment.  We do it here because
 765       ;; eval does not work yet at the end of modules.scm, and we
 766       ;; don't want to inject calls into every toplevel (see #1437)
 767       (when (null? se)
 768	 ((compile-to-closure
 769	   `(##core#begin (import-for-syntax ,@default-syntax-imports)
 770			  (import ,@default-imports))
 771	   '() #f #f #f #t) '()))
 772       (cond (env
 773	      (##sys#check-structure env 'environment 'eval)
 774	      (let ((ve2 (##sys#slot env 2))
 775                    (se2 (##sys#slot env 3)))
 776		((if ve2		; not interaction-environment?
 777                     (parameterize ((##sys#macro-environment se2)
 778                                    (##sys#current-environment ve2))
 779                       (compile-to-closure x '() #f env (##sys#slot env 4) #t))
 780                     (compile-to-closure x '() #f env #f #t))
 781                 '())))
 782	     (else
 783	      ((compile-to-closure x '() #f #f #f #t) '())))))))
 784
 785(set! scheme#eval
 786  (lambda (x . env)
 787    (apply (eval-handler) x env)))
 788
 789;;; User-facing `module-environment` procedure:
 790
 791(define (module-environment name)
 792  (chicken.module#module-environment name))
 793
 794
 795;;; Setting properties dynamically scoped
 796
 797(define-values (##sys#put/restore! ##sys#with-property-restore)
 798  (let ((trail '())
 799	(restoring #f))
 800    (values
 801     (lambda (sym prop val)
 802       (when restoring
 803	 (set! trail (cons (list sym prop (##sys#get sym prop)) trail)))
 804       (##sys#put! sym prop val)
 805       val)
 806     (lambda (thunk)
 807       (let ((t0 #f)
 808	     (r0 restoring))
 809	 (dynamic-wind
 810	     (lambda ()
 811	       (set! t0 trail)
 812	       (set! restoring #t))
 813	     thunk
 814	     (lambda ()
 815	       (do () ((eq? t0 trail))
 816		 (apply ##sys#put! (car trail))
 817		 (set! trail (cdr trail)))
 818	       (set! restoring r0))))))))
 819
 820
 821;;; Split lambda-list into its parts:
 822
 823(define ##sys#decompose-lambda-list
 824  (let ([reverse reverse])
 825    (lambda (llist0 k)
 826
 827      (define (err)
 828	(set! ##sys#syntax-error-culprit #f)
 829	(##sys#syntax-error "illegal lambda-list syntax" llist0) )
 830
 831      (let loop ([llist llist0] [vars '()] [argc 0])
 832	(cond [(eq? llist '()) (k (reverse vars) argc #f)]
 833	      [(not (##core#inline "C_blockp" llist)) (err)]
 834	      [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
 835	      [(not (##core#inline "C_pairp" llist)) (err)]
 836	      [else (loop (##sys#slot llist 1)
 837			  (cons (##sys#slot llist 0) vars)
 838			  (fx+ argc 1) ) ] ) ) ) ) )
 839
 840(set! scheme#interaction-environment
 841  (let ((e (##sys#make-structure 'environment 'interaction-environment #f #f #f)))
 842    (lambda () e)))
 843
 844(set-record-printer! 'environment
 845  (lambda (e p)
 846    (##sys#print "#<environment " #f p)
 847    (##sys#print (##sys#slot e 1) #f p)
 848    (##sys#write-char-0 #\> p)))
 849
 850(let* ((r4s (chicken.module#module-environment 'scheme.r4rs 'scheme-report-environment/4))
 851       (r5s (chicken.module#module-environment 'scheme.r5rs 'scheme-report-environment/5))
 852       (r4n (chicken.module#module-environment 'scheme.r4rs-null 'null-environment/4))
 853       (r5n (chicken.module#module-environment 'scheme.r5rs-null 'null-environment/5)))
 854  (define (strip se)
 855    (foldr
 856     (lambda (s r)
 857       (if (memq (car s)
 858		 '(cond-expand
 859		   define-interface
 860		   delay-force
 861		   export
 862                   export/rename
 863		   functor
 864                   define-library
 865		   import
 866		   import-for-syntax
 867		   import-syntax
 868		   import-syntax-for-syntax
 869		   letrec*
 870		   module
 871		   reexport
 872		   require-library
 873		   syntax))
 874	   r
 875	   (cons s r)))
 876     '()
 877     se))
 878  ;; Strip non-std syntax from SEs
 879  (##sys#setslot r4s 3 (strip (##sys#slot r4s 3)))
 880  (##sys#setslot r4n 3 (strip (##sys#slot r4n 3)))
 881  (##sys#setslot r5s 3 (strip (##sys#slot r5s 3)))
 882  (##sys#setslot r5n 3 (strip (##sys#slot r5n 3)))
 883  (set! scheme#scheme-report-environment
 884    (lambda (n)
 885      (##sys#check-fixnum n 'scheme-report-environment)
 886      (case n
 887	((4) r4s)
 888	((5) r5s)
 889	(else
 890	 (##sys#error
 891	  'scheme-report-environment
 892	  "unsupported scheme report environment version" n)))))
 893  (set! scheme#null-environment
 894    (lambda (n)
 895      (##sys#check-fixnum n 'null-environment)
 896      (case n
 897	((4) r4n)
 898	((5) r5n)
 899	(else
 900	 (##sys#error
 901	  'null-environment
 902	  "unsupported null environment version" n))))))
 903
 904) ; eval module
 905
 906
 907(module chicken.load
 908  (dynamic-load-libraries set-dynamic-load-mode!
 909   load-library load-noisily load-relative load-verbose
 910   provide provided? require)
 911
 912(import scheme
 913	chicken.base
 914	chicken.eval
 915	chicken.fixnum
 916	chicken.foreign
 917	chicken.internal
 918	chicken.platform
 919	chicken.syntax
 920	chicken.time)
 921(import (only (scheme base) make-parameter port?))
 922
 923(include "mini-srfi-1.scm")
 924
 925;;; Installation locations
 926
 927(define-foreign-variable binary-version int "C_BINARY_VERSION")
 928(define-foreign-variable install-lib-name c-string "C_INSTALL_LIB_NAME")
 929(define-foreign-variable uses-soname? bool "C_USES_SONAME")
 930
 931;;; Core unit information
 932
 933;; this maps built-in library names to require forms when the mapping isn't 1:1
 934(define-constant core-unit-requirements
 935  '((chicken.foreign
 936     . (##core#require-for-syntax chicken-ffi-syntax))
 937    (chicken.condition
 938     . (##core#begin
 939	(##core#require-for-syntax chicken-syntax)
 940	(##core#require library)))))
 941
 942;; this list contains built-in units that are provided by libchicken
 943;; and should not be treated as separate extension libraries during
 944;; linking (they are omitted from types/inline/link files etc.)
 945(define-constant core-units
 946  '(chicken-syntax chicken-ffi-syntax continuation data-structures
 947    debugger-client eval eval-modules expand extras file internal
 948    irregex library lolevel pathname port posix profiler read-syntax
 949    repl scheduler srfi-4 tcp r7lib))
 950
 951(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
 952(define-constant macosx-load-library-extension ".dylib")
 953(define-constant windows-load-library-extension ".dll")
 954(define-constant hppa-load-library-extension ".sl")
 955(define-constant default-load-library-extension ".so")
 956(define-constant source-file-extension ".scm")
 957
 958(define load-library-extension
 959  (cond ((eq? (software-type) 'windows) windows-load-library-extension)
 960	((eq? (software-version) 'macosx) macosx-load-library-extension)
 961	((and (eq? (software-version) 'hpux)
 962	      (eq? (machine-type) 'hppa)) hppa-load-library-extension)
 963	(else default-load-library-extension)))
 964
 965(define ##sys#load-dynamic-extension default-load-library-extension)
 966
 967(define (chicken.load#core-library? id) ; used by core.scm
 968  (or (memq id core-units)
 969      (assq id core-unit-requirements)))
 970
 971(define default-dynamic-load-libraries
 972  (case (software-version)
 973    ((cygwin) cygwin-default-dynamic-load-libraries)
 974    (else `(,(string-append "lib" install-lib-name)))))
 975
 976
 977;;; Library registration (used for code loading):
 978
 979(define (##sys#provide id)
 980  (##core#inline_allocate ("C_a_i_provide" 8) id))
 981
 982(define (##sys#provided? id)
 983  (##core#inline "C_i_providedp" id))
 984
 985
 986;;; Pathname helpers:
 987
 988(define path-separators
 989  (if ##sys#windows-platform '(#\\ #\/) '(#\/)))
 990
 991(define (path-separator-index/right s)
 992  (let loop ((i (fx- (string-length s) 1)))
 993    (if (memq (string-ref s i) path-separators)
 994	i
 995	(and (fx< 0 i) (loop (fx- i 1))))))
 996
 997(define (make-relative-pathname from file)
 998  (let ((i (and (string? from)
 999		(positive? (string-length file)) ; XXX probably an error?
 1000		(not (memq (string-ref file 0) path-separators))
1001		(path-separator-index/right from))))
1002    (if (not i) file (string-append (##sys#substring from 0 i) "/" file))))
1003
1004
1005;;; Loading source/object files:
1006
1007(define load-verbose (make-parameter (##sys#debug-mode?)))
1008
1009(define ##sys#current-load-filename #f)
1010(define ##sys#dload-disabled #f)
1011
1012(define-foreign-variable _dlerror c-string "C_dlerror")
1013
1014(define (set-dynamic-load-mode! mode)
1015  (let ([mode (if (pair? mode) mode (list mode))]
1016	[now #f]
1017	[global #t] )
1018    (let loop ([mode mode])
1019      (when (pair? mode)
1020	(case (##sys#slot mode 0)
1021	  [(global) (set! global #t)]
1022	  [(local) (set! global #f)]
1023	  [(lazy) (set! now #f)]
1024	  [(now) (set! now #t)]
1025	  [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
1026	(loop (##sys#slot mode 1)) ) )
1027    (##sys#set-dlopen-flags! now global) ) )
1028
1029(define (toplevel name)
1030  (if (not name)
1031      "toplevel"
1032      (##sys#string-append
1033       (string->c-identifier (##sys#symbol->string/shared name))
1034       "_toplevel")))
1035
1036(define (c-toplevel name loc)
1037  (##sys#make-c-string (##sys#string-append "C_" (toplevel name)) loc))
1038
1039(define load/internal
1040  (let ((write write)
1041	(display display)
1042	(newline newline)
1043	(eval eval)
1044        (case-sensitive case-sensitive)
1045	(open-input-file open-input-file)
1046	(close-input-port close-input-port))
1047    (lambda (input evaluator #!optional pf timer printer unit)
1048
1049      (define evalproc
1050	(or evaluator eval))
1051
1052      ;; dload doesn't consider filenames without slashes to be paths,
1053      ;; so we prepend a dot to force a relative pathname.
1054      (define (dload-path path)
1055	(if (path-separator-index/right path)
1056	    path
1057	    (##sys#string-append "./" path)))
1058
1059      (define (dload path)
1060	(let ((c-path (##sys#make-c-string (dload-path path) 'load)))
1061	  (or (##sys#dload c-path (c-toplevel unit 'load))
1062	      (and (symbol? unit)
1063		   (##sys#dload c-path (c-toplevel #f 'load))))))
1064
1065      (define dload?
1066	(and (not ##sys#dload-disabled)
1067	     (feature? #:dload)))
1068
1069      (define fname
1070	(cond ((port? input) #f)
1071	      ((not (string? input))
1072	       (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" input))
1073	      ((##sys#file-exists? input #t #f 'load) input)
1074	      ((let ((f (##sys#string-append input ##sys#load-dynamic-extension)))
1075		 (and dload? (##sys#file-exists? f #t #f 'load) f)))
1076	      ((let ((f (##sys#string-append input source-file-extension)))
1077		 (and (##sys#file-exists? f #t #f 'load) f)))
1078	      (else
1079	       (##sys#signal-hook #:file-error 'load "cannot open file" input))))
1080
1081      (when (and (load-verbose) fname)
1082	(display "; loading ")
1083	(display fname)
1084	(display " ...\n")
1085	(flush-output))
1086
1087      (or (and fname dload? (dload fname))
1088	  (call-with-current-continuation
1089	   (lambda (abrt)
1090	     (fluid-let ((##sys#read-error-with-line-number #t)
1091			 (##sys#current-load-filename fname)
1092			 (##sys#current-source-filename fname))
1093	       (let ((in (if fname (open-input-file fname) input))
1094                     (cs (case-sensitive))
1095		     (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
1096		 (##sys#dynamic-wind
1097		  (lambda () (set! cs (case-sensitive)))
1098		  (lambda ()
1099		    (let ((c1 (peek-char in)))
1100		      (when (eq? c1 (integer->char 127))
1101			(##sys#error
1102			 'load
1103			 (##sys#string-append
1104			  "unable to load compiled module - "
1105			  (or _dlerror "unknown reason"))
1106			 fname)))
1107		    (let ((x1 (read-with-source-info in)))
1108		      (do ((x x1 (read-with-source-info in)))
1109			  ((eof-object? x))
1110			(when printer (printer x))
1111			(##sys#call-with-values
1112			 (lambda ()
1113			   (if timer
1114			       (time (evalproc x))
1115			       (evalproc x)))
1116			 (lambda results
1117			   (when pf
1118			     (for-each
1119			      (lambda (r)
1120				(write r)
1121				(newline))
1122			      results)))))))
1123		  (lambda ()
1124                    (case-sensitive cs)
1125		    (close-input-port in))))))))
1126      (##core#undefined))))
1127
1128(define evaluator
1129  (let ((eval eval))
1130    (lambda (x)
1131      (cond ((procedure? x) x)
1132            ((not x) #f)
1133            (else (lambda (y) (eval y x)))))))
1134
1135(set! scheme#load
1136  (lambda (filename #!optional env)
1137    (load/internal filename (evaluator env))))
1138
1139(define (load-relative filename #!optional env)
1140  (let ((fn (make-relative-pathname ##sys#current-load-filename filename)))
1141    (load/internal fn (evaluator env))))
1142
1143(define (load-noisily filename #!key env (time #f) (printer #f))
1144  (load/internal filename (evaluator env) #t time printer))
1145
1146(define dynamic-load-libraries
1147  (let ((ext
1148	 (if uses-soname?
1149	     (string-append
1150	      load-library-extension
1151	      "."
1152	      (number->string binary-version))
1153	     load-library-extension)))
1154    (define complete
1155      (cut ##sys#string-append <> ext))
1156    (make-parameter
1157     (map complete default-dynamic-load-libraries)
1158     (lambda (x)
1159       (##sys#check-list x)
1160       x) ) ) )
1161
1162(define (load-unit unit-name lib loc)
1163  (unless (##sys#provided? unit-name)
1164    (let ((libs
1165	   (if lib
1166	       (##sys#list lib)
1167	       (cons (##sys#string-append (##sys#symbol->string/shared unit-name) load-library-extension)
1168		     (dynamic-load-libraries))))
1169	  (top
1170	   (c-toplevel unit-name loc)))
1171      (when (load-verbose)
1172	(display "; loading library ")
1173	(display unit-name)
1174	(display " ...\n"))
1175      (let loop ((libs libs))
1176	(cond ((null? libs)
1177	       (##sys#error loc "unable to load library" unit-name (or _dlerror "library not found")))
1178	      ((##sys#dload (##sys#make-c-string (##sys#slot libs 0) 'load-library) top)
1179	       (##core#undefined))
1180	      (else
1181	       (loop (##sys#slot libs 1))))))))
1182
1183(define (load-library unit-name #!optional lib)
1184  (##sys#check-symbol unit-name 'load-library)
1185  (unless (not lib) (##sys#check-string lib 'load-library))
1186  (load-unit unit-name lib 'load-library))
1187
1188(define ##sys#include-forms-from-file
1189  (let ((call-with-input-file call-with-input-file)
1190	(reverse reverse))
1191    (lambda (filename source ci k)
1192      (let ((path (##sys#resolve-include-filename filename #t #f source))
1193	    (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
1194	(when (not path)
1195	  (##sys#signal-hook #:file-error 'include "cannot open file" filename))
1196	(when (load-verbose)
1197	  (print "; including " path " ..."))
1198	(call-with-input-file path
1199	  (lambda (in)
1200	    (let ((oldci (##sys#slot in 13)))
1201  	     (k (fluid-let ((##sys#current-source-filename path))
1202                 (##sys#setislot in 13 (not ci))
1203                 (do ((x (read-with-source-info in) (read-with-source-info in))
1204                      (xs '() (cons x xs)))
1205                     ((eof-object? x)
1206                      (##sys#setislot in 13 oldci)
1207                      (reverse xs))))
1208                path))))))))
1209
1210
1211;;; Extensions:
1212
1213(define ##sys#setup-mode #f)
1214
1215(define (file-exists? name) ; defined here to avoid file unit dependency
1216  (and (##sys#file-exists? name #t #f #f) name))
1217
1218(define (find-file name search-path)
1219  (cond ((not search-path) #f)
1220        ((null? search-path) #f)
1221        ((string? search-path) (find-file name (list search-path)))
1222        ((file-exists? (string-append (car search-path) "/" name)))
1223        (else (find-file name (cdr search-path)))))
1224
1225(define find-dynamic-extension
1226  (let ((string-append string-append))
1227    (lambda (id inc?)
1228      (let ((rp (repository-path))
1229	    (basename (if (symbol? id) (symbol->string id) id)))
1230	(define (check path)
1231	  (let ((p0 (string-append path "/" basename)))
1232	    (or (and rp
1233		     (not ##sys#dload-disabled)
1234		     (feature? #:dload)
1235		     (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
1236		(file-exists? (##sys#string-append p0 source-file-extension)))))
1237	(let loop ((paths (##sys#append
1238			   (if ##sys#setup-mode '(".") '())
1239			   (or rp '())
1240			   (if inc? ##sys#include-pathnames '())
1241			   (if ##sys#setup-mode '() '("."))) ))
1242	  (and (pair? paths)
1243	       (let ((pa (##sys#slot paths 0)))
1244		 (or (check pa)
1245		     (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
1246
1247(define-inline (extension-loaded? lib mod)
1248  (cond ((##sys#provided? lib))
1249	((eq? mod #t)
1250	 (##sys#provided? (module-requirement lib)))
1251	((symbol? mod)
1252	 (##sys#provided? (module-requirement mod)))
1253	(else #f)))
1254
1255(define (load-extension lib mod loc)
1256  (unless (extension-loaded? lib mod)
1257    (cond ((memq lib core-units)
1258	   (load-unit lib #f loc))
1259	  ((find-dynamic-extension lib #f) =>
1260	   (lambda (ext)
1261	     (load/internal ext #f #f #f #f #f lib)
1262	     (##sys#provide lib)
1263	     (##core#undefined)))
1264	  (else
1265	   (##sys#error loc "cannot load extension" lib)))))
1266
1267(define (require . ids)
1268  (for-each (cut ##sys#check-symbol <> 'require) ids)
1269  (for-each (cut load-extension <> #f 'require) ids))
1270
1271(define (provide . ids)
1272  (for-each (cut ##sys#check-symbol <> 'provide) ids)
1273  (for-each (cut ##sys#provide <>) ids))
1274
1275(define (provided? . ids)
1276  (for-each (cut ##sys#check-symbol <> 'provided?) ids)
1277  (every ##sys#provided? ids))
1278
1279;; Export for internal use in the expansion of `##core#require':
1280(define chicken.load#load-unit load-unit)
1281(define chicken.load#load-extension load-extension)
1282
1283;; Export for internal use in csc, modules and batch-driver:
1284(define chicken.load#find-file find-file)
1285(define chicken.load#find-dynamic-extension find-dynamic-extension)
1286
1287;; Do the right thing with a `##core#require' form.
1288(define (##sys#process-require lib mod compile-mode)
1289  (let ((mod (or (eq? lib mod) mod)))
1290    (cond
1291      ((assq lib core-unit-requirements) => cdr)
1292      ((memq lib core-units)
1293       (if compile-mode
1294           `(##core#callunit ,lib)
1295           `(chicken.load#load-unit (##core#quote ,lib)
1296                                    (##core#quote #f)
1297                                    (##core#quote #f))))
1298      ((eq? compile-mode 'static)
1299       `(##core#callunit ,lib))
1300      (else
1301       `(chicken.load#load-extension (##core#quote ,lib)
1302                                     (##core#quote ,mod)
1303                                     (##core#quote #f))))))
1304
1305;;; Find included file:
1306
1307(define ##sys#resolve-include-filename
1308  (let ((string-append string-append) )
1309    (lambda (fname exts repo source)
1310      (define (test-extensions fname lst)
1311	(if (null? lst)
1312	    (and (file-exists? fname) fname)
1313	    (let ((fn (##sys#string-append fname (car lst))))
1314	      (or (file-exists? fn)
1315		  (test-extensions fname (cdr lst))))))
1316      (define (test fname)
1317	(test-extensions
1318	 fname
1319	 (cond ((pair? exts) exts)       ; specific list of extensions
1320	       ((not (feature? #:dload)) ; no dload -> source only
1321		(list source-file-extension))
1322	       ((not exts)               ; prefer compiled
1323		(list ##sys#load-dynamic-extension source-file-extension))
1324	       (else                     ; prefer source
1325		(list source-file-extension ##sys#load-dynamic-extension)))))
1326      (or (test (make-relative-pathname source fname))
1327	  (let loop ((paths (if repo
1328				(##sys#append
1329				 ##sys#include-pathnames
1330				 (or (repository-path) '()) )
1331				##sys#include-pathnames) ) )
1332	    (cond ((eq? paths '()) #f)
1333		  ((test (string-append (##sys#slot paths 0)
1334					"/"
1335					fname) ) )
1336		  (else (loop (##sys#slot paths 1))) ) ) ) ) ) )
1337
1338) ; chicken.load
1339
1340
1341;;; Simple invocation API:
1342
1343(import scheme chicken.base chicken.condition chicken.eval chicken.fixnum chicken.load)
1344(import (only (scheme base) open-output-string get-output-string open-input-string))
1345
1346(declare
1347  (hide last-error run-safe store-result store-string
1348	CHICKEN_yield CHICKEN_eval CHICKEN_eval_string
1349	CHICKEN_eval_to_string CHICKEN_eval_string_to_string
1350	CHICKEN_apply CHICKEN_apply_to_string CHICKEN_eval_apply
1351	CHICKEN_read CHICKEN_load CHICKEN_get_error_message))
1352
1353(define last-error #f)
1354
1355(define (run-safe thunk)
1356  (set! last-error #f)
1357  (handle-exceptions ex
1358      (let ((o (open-output-string)))
1359	(print-error-message ex o)
1360	(set! last-error (get-output-string o))
1361	#f)
1362    (thunk) ) )
1363
1364#>
1365#define C_store_result(x, ptr)   (*((C_word *)C_block_item(ptr, 0)) = (x), C_SCHEME_TRUE)
1366<#
1367
1368(define (store-result x result)
1369  (##sys#gc #f)
1370  (when result
1371    (##core#inline "C_store_result" x result) )
1372  #t)
1373
1374(define-external (CHICKEN_yield) bool
1375  (run-safe (lambda () (begin (##sys#thread-yield!) #t))) )
1376
1377(define-external (CHICKEN_eval (scheme-object exp) ((c-pointer "C_word") result)) bool
1378  (run-safe
1379   (lambda ()
1380     (store-result (eval exp) result))))
1381
1382(define-external (CHICKEN_eval_string (c-string str) ((c-pointer "C_word") result)) bool
1383  (run-safe
1384   (lambda ()
1385     (let ((i (open-input-string str)))
1386       (store-result (eval (read i)) result)))))
1387
1388#>
1389#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)
1390<#
1391
1392(define (store-string str bufsize buf)
1393  (let* ((bv (##sys#slot str 0))
1394         (len (fx- (##sys#size bv) 1)))
1395    (cond ((fx>= len bufsize)
1396	   (set! last-error "Error: not enough room for result string")
1397	   #f)
1398	  (else (##core#inline "C_copy_result_string" bv buf len)) ) ) )
1399
1400(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
1401					  (int bufsize))
1402  bool
1403  (run-safe
1404   (lambda ()
1405     (let ((o (open-output-string)))
1406       (write (eval exp) o)
1407       (store-string (get-output-string o) bufsize buf)) ) ) )
1408
1409(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
1410						 (int bufsize) )
1411  bool
1412  (run-safe
1413   (lambda ()
1414     (let ((o (open-output-string)))
1415       (write (eval (read (open-input-string str))) o)
1416       (store-string (get-output-string o) bufsize buf)) ) ) )
1417
1418(define-external (CHICKEN_apply (scheme-object func) (scheme-object args)
1419				 ((c-pointer "C_word") result))
1420  bool
1421  (run-safe (lambda () (store-result (apply func args) result))) )
1422
1423(define-external (CHICKEN_apply_to_string (scheme-object func) (scheme-object args)
1424					   ((c-pointer "char") buf) (int bufsize))
1425  bool
1426  (run-safe
1427   (lambda ()
1428     (let ((o (open-output-string)))
1429       (write (apply func args) o)
1430       (store-string (get-output-string o) bufsize buf)) ) ) )
1431
1432(define-external (CHICKEN_read (c-string str) ((c-pointer "C_word") result)) bool
1433  (run-safe
1434   (lambda ()
1435     (let ((i (open-input-string str)))
1436       (store-result (read i) result) ) ) ) )
1437
1438(define-external (CHICKEN_load (c-string str)) bool
1439  (run-safe (lambda () (load str) #t)))
1440
1441(define-external (CHICKEN_get_error_message ((c-pointer "char") buf) (int bufsize)) void
1442  (store-string (or last-error "No error") bufsize buf) )