~ chicken-core (chicken-5) /modules.scm

   1;;;; modules.scm - module-system support
   2;
   3; Copyright (c) 2011-2022, The CHICKEN Team
   4; All rights reserved.
   5;
   6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   7; conditions are met:
   8;
   9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  10;     disclaimer. 
  11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  12;     disclaimer in the documentation and/or other materials provided with the distribution. 
  13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  14;     products derived from this software without specific prior written permission. 
  15;
  16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  24; POSSIBILITY OF SUCH DAMAGE.
  25
  26
  27;; this unit needs the "eval" unit, but must be initialized first, so it doesn't
  28;; declare "eval" as used - if you use "-explicit-use", take care of this.
  29
  30(declare
  31  (unit modules)
  32  (uses chicken-syntax)
  33  (disable-interrupts)
  34  (fixnum)
  35  (not inline ##sys#alias-global-hook)
  36  (hide check-for-redef compiled-module-dependencies find-export
  37	find-module/import-library match-functor-argument merge-se
  38	module-indirect-exports module-rename register-undefined))
  39
  40(import scheme
  41	chicken.base
  42	chicken.internal
  43	chicken.keyword
  44	chicken.platform
  45	chicken.syntax
  46	(only chicken.string string-split)
  47	(only chicken.format fprintf format))
  48
  49(include "common-declarations.scm")
  50(include "mini-srfi-1.scm")
  51
  52(define-syntax d (syntax-rules () ((_ . _) (void))))
  53
  54(define-alias dd d)
  55(define-alias dm d)
  56(define-alias dx d)
  57
  58#+debugbuild
  59(define (map-se se)
  60  (map (lambda (a) 
  61	 (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
  62       se))
  63
  64(define-inline (getp sym prop)
  65  (##core#inline "C_i_getprop" sym prop #f))
  66
  67(define-inline (putp sym prop val)
  68  (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
  69
  70(define-inline (namespaced-symbol? sym)
  71  (##core#inline "C_u_i_namespaced_symbolp" sym))
  72
  73;;; Support definitions
  74
  75;;; low-level module support
  76
  77(define ##sys#current-module (make-parameter #f))
  78(define ##sys#module-alias-environment (make-parameter '()))
  79
  80(declare 
  81  (hide make-module module? %make-module
  82	module-name module-library
  83	module-vexports module-sexports
  84	set-module-vexports! set-module-sexports!
  85	module-export-list set-module-export-list! 
  86	module-defined-list set-module-defined-list!
  87	module-import-forms set-module-import-forms!
  88	module-meta-import-forms set-module-meta-import-forms!
  89	module-exist-list set-module-exist-list!
  90	module-meta-expressions set-module-meta-expressions!
  91	module-defined-syntax-list set-module-defined-syntax-list!
  92	module-saved-environments set-module-saved-environments!
  93	module-iexports set-module-iexports!
  94        module-rename-list set-module-rename-list!))
  95
  96(define-record-type module
  97  (%make-module name library export-list defined-list exist-list defined-syntax-list
  98		undefined-list import-forms meta-import-forms meta-expressions 
  99		vexports sexports iexports saved-environments rename-list) 
 100  module?
 101  (name module-name)			; SYMBOL
 102  (library module-library)		; SYMBOL
 103  (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
 104  (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...)    - *exported* value definitions
 105  (exist-list module-exist-list set-module-exist-list!)	      ; (SYMBOL ...)    - only for checking refs to undef'd
 106  (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
 107  (undefined-list module-undefined-list set-module-undefined-list!) ; ((SYMBOL WHERE1 ...) ...)
 108  (import-forms module-import-forms set-module-import-forms!)	    ; (SPEC ...)
 109  (meta-import-forms module-meta-import-forms set-module-meta-import-forms!)	    ; (SPEC ...)
 110  (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
 111  (vexports module-vexports set-module-vexports!)	      ; ((SYMBOL . SYMBOL) ...)
 112  (sexports module-sexports set-module-sexports!)	      ; ((SYMBOL SE TRANSFORMER) ...)
 113  (iexports module-iexports set-module-iexports!)	      ; ((SYMBOL . SYMBOL) ...)
 114  ;; for csi's ",m" command, holds (<env> . <macroenv>)
 115  (saved-environments module-saved-environments set-module-saved-environments!)
 116  (rename-list module-rename-list set-module-rename-list!))
 117
 118(define ##sys#module-name module-name)
 119
 120(define (##sys#module-exports m)
 121  (values 
 122   (module-export-list m)
 123   (module-vexports m)
 124   (module-sexports m)))
 125
 126(define (make-module name lib explist vexports sexports iexports #!optional (renames '()))
 127  (%make-module name lib explist '() '() '() '() '() '() '() vexports sexports iexports #f
 128                renames))
 129
 130(define (##sys#register-module-alias alias name)
 131  (##sys#module-alias-environment
 132    (cons (cons alias name) (##sys#module-alias-environment))))
 133
 134(define (##sys#with-module-aliases bindings thunk)
 135  (parameterize ((##sys#module-alias-environment
 136		  (append
 137		   (map (lambda (b) (cons (car b) (cadr b))) bindings)
 138		   (##sys#module-alias-environment))))
 139    (thunk)))
 140
 141(define (##sys#resolve-module-name name loc)
 142  (let loop ((n (library-id name)) (done '()))
 143    (cond ((assq n (##sys#module-alias-environment)) =>
 144	   (lambda (a)
 145	     (let ((n2 (cdr a)))
 146	       (if (memq n2 done)
 147		   (error loc "module alias refers to itself" name)
 148		   (loop n2 (cons n2 done))))))
 149	  (else n))))
 150
 151(define (##sys#find-module name #!optional (err #t) loc)
 152  (cond ((assq name ##sys#module-table) => cdr)
 153	(err (error loc "module not found" name))
 154	(else #f)))
 155
 156(define ##sys#switch-module
 157  (let ((saved-default-envs #f))
 158    (lambda (mod)
 159      (let ((now (cons (##sys#current-environment) (##sys#macro-environment))))
 160	(cond ((##sys#current-module) =>
 161	       (lambda (m)
 162		 (set-module-saved-environments! m now)))
 163	      (else 
 164	       (set! saved-default-envs now)))
 165	(let ((saved (if mod (module-saved-environments mod) saved-default-envs)))
 166	  (when saved
 167	    (##sys#current-environment (car saved))
 168	    (##sys#macro-environment (cdr saved)))
 169	  (##sys#current-module mod))))))
 170
 171(define (##sys#add-to-export-list mod exps)
 172  (let ((xl (module-export-list mod)))
 173    (if (eq? xl #t)
 174	(let ((el (module-exist-list mod))
 175	      (me (##sys#macro-environment))
 176	      (sexps '()))
 177	  (for-each
 178	   (lambda (exp)
 179	     (cond ((assq exp me) =>
 180		    (lambda (a)
 181		      (set! sexps (cons a sexps))))))
 182	   exps)
 183	  (set-module-sexports! mod (append sexps (module-sexports mod)))
 184	  (set-module-exist-list! mod (append el exps)))
 185	(set-module-export-list! mod (append xl exps)))))
 186
 187(define (##sys#add-to-export/rename-list mod renames)
 188  (let ((rl (module-rename-list mod)))
 189    (set-module-rename-list! mod (append rl renames))
 190    (##sys#add-to-export-list mod (map car renames))))
 191
 192(define (##sys#toplevel-definition-hook sym renamed exported?) #f)
 193
 194(define (##sys#register-meta-expression exp)
 195  (and-let* ((mod (##sys#current-module)))
 196    (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
 197
 198(define (check-for-redef sym env senv)
 199  (and-let* ((a (assq sym env)))
 200    (##sys#warn "redefinition of imported value binding" sym) )
 201  (and-let* ((a (assq sym senv)))
 202    (##sys#warn "redefinition of imported syntax binding" sym)))
 203
 204(define (##sys#register-export sym mod)
 205  (when mod
 206    (let ((exp (or (eq? #t (module-export-list mod))
 207		   (find-export sym mod #t)))
 208	  (ulist (module-undefined-list mod)))
 209      (##sys#toplevel-definition-hook	; in compiler, hides unexported bindings
 210       sym (module-rename sym (module-name mod)) exp)
 211      (and-let* ((a (assq sym ulist)))
 212	(set-module-undefined-list! mod (delete a ulist eq?)))
 213      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
 214      (set-module-exist-list! mod (cons sym (module-exist-list mod)))
 215      (when exp
 216	(dm "defined: " sym)
 217	(set-module-defined-list! 
 218	 mod
 219	 (cons (cons sym #f)
 220	       (module-defined-list mod)))))) )
 221
 222(define (##sys#register-syntax-export sym mod val)
 223  (when mod
 224    (let ((exp (or (eq? #t (module-export-list mod))
 225		   (find-export sym mod #t)))
 226	  (ulist (module-undefined-list mod))
 227	  (mname (module-name mod)))
 228      (when (assq sym ulist)	    
 229	(##sys#warn "use of syntax precedes definition" sym)) ;XXX could report locations
 230      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
 231      (dm "defined syntax: " sym)
 232      (when exp
 233	(set-module-defined-list! 
 234	 mod
 235	 (cons (cons sym val)
 236	       (module-defined-list mod))) )
 237      (set-module-defined-syntax-list! 
 238       mod
 239       (cons (cons sym val) (module-defined-syntax-list mod))))))
 240
 241(define (##sys#unregister-syntax-export sym mod)
 242  (when mod
 243    (set-module-defined-syntax-list!
 244     mod
 245     (delete sym (module-defined-syntax-list mod) (lambda (x y) (eq? x (car y)))))))
 246
 247(define (register-undefined sym mod where)
 248  (when mod
 249    (let ((ul (module-undefined-list mod)))
 250      (cond ((assq sym ul) =>
 251	     (lambda (a)
 252	       (when (and where (not (memq where (cdr a))))
 253		 (set-cdr! a (cons where (cdr a))))))
 254	    (else
 255	     (set-module-undefined-list!
 256	      mod
 257	      (cons (cons sym (if where (list where) '())) ul)))))))
 258
 259(define (##sys#register-module name lib explist #!optional (vexports '()) (sexports '()))
 260  (let ((mod (make-module name lib explist vexports sexports '())))
 261    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
 262    mod) )
 263
 264(define (module-indirect-exports mod)
 265  (let ((exports (module-export-list mod))
 266	(mname (module-name mod))
 267	(dlist (module-defined-list mod)))
 268    (define (indirect? id)
 269      (let loop ((exports exports))
 270	(and (not (null? exports))
 271	     (or (and (pair? (car exports))
 272		      (memq id (cdar exports)))
 273		 (loop (cdr exports))))))
 274    (define (warn msg id)
 275      (##sys#warn
 276       (string-append msg " in module `" (symbol->string mname) "'")
 277       id))
 278    (if (eq? #t exports)
 279	'()
 280	(let loop ((exports exports))	; walk export list
 281	  (cond ((null? exports) '())
 282		((symbol? (car exports)) (loop (cdr exports))) ; normal export
 283		(else
 284		 (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
 285		   (cond ((null? iexports) (loop (cdr exports)))
 286			 ((assq (car iexports) (##sys#macro-environment))
 287			  (warn "indirect export of syntax binding" (car iexports))
 288			  (loop2 (cdr iexports)))
 289			 ((assq (car iexports) dlist) => ; defined in current module?
 290			  (lambda (a) 
 291			    (cons 
 292			     (cons 
 293			      (car iexports)
 294			      (or (cdr a) (module-rename (car iexports) mname)))
 295			     (loop2 (cdr iexports)))))
 296			 ((assq (car iexports) (##sys#current-environment)) =>
 297			  (lambda (a)	; imported in current env.
 298			    (cond ((symbol? (cdr a)) ; not syntax
 299				   (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
 300				  (else
 301				   (warn "indirect reexport of syntax" (car iexports))
 302				   (loop2 (cdr iexports))))))
 303			 (else 
 304			  (warn "indirect export of unknown binding" (car iexports))
 305			  (loop2 (cdr iexports)))))))))))
 306
 307(define (merge-se . ses*) ; later occurrences take precedence to earlier ones
 308  (let ((seen (make-hash-table)) (rses (reverse ses*)))
 309    (let loop ((ses (cdr rses)) (last-se #f) (se2 (car rses)))
 310      (cond ((null? ses) se2)
 311	    ((or (eq? last-se (car ses)) (null? (car ses)))
 312	     (loop (cdr ses) last-se se2))
 313	    ((not last-se)
 314             (for-each (lambda (e) (hash-table-set! seen (car e) #t)) se2)
 315	     (loop ses se2 se2))
 316	    (else (let lp ((se (car ses)) (se2 se2))
 317		    (cond ((null? se) (loop (cdr ses) (car ses) se2))
 318			  ((hash-table-ref seen (caar se))
 319			   (lp (cdr se) se2))
 320			  (else (hash-table-set! seen (caar se) #t)
 321				(lp (cdr se) (cons (car se) se2))))))))))
 322
 323(define (compiled-module-dependencies mod)
 324  (let ((libs (filter-map ; extract library names
 325	       (lambda (x) (nth-value 1 (##sys#decompose-import x o eq? 'module)))
 326	       (module-import-forms mod))))
 327    (map (lambda (lib) `(##core#require ,lib))
 328	 (delete-duplicates libs eq?))))
 329
 330(define (##sys#compiled-module-registration mod compile-mode)
 331  (let ((dlist (module-defined-list mod))
 332	(mname (module-name mod))
 333	(ifs (module-import-forms mod))
 334	(sexports (module-sexports mod))
 335	(mifs (module-meta-import-forms mod)))
 336    `((##sys#with-environment
 337        (lambda ()
 338	  ,@(if (and (eq? compile-mode 'static) (pair? ifs) (pair? sexports))
 339		(compiled-module-dependencies mod)
 340		'())
 341          ,@(if (and (pair? ifs) (pair? sexports))
 342   	        `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
 343  	        '())
 344          ,@(if (and (pair? mifs) (pair? sexports))
 345     	        `((import-syntax ,@(strip-syntax mifs)))
 346	        '())
 347          ,@(if (or (getp mname '##core#functor) (pair? sexports))
 348 	        (##sys#fast-reverse (strip-syntax (module-meta-expressions mod)))
 349	        '())
 350          (##sys#register-compiled-module
 351            ',(module-name mod)
 352            ',(module-library mod)
 353            (scheme#list			; iexports
 354	      ,@(map (lambda (ie)
 355                       (if (symbol? (cdr ie))
 356                           `'(,(car ie) . ,(cdr ie))
 357                           `(scheme#list ',(car ie) '() ,(cdr ie))))
 358                 (module-iexports mod)))
 359            ',(module-vexports mod)		; vexports
 360            (scheme#list			; sexports
 361	    ,@(map (lambda (sexport)
 362	  	     (let* ((name (car sexport))
 363                            (a (assq name dlist)))
 364                       (cond ((pair? a) 
 365                              `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
 366                             (else
 367                               (dm "re-exported syntax" name mname)
 368			  `',name))))
 369	        sexports))
 370            (scheme#list			; sdefs
 371	      ,@(if (null? sexports)
 372	            '() 			; no syntax exported - no more info needed
 373                    (let loop ((sd (module-defined-syntax-list mod)))
 374                      (cond ((null? sd) '())
 375                            ((assq (caar sd) sexports) (loop (cdr sd)))
 376                            (else
 377                              (let ((name (caar sd)))
 378                                (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd)))
 379                                      (loop (cdr sd)))))))))
 380            (scheme#list   ; renames
 381              ,@(map (lambda (ren)
 382                       `(scheme#cons ',(car ren) ',(cdr ren)))
 383                  (module-rename-list mod)))))))))
 384
 385;; iexports = indirect exports (syntax dependencies on value idents, explicitly included in module export list)
 386;; vexports = value (non-syntax) exports
 387;; sexports = syntax exports
 388;; sdefs = unexported definitions from syntax environment used by exported macros (not in export list)
 389(define (##sys#register-compiled-module name lib iexports vexports sexports #!optional
 390					(sdefs '()) (renames '()))
 391  (define (find-reexport name)
 392    (let ((a (assq name (##sys#macro-environment))))
 393      (if (and a (pair? (cdr a)))
 394	  a
 395	  (##sys#error
 396	   'import "cannot find implementation of re-exported syntax"
 397	   name))))
 398  (let* ((sexps
 399	  (filter-map (lambda (se)
 400			(and (not (symbol? se))
 401			     (list (car se) #f (##sys#ensure-transformer (cdr se) (car se)))))
 402		      sexports))
 403	 (reexp-sexps
 404	  (filter-map (lambda (se) (and (symbol? se) (find-reexport se)))
 405		      sexports))
 406	 (nexps
 407	  (map (lambda (ne)
 408		 (list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
 409	       sdefs))
 410	 (mod (make-module name lib '() vexports (append sexps reexp-sexps) iexports
 411                           renames))
 412	 (senv (if (or (not (null? sexps))  ; Only macros have an senv
 413		       (not (null? nexps))) ; which must be patched up
 414		   (merge-se
 415		    (##sys#macro-environment)
 416		    (##sys#current-environment)
 417		    iexports vexports sexps nexps)
 418		   '())))
 419    (for-each
 420     (lambda (sexp)
 421       (set-car! (cdr sexp) (merge-se (or (cadr sexp) '()) senv)))
 422     sexps)
 423    (for-each
 424     (lambda (nexp)
 425       (set-car! (cdr nexp) (merge-se (or (cadr nexp) '()) senv)))
 426     nexps)
 427    (set-module-saved-environments!
 428     mod
 429     (cons (merge-se (##sys#current-environment) vexports sexps)
 430	   (##sys#macro-environment)))
 431    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
 432    mod))
 433
 434(define (##sys#register-core-module name lib vexports #!optional (sexports '()))
 435  (let* ((me (##sys#macro-environment))
 436	 (mod (make-module
 437	       name lib '()
 438	       vexports
 439	       (map (lambda (se)
 440		      (if (symbol? se)
 441			  (or (assq se me)
 442			      (##sys#error
 443			       "unknown syntax referenced while registering module" 
 444			       se name))
 445			  se))
 446		    sexports)
 447	       '())))
 448    (set-module-saved-environments!
 449     mod
 450     (cons (merge-se (##sys#current-environment)
 451		     (module-vexports mod)
 452		     (module-sexports mod))
 453	   (##sys#macro-environment)))
 454    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
 455    mod))
 456
 457;; same as register-core-module (above) but does not load any code,
 458;; used to register modules that provide only syntax
 459(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
 460  (##sys#register-core-module name #f vexports sexports))
 461
 462(define (find-export sym mod indirect)
 463  (let ((exports (module-export-list mod)))
 464    (let loop ((xl (if (eq? #t exports) (module-exist-list mod) exports)))
 465      (cond ((null? xl) #f)
 466	    ((eq? sym (car xl)))
 467	    ((pair? (car xl))
 468	     (or (eq? sym (caar xl))
 469		 (and indirect (memq sym (cdar xl)))
 470		 (loop (cdr xl))))
 471	    (else (loop (cdr xl)))))))
 472
 473(define ##sys#finalize-module 
 474  (let ((display display)
 475	(write-char write-char))
 476    (lambda (mod #!optional (invalid-export (lambda _ #f)))
 477      ;; invalid-export: Returns a string if given identifier names a
 478      ;; non-exportable object. The string names the type (e.g. "an
 479      ;; inline function"). Returns #f otherwise.
 480
 481      ;; Given a list of (<identifier> . <source-location>), builds a nicely
 482      ;; formatted error message with suggestions where possible.
 483      (define (report-unresolved-identifiers unknowns)
 484	(let ((out (open-output-string)))
 485	  (fprintf out "Module `~a' has unresolved identifiers" (module-name mod))
 486
 487	  ;; Print filename from a line number entry
 488	  (let lp ((locs (apply append (map cdr unknowns))))
 489	    (unless (null? locs)
 490	      (or (and-let* ((loc (car locs))
 491			     (ln (and (pair? loc) (cdr loc)))
 492			     (ss (string-split ln ":"))
 493			     ((= 2 (length ss))))
 494		    (fprintf out "\n  In file `~a':" (car ss))
 495		    #t)
 496		  (lp (cdr locs)))))
 497
 498	  (for-each
 499	   (lambda (id.locs)
 500	     (fprintf out "\n\n  Unknown identifier `~a'" (car id.locs))
 501
 502	     ;; Print all source locations where this ID occurs
 503	     (for-each
 504	      (lambda (loc)
 505		(define (ln->num ln) (let ((ss (string-split ln ":")))
 506				       (if (and (pair? ss) (= 2 (length ss)))
 507					   (cadr ss)
 508					   ln)))
 509		(and-let* ((loc-s
 510			    (cond
 511			      ((and (pair? loc) (car loc) (cdr loc)) =>
 512			       (lambda (ln)
 513				 (format "In procedure `~a' on line ~a" (car loc) (ln->num ln))))
 514			      ((and (pair? loc) (cdr loc))
 515			       (format "On line ~a" (ln->num (cdr loc))))
 516			      (else (format "In procedure `~a'" loc)))))
 517		  (fprintf out "\n    ~a" loc-s)))
 518	      (reverse (cdr id.locs)))
 519
 520	     ;; Print suggestions from identifier db
 521	     (and-let* ((id (car id.locs))
 522			(a (getp id '##core#db)))
 523	       (fprintf out "\n  Suggestion: try importing ")
 524	       (cond
 525		 ((= 1 (length a))
 526		  (fprintf out "module `~a'" (cadar a)))
 527		 (else
 528		  (fprintf out "one of these modules:")
 529		  (for-each
 530		   (lambda (a)
 531		     (fprintf out "\n    ~a" (cadr a)))
 532		   a)))))
 533	   unknowns)
 534
 535	  (##sys#error (get-output-string out))))
 536
 537      (define (filter-sdlist mod)
 538        (let loop ((syms (module-defined-syntax-list mod)))
 539          (cond ((null? syms) '())
 540                ((eq? (##sys#get (caar syms) '##sys#override) 'value)
 541                 (loop (cdr syms)))
 542                (else (cons (assq (caar syms) (##sys#macro-environment))
 543                            (loop (cdr syms)))))))
 544
 545      (let* ((explist (module-export-list mod))
 546	     (name (module-name mod))
 547	     (dlist (module-defined-list mod))
 548	     (elist (module-exist-list mod))
 549	     (missing #f)
 550	     (sdlist (filter-sdlist mod))
 551	     (sexports
 552	      (if (eq? #t explist)
 553		  (merge-se (module-sexports mod) sdlist)
 554		  (let loop ((me (##sys#macro-environment)))
 555		    (cond ((null? me) '())
 556                          ((eq? (##sys#get (caar me) '##sys#override) 'value)
 557                           (loop (cdr me)))
 558			  ((find-export (caar me) mod #f)
 559			   (cons (car me) (loop (cdr me))))
 560			  (else (loop (cdr me)))))))
 561	     (vexports
 562	      (let loop ((xl (if (eq? #t explist) elist explist)))
 563		(if (null? xl)
 564		    '()
 565		    (let* ((h (car xl))
 566			   (id (if (symbol? h) h (car h))))
 567		      (cond ((eq? (##sys#get id '##sys#override) 'syntax)
 568                              (loop (cdr xl)))
 569                            ((assq id sexports) (loop (cdr xl)))
 570                            (else 
 571                              (cons 
 572                                (cons 
 573			          id
 574                                  (let ((def (assq id dlist)))
 575                                    (if (and def (symbol? (cdr def))) 
 576                                        (cdr def)
 577                                        (let ((a (assq id (##sys#current-environment))))
 578					  (define (fail msg)
 579					    (##sys#warn msg)
 580					    (set! missing #t))
 581					  (define (id-string)
 582					    (string-append "`" (symbol->string id) "'"))
 583                                          (cond ((and a (symbol? (cdr a)))
 584                                                 (dm "reexporting: " id " -> " (cdr a))
 585                                                 (cdr a))
 586						(def (module-rename id name))
 587						((invalid-export id)
 588						 =>
 589						 (lambda (type)
 590						   (fail (string-append
 591							  "Cannot export " (id-string)
 592							  " because it is " type "."))))
 593                                                ((not def)
 594						 (fail (string-append
 595							"Exported identifier " (id-string)
 596							" has not been defined.")))
 597                                                (else (bomb "fail")))))))
 598                              (loop (cdr xl))))))))))
 599
 600	;; Check all identifiers were resolved
 601	(let ((unknowns '()))
 602	  (for-each (lambda (u)
 603		      (unless (memq (car u) elist)
 604			(set! unknowns (cons u unknowns))))
 605		    (module-undefined-list mod))
 606	  (unless (null? unknowns)
 607	    (report-unresolved-identifiers unknowns)))
 608
 609	(when missing
 610	  (##sys#error "module unresolved" name))
 611	(let* ((iexports 
 612		(map (lambda (exp)
 613		       (cond ((symbol? (cdr exp)) exp)
 614			     ((assq (car exp) (##sys#macro-environment)))
 615			     (else (##sys#error "(internal) indirect export not found" (car exp)))) )
 616		     (module-indirect-exports mod)))
 617	       (new-se (merge-se 
 618			(##sys#macro-environment) 
 619			(##sys#current-environment) 
 620			iexports vexports sexports sdlist)))
 621	  (for-each
 622	   (lambda (m)
 623	     (let ((se (merge-se (cadr m) new-se))) ;XXX needed?
 624	       (dm `(FIXUP: ,(car m) ,@(map-se se)))
 625	       (set-car! (cdr m) se)))
 626	   sdlist)
 627	  (dm `(EXPORTS: 
 628		,(module-name mod) 
 629		(DLIST: ,@dlist)
 630		(SDLIST: ,@(map-se sdlist))
 631		(IEXPORTS: ,@(map-se iexports))
 632		(VEXPORTS: ,@(map-se vexports))
 633		(SEXPORTS: ,@(map-se sexports))))
 634	  (set-module-vexports! mod vexports)
 635	  (set-module-sexports! mod sexports)
 636	  (set-module-iexports! 
 637	   mod
 638	   (merge-se (module-iexports mod) iexports)) ; "reexport" may already have added some
 639	  (set-module-saved-environments!
 640	   mod
 641	   (cons (merge-se (##sys#current-environment) vexports sexports)
 642		 (##sys#macro-environment))))))))
 643
 644(define ##sys#module-table '())
 645
 646
 647;;; Import-expansion
 648
 649(define (##sys#with-environment thunk)
 650  (parameterize ((##sys#current-module #f)
 651                 (##sys#current-environment '())
 652                 (##sys#current-meta-environment
 653                   (##sys#current-meta-environment))
 654                 (##sys#macro-environment
 655		   (##sys#meta-macro-environment)))
 656    (thunk)))
 657
 658(define (##sys#import-library-hook mname)
 659  (and-let* ((il (chicken.load#find-dynamic-extension
 660		  (string-append (symbol->string mname) ".import")
 661		  #t)))
 662     (##sys#with-environment
 663       (lambda ()
 664         (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
 665           (load il)
 666           (##sys#find-module mname 'import))))))
 667
 668(define (find-module/import-library lib loc)
 669  (let ((mname (##sys#resolve-module-name lib loc)))
 670    (or (##sys#find-module mname #f loc)
 671	(##sys#import-library-hook mname))))
 672
 673(define (##sys#decompose-import x r c loc)
 674  (let ((%only (r 'only))
 675	(%rename (r 'rename))
 676	(%except (r 'except))
 677	(%prefix (r 'prefix)))
 678    (define (warn msg mod id)
 679      (##sys#warn (string-append msg " in module `" (symbol->string mod) "'") id))
 680    (define (tostr x)
 681      (cond ((string? x) x)
 682	    ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; hack
 683	    ((symbol? x) (##sys#symbol->string x))
 684	    ((number? x) (number->string x))
 685	    (else (##sys#syntax-error-hook loc "invalid prefix" ))))
 686    (define (export-rename mod lst)
 687      (let ((ren (module-rename-list mod)))
 688        (if (null? ren)
 689            lst
 690            (map (lambda (a)
 691                   (cond ((assq (car a) ren) =>
 692                          (lambda (b) 
 693                            (cons (cdr b) (cdr a))))
 694                         (else a)))
 695              lst))))
 696    (call-with-current-continuation
 697     (lambda (k)
 698       (define (module-imports name)
 699	 (let* ((id  (library-id name))
 700	        (mod (find-module/import-library id loc)))
 701	   (if (not mod)
 702	       (k id id #f #f #f #f)
 703	       (values (module-name mod)
 704		       (module-library mod)
 705		       (module-name mod)
 706		       (export-rename mod (module-vexports mod))
 707		       (export-rename mod (module-sexports mod))
 708		       (module-iexports mod)))))
 709       (let outer ((x x))
 710	 (cond ((symbol? x)
 711		(module-imports (strip-syntax x)))
 712	       ((not (pair? x))
 713		(##sys#syntax-error-hook loc "invalid import specification" x))
 714	       (else
 715		(let ((head (car x)))
 716		  (cond ((c %only head)
 717			 (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
 718			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 719				      ((imports) (strip-syntax (cddr x))))
 720			   (let loop ((ids imports) (v '()) (s '()) (missing '()))
 721			     (cond ((null? ids)
 722				    (for-each
 723				     (lambda (id)
 724				       (warn "imported identifier doesn't exist" name id))
 725				     missing)
 726				    (values name lib `(,head ,spec ,@imports) v s impi))
 727				   ((assq (car ids) impv) =>
 728				    (lambda (a)
 729				      (loop (cdr ids) (cons a v) s missing)))
 730				   ((assq (car ids) imps) =>
 731				    (lambda (a)
 732				      (loop (cdr ids) v (cons a s) missing)))
 733				   (else
 734				    (loop (cdr ids) v s (cons (car ids) missing)))))))
 735			((c %except head)
 736			 (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
 737			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 738				      ((imports) (strip-syntax (cddr x))))
 739			   (let loopv ((impv impv) (v '()) (ids imports))
 740			     (cond ((null? impv)
 741				    (let loops ((imps imps) (s '()) (ids ids))
 742				      (cond ((null? imps)
 743					     (for-each
 744					      (lambda (id)
 745						(warn "excluded identifier doesn't exist" name id))
 746					      ids)
 747					     (values name lib `(,head ,spec ,@imports) v s impi))
 748					    ((memq (caar imps) ids) =>
 749								    (lambda (id)
 750								      (loops (cdr imps) s (delete (car id) ids eq?))))
 751					    (else
 752					     (loops (cdr imps) (cons (car imps) s) ids)))))
 753				   ((memq (caar impv) ids) =>
 754							   (lambda (id)
 755							     (loopv (cdr impv) v (delete (car id) ids eq?))))
 756				   (else
 757				    (loopv (cdr impv) (cons (car impv) v) ids))))))
 758			((c %rename head)
 759			 (##sys#check-syntax loc x '(_ _ . #((symbol symbol) 0)))
 760			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 761				      ((renames) (strip-syntax (cddr x))))
 762			   (let loopv ((impv impv) (v '()) (ids renames))
 763			     (cond ((null? impv)
 764				    (let loops ((imps imps) (s '()) (ids ids))
 765				      (cond ((null? imps)
 766					     (for-each
 767					      (lambda (id)
 768						(warn "renamed identifier doesn't exist" name id))
 769					      (map car ids))
 770					     (values name lib `(,head ,spec ,@renames) v s impi))
 771					    ((assq (caar imps) ids) =>
 772					     (lambda (a)
 773					       (loops (cdr imps)
 774						     (cons (cons (cadr a) (cdar imps)) s)
 775						     (delete a ids eq?))))
 776					    (else
 777					     (loops (cdr imps) (cons (car imps) s) ids)))))
 778				   ((assq (caar impv) ids) =>
 779				    (lambda (a)
 780				      (loopv (cdr impv)
 781					     (cons (cons (cadr a) (cdar impv)) v)
 782					     (delete a ids eq?))))
 783				   (else
 784				    (loopv (cdr impv) (cons (car impv) v) ids))))))
 785			((c %prefix head)
 786			 (##sys#check-syntax loc x '(_ _ _))
 787			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 788				      ((prefix) (strip-syntax (caddr x))))
 789			   (define (rename imp)
 790			     (cons
 791			      (##sys#string->symbol
 792			       (##sys#string-append (tostr prefix) (##sys#symbol->string (car imp))))
 793			      (cdr imp)))
 794			   (values name lib `(,head ,spec ,prefix) (map rename impv) (map rename imps) impi)))
 795			(else
 796			 (module-imports (strip-syntax x))))))))))))
 797
 798(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
 799  (##sys#check-syntax loc x '(_ . #(_ 1)))
 800  (for-each
 801   (lambda (x)
 802     (let-values (((name _ spec v s i) (##sys#decompose-import x r c loc)))
 803       (if (not spec)
 804	   (##sys#syntax-error-hook loc "cannot import from undefined module" name x)
 805	   (##sys#import spec v s i import-env macro-env meta? reexp? loc))))
 806   (cdr x))
 807  '(##core#undefined))
 808
 809(define (##sys#import spec vsv vss vsi import-env macro-env meta? reexp? loc)
 810  (let ((cm (##sys#current-module)))
 811    (when cm ; save import form
 812      (if meta?
 813          (set-module-meta-import-forms!
 814           cm
 815           (append (module-meta-import-forms cm) (list spec)))
 816          (set-module-import-forms!
 817           cm
 818           (append (module-import-forms cm) (list spec)))))
 819    (dd `(IMPORT: ,loc))
 820    (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
 821    (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
 822    (for-each
 823     (lambda (imp)
 824       (let ((id (car imp)))
 825         (##sys#put! id '##sys#override #f)
 826         (and-let* ((a (assq id (import-env)))
 827                    (aid (cdr imp))
 828                    ((not (eq? aid (cdr a)))))
 829              (##sys#notice "re-importing already imported identifier" id))))
 830     vsv)
 831    (for-each
 832     (lambda (imp)
 833       (let ((id (car imp)))
 834         (##sys#put! id '##sys#override #f)
 835         (and-let* ((a (assq (car imp) (macro-env)))
 836                    ((not (eq? (cdr imp) (cdr a)))))
 837              (##sys#notice "re-importing already imported syntax" (car imp)))))
 838     vss)
 839    (when reexp?
 840      (unless cm
 841        (##sys#syntax-error-hook loc "`reexport' only valid inside a module"))
 842      (let ((el (module-export-list cm)))
 843        (cond ((eq? #t el)
 844               (set-module-sexports! cm (append vss (module-sexports cm)))
 845               (set-module-exist-list!
 846                cm
 847                (append (module-exist-list cm)
 848                        (map car vsv)
 849                        (map car vss))))
 850              (else
 851               (set-module-export-list!
 852                cm
 853                (append
 854                 (let ((xl (module-export-list cm)))
 855                   (if (eq? #t xl) '() xl))
 856                 (map car vsv)
 857                 (map car vss))))))
 858      (set-module-iexports!
 859       cm
 860       (merge-se (module-iexports cm) vsi))
 861      (dm "export-list: " (module-export-list cm)))
 862    (import-env (merge-se (import-env) vsv))
 863    (macro-env (merge-se (macro-env) vss))))
 864
 865(define (module-rename sym prefix)
 866  (##sys#string->symbol
 867   (string-append
 868    (##sys#slot prefix 1)
 869    "#"
 870    (##sys#slot sym 1) ) ) )
 871
 872(define (##sys#alias-global-hook sym assign where)
 873  (define (mrename sym)
 874    (cond ((##sys#current-module) => 
 875	   (lambda (mod)
 876	     (dm "(ALIAS) global alias " sym " in " (module-name mod))
 877	     (unless assign 
 878	       (register-undefined sym mod where))
 879	     (module-rename sym (module-name mod))))
 880	  (else sym)))
 881  (cond ((namespaced-symbol? sym) sym)
 882	((assq sym (##sys#current-environment)) =>
 883	 (lambda (a)
 884	   (let ((sym2 (cdr a)))
 885	     (dm "(ALIAS) in current environment " sym " -> " sym2)
 886	     ;; check for macro (XXX can this be?)
 887	     (if (pair? sym2) (mrename sym) sym2))))
 888	(else (mrename sym))))
 889
 890(define (##sys#validate-exports exps loc)
 891  ;; expects "exps" to be stripped
 892  (define (err . args)
 893    (apply ##sys#syntax-error-hook loc args))
 894  (define (iface name)
 895    (or (getp name '##core#interface)
 896	(err "unknown interface" name exps)))
 897  (cond ((eq? '* exps) exps)
 898	((symbol? exps) (iface exps))
 899	((not (list? exps))
 900	 (err "invalid exports" exps))
 901	(else
 902	 (let loop ((xps exps))
 903	   (cond ((null? xps) '())
 904		 ((not (pair? xps))
 905		  (err "invalid exports" exps))
 906		 (else
 907		  (let ((x (car xps)))
 908		    (cond ((symbol? x) (cons x (loop (cdr xps))))
 909			  ((not (list? x))
 910			   (err "invalid export" x exps))
 911			  ((eq? #:syntax (car x))
 912			   (cons (cdr x) (loop (cdr xps)))) ; currently not used
 913			  ((eq? #:interface (car x))
 914			   (if (and (pair? (cdr x)) (symbol? (cadr x)))
 915			       (append (iface (cadr x)) (loop (cdr xps)))
 916			       (err "invalid interface specification" x exps)))
 917			  (else
 918			   (let loop2 ((lst x))
 919			     (cond ((null? lst) (cons x (loop (cdr xps))))
 920				   ((symbol? (car lst)) (loop2 (cdr lst)))
 921				   (else (err "invalid export" x exps)))))))))))))
 922
 923(define (##sys#register-functor name fargs fexps body)
 924  (putp name '##core#functor (cons fargs (cons fexps body))))
 925
 926(define (##sys#instantiate-functor name fname args)
 927  (let ((funcdef (getp fname '##core#functor)))
 928    (define (err . args)
 929      (apply ##sys#syntax-error-hook name args))
 930    (unless funcdef (err "instantation of undefined functor" fname))
 931    (let ((fargs (car funcdef))
 932	  (exports (cadr funcdef))
 933	  (body (cddr funcdef)))
 934      (define (merr)
 935	(err "argument list mismatch in functor instantiation" 
 936	     (cons name args) (cons fname (map car fargs))))
 937      `(##core#let-module-alias
 938	,(let loop ((as args) (fas fargs))
 939	   (cond ((null? as)
 940		  ;; use default arguments (if available) or bail out
 941		  (let loop2 ((fas fas))
 942		    (if (null? fas)
 943			'()
 944			(let ((p (car fas)))
 945			  (if (pair? (car p)) ; has default argument?
 946			      (let ((exps (cdr p))
 947				    (alias (caar p))
 948				    (mname (library-id (cadar p))))
 949				(match-functor-argument alias name mname exps fname)
 950				(cons (list alias mname) (loop2 (cdr fas))))
 951			      ;; no default argument, we have too few argument modules
 952			      (merr))))))
 953		 ;; more arguments given as defined for the functor
 954		 ((null? fas) (merr))
 955		 (else
 956		  ;; otherwise match provided argument to functor argument
 957		  (let* ((p (car fas))
 958			 (p1 (car p))
 959			 (exps (cdr p))
 960			 (def? (pair? p1))
 961			 (alias (if def? (car p1) p1))
 962			 (mname (library-id (car as))))
 963		    (match-functor-argument alias name mname exps fname)
 964		    (cons (list alias mname)
 965			  (loop (cdr as) (cdr fas)))))))
 966	(##core#module
 967	 ,name
 968	 ,(if (eq? '* exports) #t exports)
 969	 ,@body)))))
 970
 971(define (match-functor-argument alias name mname exps fname)
 972  (let ((mod (##sys#find-module (##sys#resolve-module-name mname 'module) #t 'module)))
 973    (unless (eq? exps '*)
 974      (let ((missing '()))
 975	(for-each
 976	 (lambda (exp)
 977	   (let ((sym (if (symbol? exp) exp (car exp))))
 978	     (unless (or (assq sym (module-vexports mod))
 979			 (assq sym (module-sexports mod)))
 980	       (set! missing (cons sym missing)))))
 981	 exps)
 982	(when (pair? missing)
 983	  (##sys#syntax-error-hook
 984	   'module 
 985	   (apply
 986	    string-append 
 987	    "argument module `" (symbol->string mname) "' does not match required signature\n"
 988	    "in instantiation `" (symbol->string name) "' of functor `"
 989	    (symbol->string fname) "', because the following required exports are missing:\n"
 990	    (map (lambda (s) (string-append "\n  " (symbol->string s))) missing))))))))
 991
 992
 993;;; built-in modules (needed for eval environments)
 994
 995(let ((r4rs-values
 996       '((not . scheme#not) (boolean? . scheme#boolean?)
 997	 (eq? . scheme#eq?) (eqv? . scheme#eqv?) (equal? . scheme#equal?)
 998	 (pair? . scheme#pair?) (cons . scheme#cons)
 999	 (car . scheme#car) (cdr . scheme#cdr)
 1000	 (caar . scheme#caar) (cadr . scheme#cadr) (cdar . scheme#cdar)
1001	 (cddr . scheme#cddr)
1002	 (caaar . scheme#caaar) (caadr . scheme#caadr)
1003	 (cadar . scheme#cadar) (caddr . scheme#caddr)
1004	 (cdaar . scheme#cdaar) (cdadr . scheme#cdadr)
1005	 (cddar . scheme#cddar) (cdddr . scheme#cdddr)
1006	 (caaaar . scheme#caaaar) (caaadr . scheme#caaadr)
1007	 (caadar . scheme#caadar) (caaddr . scheme#caaddr)
1008	 (cadaar . scheme#cadaar) (cadadr . scheme#cadadr)
1009	 (caddar . scheme#caddar) (cadddr . scheme#cadddr)
1010	 (cdaaar . scheme#cdaaar) (cdaadr . scheme#cdaadr)
1011	 (cdadar . scheme#cdadar) (cdaddr . scheme#cdaddr)
1012	 (cddaar . scheme#cddaar) (cddadr . scheme#cddadr)
1013	 (cdddar . scheme#cdddar) (cddddr . scheme#cddddr)
1014	 (set-car! . scheme#set-car!) (set-cdr! . scheme#set-cdr!)
1015	 (null? . scheme#null?) (list? . scheme#list?)
1016	 (list . scheme#list) (length . scheme#length)
1017	 (list-tail . scheme#list-tail) (list-ref . scheme#list-ref)
1018	 (append . scheme#append) (reverse . scheme#reverse)
1019	 (memq . scheme#memq) (memv . scheme#memv)
1020	 (member . scheme#member) (assq . scheme#assq)
1021	 (assv . scheme#assv) (assoc . scheme#assoc)
1022	 (symbol? . scheme#symbol?)
1023	 (symbol->string . scheme#symbol->string)
1024	 (string->symbol . scheme#string->symbol)
1025	 (number? . scheme#number?) (integer? . scheme#integer?)
1026	 (exact? . scheme#exact?) (real? . scheme#real?)
1027	 (complex? . scheme#complex?) (inexact? . scheme#inexact?)
1028	 (rational? . scheme#rational?) (zero? . scheme#zero?)
1029	 (odd? . scheme#odd?) (even? . scheme#even?)
1030	 (positive? . scheme#positive?) (negative? . scheme#negative?)
1031	 (max . scheme#max) (min . scheme#min)
1032	 (+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/)
1033	 (= . scheme#=) (> . scheme#>) (< . scheme#<)
1034	 (>= . scheme#>=) (<= . scheme#<=)
1035	 (quotient . scheme#quotient) (remainder . scheme#remainder)
1036	 (modulo . scheme#modulo)
1037	 (gcd . scheme#gcd) (lcm . scheme#lcm) (abs . scheme#abs)
1038	 (floor . scheme#floor) (ceiling . scheme#ceiling)
1039	 (truncate . scheme#truncate) (round . scheme#round)
1040	 (rationalize . scheme#rationalize)
1041	 (exact->inexact . scheme#exact->inexact)
1042	 (inexact->exact . scheme#inexact->exact)
1043	 (exp . scheme#exp) (log . scheme#log) (expt . scheme#expt)
1044	 (sqrt . scheme#sqrt)
1045	 (sin . scheme#sin) (cos . scheme#cos) (tan . scheme#tan)
1046	 (asin . scheme#asin) (acos . scheme#acos) (atan . scheme#atan)
1047	 (number->string . scheme#number->string)
1048	 (string->number . scheme#string->number)
1049	 (char? . scheme#char?) (char=? . scheme#char=?)
1050	 (char>? . scheme#char>?) (char<? . scheme#char<?)
1051	 (char>=? . scheme#char>=?) (char<=? . scheme#char<=?)
1052	 (char-ci=? . scheme#char-ci=?)
1053	 (char-ci<? . scheme#char-ci<?) (char-ci>? . scheme#char-ci>?)
1054	 (char-ci>=? . scheme#char-ci>=?) (char-ci<=? . scheme#char-ci<=?)
1055	 (char-alphabetic? . scheme#char-alphabetic?)
1056	 (char-whitespace? . scheme#char-whitespace?)
1057	 (char-numeric? . scheme#char-numeric?)
1058	 (char-upper-case? . scheme#char-upper-case?)
1059	 (char-lower-case? . scheme#char-lower-case?)
1060	 (char-upcase . scheme#char-upcase)
1061	 (char-downcase . scheme#char-downcase)
1062	 (char->integer . scheme#char->integer)
1063	 (integer->char . scheme#integer->char)
1064	 (string? . scheme#string?) (string=? . scheme#string=?)
1065	 (string>? . scheme#string>?) (string<? . scheme#string<?)
1066	 (string>=? . scheme#string>=?) (string<=? . scheme#string<=?)
1067	 (string-ci=? . scheme#string-ci=?)
1068	 (string-ci<? . scheme#string-ci<?)
1069	 (string-ci>? . scheme#string-ci>?)
1070	 (string-ci>=? . scheme#string-ci>=?)
1071	 (string-ci<=? . scheme#string-ci<=?)
1072	 (make-string . scheme#make-string)
1073	 (string-length . scheme#string-length)
1074	 (string-ref . scheme#string-ref)
1075	 (string-set! . scheme#string-set!)
1076	 (string-append . scheme#string-append)
1077	 (string-copy . scheme#string-copy)
1078	 (string->list . scheme#string->list)
1079	 (list->string . scheme#list->string)
1080	 (substring . scheme#substring)
1081	 (string-fill! . scheme#string-fill!)
1082	 (vector? . scheme#vector?) (make-vector . scheme#make-vector)
1083	 (vector-ref . scheme#vector-ref)
1084	 (vector-set! . scheme#vector-set!)
1085	 (string . scheme#string) (vector . scheme#vector)
1086	 (vector-length . scheme#vector-length)
1087	 (vector->list . scheme#vector->list)
1088	 (list->vector . scheme#list->vector)
1089	 (vector-fill! . scheme#vector-fill!)
1090	 (procedure? . scheme#procedure?)
1091	 (map . scheme#map) (for-each . scheme#for-each)
1092	 (apply . scheme#apply) (force . scheme#force)
1093	 (call-with-current-continuation . scheme#call-with-current-continuation)
1094	 (input-port? . scheme#input-port?)
1095	 (output-port? . scheme#output-port?)
1096	 (current-input-port . scheme#current-input-port)
1097	 (current-output-port . scheme#current-output-port)
1098	 (call-with-input-file . scheme#call-with-input-file)
1099	 (call-with-output-file . scheme#call-with-output-file)
1100	 (open-input-file . scheme#open-input-file)
1101	 (open-output-file . scheme#open-output-file)
1102	 (close-input-port . scheme#close-input-port)
1103	 (close-output-port . scheme#close-output-port)
1104	 (load . scheme#load) (read . scheme#read)
1105	 (read-char . scheme#read-char) (peek-char . scheme#peek-char)
1106	 (write . scheme#write) (display . scheme#display)
1107	 (write-char . scheme#write-char) (newline . scheme#newline)
1108	 (eof-object? . scheme#eof-object?)
1109	 (with-input-from-file . scheme#with-input-from-file)
1110	 (with-output-to-file . scheme#with-output-to-file)
1111	 (char-ready? . scheme#char-ready?)
1112	 (imag-part . scheme#imag-part) (real-part . scheme#real-part)
1113	 (make-rectangular . scheme#make-rectangular)
1114	 (make-polar . scheme#make-polar)
1115	 (angle . scheme#angle) (magnitude . scheme#magnitude)
1116	 (numerator . scheme#numerator)
1117	 (denominator . scheme#denominator)
1118	 (scheme-report-environment . scheme#scheme-report-environment)
1119	 (null-environment . scheme#null-environment)
1120	 (interaction-environment . scheme#interaction-environment)))
1121      (r4rs-syntax ##sys#scheme-macro-environment))
1122  (##sys#register-core-module 'r4rs 'library r4rs-values r4rs-syntax)
1123  (##sys#register-core-module
1124   'scheme 'library
1125   (append '((dynamic-wind . scheme#dynamic-wind)
1126	     (eval . scheme#eval)
1127	     (values . scheme#values)
1128	     (call-with-values . scheme#call-with-values))
1129	   r4rs-values)
1130   r4rs-syntax)
1131  (##sys#register-core-module 'r4rs-null #f '() r4rs-syntax)
1132  (##sys#register-core-module 'r5rs-null #f '() r4rs-syntax))
1133
1134(##sys#register-module-alias 'r5rs 'scheme)
1135
1136(define-inline (se-subset names env) (map (cut assq <> env) names))
1137
1138;; Hack for library.scm to use macros from modules it defines itself.
1139(##sys#register-primitive-module
1140 'chicken.internal.syntax '() (##sys#macro-environment))
1141
1142(##sys#register-primitive-module
1143 'chicken.module '() ##sys#chicken.module-macro-environment)
1144
1145(##sys#register-primitive-module
1146 'chicken.type '() ##sys#chicken.type-macro-environment)
1147
1148(##sys#register-primitive-module
1149 'srfi-0 '() (se-subset '(cond-expand) ##sys#default-macro-environment))
1150
1151(##sys#register-primitive-module
1152 'srfi-2 '() (se-subset '(and-let*) ##sys#chicken.base-macro-environment))
1153
1154(##sys#register-core-module
1155 'srfi-6 'library
1156 '((get-output-string . chicken.base#get-output-string)
1157   (open-input-string . chicken.base#open-input-string)
1158   (open-output-string . chicken.base#open-output-string)))
1159
1160(##sys#register-primitive-module
1161 'srfi-8 '() (se-subset '(receive) ##sys#chicken.base-macro-environment))
1162
1163(##sys#register-primitive-module
1164 'srfi-9 '() (se-subset '(define-record-type) ##sys#chicken.base-macro-environment))
1165
1166(##sys#register-core-module
1167 'srfi-10 'read-syntax '((define-reader-ctor . chicken.read-syntax#define-reader-ctor)))
1168
1169(##sys#register-primitive-module
1170 'srfi-11 '() (se-subset '(let-values let*-values) ##sys#chicken.base-macro-environment))
1171
1172(##sys#register-core-module
1173 'srfi-12 'library
1174 '((abort . chicken.condition#abort)
1175   (condition? . chicken.condition#condition?)
1176   (condition-predicate . chicken.condition#condition-predicate)
1177   (condition-property-accessor . chicken.condition#condition-property-accessor)
1178   (current-exception-handler . chicken.condition#current-exception-handler)
1179   (make-composite-condition . chicken.condition#make-composite-condition)
1180   (make-property-condition . chicken.condition#make-property-condition)
1181   (signal . chicken.condition#signal)
1182   (with-exception-handler . chicken.condition#with-exception-handler))
1183 (se-subset '(handle-exceptions) ##sys#chicken.condition-macro-environment))
1184
1185(##sys#register-primitive-module
1186 'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken.base-macro-environment))
1187
1188(##sys#register-primitive-module
1189 'srfi-16 '() (se-subset '(case-lambda) ##sys#chicken.base-macro-environment))
1190
1191(##sys#register-core-module
1192 'srfi-17 'library
1193 '((getter-with-setter . chicken.base#getter-with-setter)
1194   (setter . chicken.base#setter))
1195 (se-subset '(set!) ##sys#default-macro-environment))
1196
1197(##sys#register-core-module
1198 'srfi-23 'library '((error . chicken.base#error)))
1199
1200(##sys#register-primitive-module
1201 'srfi-26 '() (se-subset '(cut cute) ##sys#chicken.base-macro-environment))
1202
1203(##sys#register-core-module
1204 'srfi-28 'extras '((format . chicken.format#format)))
1205
1206(##sys#register-primitive-module
1207 'srfi-31 '() (se-subset '(rec) ##sys#chicken.base-macro-environment))
1208
1209(##sys#register-core-module
1210 'srfi-39 'library '((make-parameter . chicken.base#make-parameter))
1211 (se-subset '(parameterize) ##sys#chicken.base-macro-environment))
1212
1213(##sys#register-primitive-module
1214 'srfi-55 '() (se-subset '(require-extension) ##sys#chicken.base-macro-environment))
1215
1216(##sys#register-core-module
1217 'srfi-88 'library
1218 '((keyword? . chicken.keyword#keyword?)
1219   (keyword->string . chicken.keyword#keyword->string)
1220   (string->keyword . chicken.keyword#string->keyword)))
1221
1222(##sys#register-core-module
1223 'srfi-98 'posix
1224 '((get-environment-variable . chicken.process-context#get-environment-variable)
1225   (get-environment-variables . chicken.process-context#get-environment-variables)))
1226
1227(define (chicken.module#module-environment mname #!optional (ename mname))
1228  (let ((mod (find-module/import-library mname 'module-environment)))
1229    (if (not mod)
1230	(##sys#syntax-error-hook
1231	 'module-environment "undefined module" mname)
1232	(##sys#make-structure
1233	 'environment ename (car (module-saved-environments mod)) #t))))
1234
1235;; Ensure default modules are available in "eval", too
1236;; TODO: Figure out a better way to make this work for static programs.
1237;; The actual imports are handled lazily by eval when first called.
1238(include "chicken.base.import.scm")
1239(include "chicken.syntax.import.scm")