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