~ chicken-core (master) /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(import (only (scheme base) make-parameter open-output-string get-output-string))
  49
  50(include "common-declarations.scm")
  51(include "mini-srfi-1.scm")
  52
  53(define-syntax d (syntax-rules () ((_ . _) (void))))
  54
  55(define-alias dd d)
  56(define-alias dm d)
  57(define-alias dx d)
  58
  59#+debugbuild
  60(define (map-se se)
  61  (map (lambda (a)
  62	 (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
  63       se))
  64
  65(define-inline (getp sym prop)
  66  (##core#inline "C_i_getprop" sym prop #f))
  67
  68(define-inline (putp sym prop val)
  69  (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
  70
  71(define-inline (namespaced-symbol? sym)
  72  (##core#inline "C_u_i_namespaced_symbolp" sym))
  73
  74;;; Support definitions
  75
  76;;; low-level module support
  77
  78(define ##sys#current-module (make-parameter #f))
  79(define ##sys#module-alias-environment (make-parameter '()))
  80
  81(declare
  82  (hide make-module module? %make-module
  83	module-name module-library
  84	module-vexports module-sexports
  85	set-module-vexports! set-module-sexports!
  86	module-export-list set-module-export-list!
  87	module-defined-list set-module-defined-list!
  88	module-import-forms set-module-import-forms!
  89	module-meta-import-forms set-module-meta-import-forms!
  90	module-exist-list set-module-exist-list!
  91	module-meta-expressions set-module-meta-expressions!
  92	module-defined-syntax-list set-module-defined-syntax-list!
  93	module-saved-environments set-module-saved-environments!
  94	module-iexports set-module-iexports!
  95        module-rename-list set-module-rename-list!))
  96
  97(define-record-type module
  98  (%make-module name library export-list defined-list exist-list defined-syntax-list
  99		undefined-list import-forms meta-import-forms meta-expressions
 100		vexports sexports iexports saved-environments rename-list)
 101  module?
 102  (name module-name)			; SYMBOL
 103  (library module-library)		; SYMBOL
 104  (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
 105  (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...)    - *exported* value definitions
 106  (exist-list module-exist-list set-module-exist-list!)	      ; (SYMBOL ...)    - only for checking refs to undef'd
 107  (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
 108  (undefined-list module-undefined-list set-module-undefined-list!) ; ((SYMBOL WHERE1 ...) ...)
 109  (import-forms module-import-forms set-module-import-forms!)	    ; (SPEC ...)
 110  (meta-import-forms module-meta-import-forms set-module-meta-import-forms!)	    ; (SPEC ...)
 111  (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
 112  (vexports module-vexports set-module-vexports!)	      ; ((SYMBOL . SYMBOL) ...)
 113  (sexports module-sexports set-module-sexports!)	      ; ((SYMBOL SE TRANSFORMER) ...)
 114  (iexports module-iexports set-module-iexports!)	      ; ((SYMBOL . SYMBOL) ...)
 115  ;; for csi's ",m" command, holds (<env> . <macroenv>)
 116  (saved-environments module-saved-environments set-module-saved-environments!)
 117  (rename-list module-rename-list set-module-rename-list!))
 118
 119(define ##sys#module-name module-name)
 120
 121(define (##sys#module-exports m)
 122  (values
 123   (module-export-list m)
 124   (module-vexports m)
 125   (module-sexports m)))
 126
 127(define (make-module name lib explist vexports sexports iexports #!optional (renames '()))
 128  (%make-module name lib explist '() '() '() '() '() '() '() vexports sexports iexports #f
 129                renames))
 130
 131(define (##sys#register-module-alias alias name)
 132  (##sys#module-alias-environment
 133    (cons (cons alias name) (##sys#module-alias-environment))))
 134
 135(define (##sys#with-module-aliases bindings thunk)
 136  (parameterize ((##sys#module-alias-environment
 137		  (append
 138		   (map (lambda (b) (cons (car b) (cadr b))) bindings)
 139		   (##sys#module-alias-environment))))
 140    (thunk)))
 141
 142(define (##sys#resolve-module-name name loc)
 143  (let loop ((n (library-id name)) (done '()))
 144    (cond ((assq n (##sys#module-alias-environment)) =>
 145	   (lambda (a)
 146	     (let ((n2 (cdr a)))
 147	       (if (memq n2 done)
 148		   (error loc "module alias refers to itself" name)
 149		   (loop n2 (cons n2 done))))))
 150	  (else n))))
 151
 152(define (##sys#find-module name #!optional (err #t) loc)
 153  (cond ((assq name ##sys#module-table) => cdr)
 154	(err (error loc "module not found" name))
 155	(else #f)))
 156
 157(define ##sys#switch-module
 158  (let ((saved-default-envs #f))
 159    (lambda (mod)
 160      (let ((now (cons (##sys#current-environment) (##sys#macro-environment))))
 161	(cond ((##sys#current-module) =>
 162	       (lambda (m)
 163		 (set-module-saved-environments! m now)))
 164	      (else
 165	       (set! saved-default-envs now)))
 166	(let ((saved (if mod (module-saved-environments mod) saved-default-envs)))
 167	  (when saved
 168	    (##sys#current-environment (car saved))
 169	    (##sys#macro-environment (cdr saved)))
 170	  (##sys#current-module mod))))))
 171
 172(define (##sys#add-to-export-list mod exps)
 173  (let ((xl (module-export-list mod)))
 174    (if (eq? xl #t)
 175	(let ((el (module-exist-list mod))
 176	      (me (##sys#macro-environment))
 177	      (sexps '()))
 178	  (for-each
 179	   (lambda (exp)
 180	     (cond ((assq exp me) =>
 181		    (lambda (a)
 182		      (set! sexps (cons a sexps))))))
 183	   exps)
 184	  (set-module-sexports! mod (append sexps (module-sexports mod)))
 185	  (set-module-exist-list! mod (append el exps)))
 186	(set-module-export-list! mod (append xl exps)))))
 187
 188(define (##sys#add-to-export/rename-list mod renames)
 189  (let ((rl (module-rename-list mod)))
 190    (set-module-rename-list! mod (append rl renames))
 191    (##sys#add-to-export-list mod (map car renames))))
 192
 193(define (##sys#toplevel-definition-hook sym renamed exported?) #f)
 194
 195(define (##sys#register-meta-expression exp)
 196  (and-let* ((mod (##sys#current-module)))
 197    (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
 198
 199(define (check-for-redef sym env senv)
 200  (and-let* ((a (assq sym env)))
 201    (##sys#warn "redefinition of value binding" sym) )
 202  (and-let* ((a (assq sym senv)))
 203    (##sys#warn "redefinition of syntax binding" sym)))
 204
 205(define (##sys#register-export sym mod)
 206  (define (find-dummy dummy xl)
 207    (cond ((null? xl) #f)
 208          ((and (pair? (car xl)) (eq? dummy (caar xl))) (car xl))
 209          (else (find-dummy dummy (cdr xl)))))
 210  (when mod
 211    (let ((el (module-export-list mod))
 212          (name (module-name mod)))
 213      ;; add any export to the list of indirect exports for the dummy symbol
 214      ;; ("gruesome hack", part 2)
 215      (and-let* ((dummy (##sys#get name '##r7rs#module)))
 216        (unless (eq? sym dummy)
 217          (cond ((memq sym el))
 218                ((find-dummy dummy el) =>
 219                 (lambda (dummylist)
 220                   (set-cdr! dummylist (cons sym (cdr dummylist))))))))
 221      (let ((exp (or (eq? #t el)  
 222                     (find-export sym mod #t)))
 223            (ulist (module-undefined-list mod)))
 224        (##sys#toplevel-definition-hook ; in compiler, hides unexported bindings
 225         sym (module-rename sym name) exp)
 226        (and-let* ((a (assq sym ulist)))
 227          (set-module-undefined-list! mod (delete a ulist eq?)))
 228        (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
 229        (set-module-exist-list! mod (cons sym (module-exist-list mod)))
 230        (when exp
 231          (dm "defined: " sym)
 232          (set-module-defined-list!
 233            mod
 234            (cons (cons sym #f)
 235                  (module-defined-list mod)))))) ))
 236
 237(define (##sys#register-syntax-export sym mod val)
 238  (when mod
 239    (let ((exp (or (eq? #t (module-export-list mod))
 240		   (find-export sym mod #t)))
 241	  (ulist (module-undefined-list mod))
 242	  (mname (module-name mod)))
 243      (when (assq sym ulist)
 244	(##sys#warn "use of syntax precedes definition" sym)) ;XXX could report locations
 245      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
 246      (dm "defined syntax: " sym)
 247      (when exp
 248	(set-module-defined-list!
 249	 mod
 250	 (cons (cons sym val)
 251	       (module-defined-list mod))) )
 252      (set-module-defined-syntax-list!
 253       mod
 254       (cons (cons sym val) (module-defined-syntax-list mod))))))
 255
 256(define (##sys#unregister-syntax-export sym mod)
 257  (when mod
 258    (set-module-defined-syntax-list!
 259     mod
 260     (delete sym (module-defined-syntax-list mod) (lambda (x y) (eq? x (car y)))))))
 261
 262(define (register-undefined sym mod where)
 263  (when mod
 264    (let ((ul (module-undefined-list mod)))
 265      (cond ((assq sym ul) =>
 266	     (lambda (a)
 267	       (when (and where (not (memq where (cdr a))))
 268		 (set-cdr! a (cons where (cdr a))))))
 269	    (else
 270	     (set-module-undefined-list!
 271	      mod
 272	      (cons (cons sym (if where (list where) '())) ul)))))))
 273
 274(define (##sys#register-module name lib explist #!optional (vexports '()) (sexports '()))
 275  (let ((mod (make-module name lib explist vexports sexports '())))
 276    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
 277    mod) )
 278
 279(define (module-indirect-exports mod)
 280  (let ((exports (module-export-list mod))
 281	(mname (module-name mod))
 282	(dlist (module-defined-list mod)))
 283    (define (warn msg id)
 284      (##sys#warn
 285       (string-append msg " in module `" (symbol->string mname) "'")
 286       id))
 287    (if (eq? #t exports)
 288	'()
 289	(let loop ((exports exports))	; walk export list
 290	  (cond ((null? exports) '())
 291		((symbol? (car exports)) (loop (cdr exports))) ; normal export
 292		(else
 293		 (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
 294		   (cond ((null? iexports) (loop (cdr exports)))
 295			 ((assq (car iexports) (##sys#macro-environment))
 296			  (warn "indirect export of syntax binding" (car iexports))
 297			  (loop2 (cdr iexports)))
 298			 ((assq (car iexports) dlist) => ; defined in current module?
 299			  (lambda (a)
 300			    (cons
 301			     (cons
 302			      (car iexports)
 303			      (or (cdr a) (module-rename (car iexports) mname)))
 304			     (loop2 (cdr iexports)))))
 305			 ((assq (car iexports) (##sys#current-environment)) =>
 306			  (lambda (a)	; imported in current env.
 307			    (cond ((symbol? (cdr a)) ; not syntax
 308				   (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
 309				  (else
 310				   (warn "indirect reexport of syntax" (car iexports))
 311				   (loop2 (cdr iexports))))))
 312			 (else
 313			  (warn "indirect export of unknown binding" (car iexports))
 314			  (loop2 (cdr iexports)))))))))))
 315
 316(define (merge-se . ses*) ; later occurrences take precedence to earlier ones
 317  (let ((seen (make-hash-table)) (rses (reverse ses*)))
 318    (let loop ((ses (cdr rses)) (last-se #f) (se2 (car rses)))
 319      (cond ((null? ses) se2)
 320	    ((or (eq? last-se (car ses)) (null? (car ses)))
 321	     (loop (cdr ses) last-se se2))
 322	    ((not last-se)
 323             (for-each (lambda (e) (hash-table-set! seen (car e) #t)) se2)
 324	     (loop ses se2 se2))
 325	    (else (let lp ((se (car ses)) (se2 se2))
 326		    (cond ((null? se) (loop (cdr ses) (car ses) se2))
 327			  ((hash-table-ref seen (caar se))
 328			   (lp (cdr se) se2))
 329			  (else (hash-table-set! seen (caar se) #t)
 330				(lp (cdr se) (cons (car se) se2))))))))))
 331
 332(define (compiled-module-dependencies mod)
 333  (let ((libs (filter-map ; extract library names
 334	       (lambda (x) (nth-value 1 (##sys#decompose-import x o eq? 'module)))
 335	       (module-import-forms mod))))
 336    (map (lambda (lib) `(##core#require ,lib))
 337	 (delete-duplicates libs eq?))))
 338
 339(define (##sys#compiled-module-registration mod compile-mode)
 340  (let ((dlist (module-defined-list mod))
 341	(mname (module-name mod))
 342	(ifs (module-import-forms mod))
 343	(sexports (module-sexports mod))
 344	(mifs (module-meta-import-forms mod)))
 345    `((##sys#with-environment
 346        (lambda ()
 347	  ,@(if (and (eq? compile-mode 'static) (pair? ifs) (pair? sexports))
 348		(compiled-module-dependencies mod)
 349		'())
 350          ,@(if (and (pair? ifs) (pair? sexports))
 351   	        `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
 352  	        '())
 353          ,@(if (and (pair? mifs) (pair? sexports))
 354     	        `((import-syntax ,@(strip-syntax mifs)))
 355	        '())
 356          ,@(if (or (getp mname '##core#functor) (pair? sexports))
 357 	        (##sys#fast-reverse (strip-syntax (module-meta-expressions mod)))
 358	        '())
 359          (##sys#register-compiled-module
 360            ',(module-name mod)
 361            ',(module-library mod)
 362            (scheme#list			; iexports
 363	      ,@(map (lambda (ie)
 364                       (if (symbol? (cdr ie))
 365                           `'(,(car ie) . ,(cdr ie))
 366                           `(scheme#list ',(car ie) '() ,(cdr ie))))
 367                 (module-iexports mod)))
 368            ',(module-vexports mod)		; vexports
 369            (scheme#list			; sexports
 370	    ,@(map (lambda (sexport)
 371	  	     (let* ((name (car sexport))
 372                            (a (assq name dlist)))
 373                       (cond ((pair? a)
 374                              `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
 375                             (else
 376                               (dm "re-exported syntax" name mname)
 377			  `',name))))
 378	        sexports))
 379            (scheme#list			; sdefs
 380	      ,@(if (null? sexports)
 381	            '() 			; no syntax exported - no more info needed
 382                    (let loop ((sd (module-defined-syntax-list mod)))
 383                      (cond ((null? sd) '())
 384                            ((assq (caar sd) sexports) (loop (cdr sd)))
 385                            (else
 386                              (let ((name (caar sd)))
 387                                (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd)))
 388                                      (loop (cdr sd)))))))))
 389            (scheme#list   ; renames
 390              ,@(map (lambda (ren)
 391                       `(scheme#cons ',(car ren) ',(cdr ren)))
 392                  (module-rename-list mod)))))))))
 393
 394;; iexports = indirect exports (syntax dependencies on value idents, explicitly included in module export list)
 395;; vexports = value (non-syntax) exports
 396;; sexports = syntax exports
 397;; sdefs = unexported definitions from syntax environment used by exported macros (not in export list)
 398(define (##sys#register-compiled-module name lib iexports vexports sexports #!optional
 399					(sdefs '()) (renames '()))
 400  (define (find-reexport name)
 401    (let ((a (assq name (##sys#macro-environment))))
 402      (if (and a (pair? (cdr a)))
 403	  a
 404	  (##sys#error
 405	   'import "cannot find implementation of re-exported syntax"
 406	   name))))
 407  (let* ((sexps
 408	  (filter-map (lambda (se)
 409			(and (not (symbol? se))
 410			     (list (car se) #f (##sys#ensure-transformer (cdr se) (car se)))))
 411		      sexports))
 412	 (reexp-sexps
 413	  (filter-map (lambda (se) (and (symbol? se) (find-reexport se)))
 414		      sexports))
 415	 (nexps
 416	  (map (lambda (ne)
 417		 (list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
 418	       sdefs))
 419	 (mod (make-module name lib '() vexports (append sexps reexp-sexps) iexports
 420                           renames))
 421	 (senv (if (or (not (null? sexps))  ; Only macros have an senv
 422		       (not (null? nexps))) ; which must be patched up
 423		   (merge-se
 424		    (##sys#macro-environment)
 425		    (##sys#current-environment)
 426		    iexports vexports sexps nexps)
 427		   '())))
 428    (for-each
 429     (lambda (sexp)
 430       (set-car! (cdr sexp) (merge-se (or (cadr sexp) '()) senv)))
 431     sexps)
 432    (for-each
 433     (lambda (nexp)
 434       (set-car! (cdr nexp) (merge-se (or (cadr nexp) '()) senv)))
 435     nexps)
 436    (set-module-saved-environments!
 437     mod
 438     (cons (merge-se (##sys#current-environment) vexports sexps)
 439	   (##sys#macro-environment)))
 440    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
 441    mod))
 442
 443(define (##sys#register-core-module name lib vexports #!optional (sexports '()))
 444  (let* ((me (##sys#macro-environment))
 445	 (mod (make-module
 446	       name lib '()
 447	       vexports
 448	       (map (lambda (se)
 449		      (if (symbol? se)
 450			  (or (assq se me)
 451			      (##sys#error
 452			       "unknown syntax referenced while registering module"
 453			       se name))
 454			  se))
 455		    sexports)
 456	       '())))
 457    (set-module-saved-environments!
 458     mod
 459     (cons (merge-se (##sys#current-environment)
 460		     (module-vexports mod)
 461		     (module-sexports mod))
 462	   (##sys#macro-environment)))
 463    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
 464    mod))
 465
 466;; same as register-core-module (above) but does not load any code,
 467;; used to register modules that provide only syntax
 468(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
 469  (##sys#register-core-module name #f vexports sexports))
 470
 471(define (find-export sym mod indirect)
 472  (let ((exports (module-export-list mod)))
 473    (let loop ((xl (if (eq? #t exports) (module-exist-list mod) exports)))
 474      (cond ((null? xl) #f)
 475	    ((eq? sym (car xl)))
 476	    ((pair? (car xl))
 477	     (or (eq? sym (caar xl))
 478		 (and indirect (memq sym (cdar xl)))
 479		 (loop (cdr xl))))
 480	    (else (loop (cdr xl)))))))
 481
 482(define ##sys#finalize-module
 483  (let ((display display)
 484	(write-char write-char))
 485    (lambda (mod #!optional (invalid-export (lambda _ #f)))
 486      ;; invalid-export: Returns a string if given identifier names a
 487      ;; non-exportable object. The string names the type (e.g. "an
 488      ;; inline function"). Returns #f otherwise.
 489
 490      ;; Given a list of (<identifier> . <source-location>), builds a nicely
 491      ;; formatted error message with suggestions where possible.
 492      (define (report-unresolved-identifiers unknowns)
 493	(let ((out (open-output-string)))
 494	  (fprintf out "Module `~a' has unresolved identifiers" (module-name mod))
 495
 496	  ;; Print filename from a line number entry
 497	  (let lp ((locs (apply append (map cdr unknowns))))
 498	    (unless (null? locs)
 499	      (or (and-let* ((loc (car locs))
 500			     (ln (and (pair? loc) (cdr loc)))
 501			     (ss (string-split ln ":"))
 502			     ((= 2 (length ss))))
 503		    (fprintf out "\n  In file `~a':" (car ss))
 504		    #t)
 505		  (lp (cdr locs)))))
 506
 507	  (for-each
 508	   (lambda (id.locs)
 509	     (fprintf out "\n\n  Unknown identifier `~a'" (car id.locs))
 510
 511	     ;; Print all source locations where this ID occurs
 512	     (for-each
 513	      (lambda (loc)
 514		(define (ln->num ln) (let ((ss (string-split ln ":")))
 515				       (if (and (pair? ss) (= 2 (length ss)))
 516					   (cadr ss)
 517					   ln)))
 518		(and-let* ((loc-s
 519			    (cond
 520			      ((and (pair? loc) (car loc) (cdr loc)) =>
 521			       (lambda (ln)
 522				 (format "In procedure `~a' on line ~a" (car loc) (ln->num ln))))
 523			      ((and (pair? loc) (cdr loc))
 524			       (format "On line ~a" (ln->num (cdr loc))))
 525			      (else (format "In procedure `~a'" loc)))))
 526		  (fprintf out "\n    ~a" loc-s)))
 527	      (reverse (cdr id.locs)))
 528
 529	     ;; Print suggestions from identifier db
 530	     (and-let* ((id (car id.locs))
 531			(a (getp id '##core#db)))
 532	       (fprintf out "\n  Suggestion: try importing ")
 533	       (cond
 534		 ((= 1 (length a))
 535		  (fprintf out "module `~a'" (cadar a)))
 536		 (else
 537		  (fprintf out "one of these modules:")
 538		  (for-each
 539		   (lambda (a)
 540		     (fprintf out "\n    ~a" (cadr a)))
 541		   a)))))
 542	   unknowns)
 543
 544	  (##sys#error (get-output-string out))))
 545
 546      (define (filter-sdlist mod)
 547        (let loop ((syms (module-defined-syntax-list mod)))
 548          (cond ((null? syms) '())
 549                ((eq? (##sys#get (caar syms) '##sys#override) 'value)
 550                 (loop (cdr syms)))
 551                (else (cons (assq (caar syms) (##sys#macro-environment))
 552                            (loop (cdr syms)))))))
 553
 554      (let* ((explist (module-export-list mod))
 555	     (name (module-name mod))
 556	     (dlist (module-defined-list mod))
 557	     (elist (module-exist-list mod))
 558	     (missing #f)
 559	     (sdlist (filter-sdlist mod))
 560	     (sexports
 561	      (if (eq? #t explist)
 562		  (merge-se (module-sexports mod) sdlist)
 563		  (let loop ((me (##sys#macro-environment)))
 564		    (cond ((null? me) '())
 565                          ((eq? (##sys#get (caar me) '##sys#override) 'value)
 566                           (loop (cdr me)))
 567			  ((find-export (caar me) mod #f)
 568			   (cons (car me) (loop (cdr me))))
 569			  (else (loop (cdr me)))))))
 570	     (vexports
 571	      (let loop ((xl (if (eq? #t explist) elist explist)))
 572		(if (null? xl)
 573		    '()
 574		    (let* ((h (car xl))
 575			   (id (if (symbol? h) h (car h))))
 576		      (cond ((eq? (##sys#get id '##sys#override) 'syntax)
 577                              (loop (cdr xl)))
 578                            ((assq id sexports) (loop (cdr xl)))
 579                            (else
 580                              (cons
 581                                (cons
 582			          id
 583                                  (let ((def (assq id dlist)))
 584                                    (if (and def (symbol? (cdr def)))
 585                                        (cdr def)
 586                                        (let ((a (assq id (##sys#current-environment))))
 587					  (define (fail msg)
 588					    (##sys#warn msg)
 589					    (set! missing #t))
 590					  (define (id-string)
 591					    (string-append "`" (symbol->string id) "'"))
 592                                          (cond ((and a (symbol? (cdr a)))
 593                                                 (dm "reexporting: " id " -> " (cdr a))
 594                                                 (cdr a))
 595						(def (module-rename id name))
 596						((invalid-export id)
 597						 =>
 598						 (lambda (type)
 599						   (fail (string-append
 600							  "Cannot export " (id-string)
 601							  " because it is " type "."))))
 602                                                ((not def)
 603						 (fail (string-append
 604							"Exported identifier " (id-string)
 605							" has not been defined.")))
 606                                                (else (bomb "fail")))))))
 607                              (loop (cdr xl))))))))))
 608
 609	;; Check all identifiers were resolved
 610	(let ((unknowns '()))
 611	  (for-each (lambda (u)
 612		      (unless (memq (car u) elist)
 613			(set! unknowns (cons u unknowns))))
 614		    (module-undefined-list mod))
 615	  (unless (null? unknowns)
 616	    (report-unresolved-identifiers unknowns)))
 617
 618	(when missing
 619	  (##sys#error "module unresolved" name))
 620	(let* ((iexports
 621		(map (lambda (exp)
 622		       (cond ((symbol? (cdr exp)) exp)
 623			     ((assq (car exp) (##sys#macro-environment)))
 624			     (else (##sys#error "(internal) indirect export not found" (car exp)))) )
 625		     (module-indirect-exports mod)))
 626	       (new-se (merge-se
 627			(##sys#macro-environment)
 628			(##sys#current-environment)
 629			iexports vexports sexports sdlist)))
 630	  (for-each
 631	   (lambda (m)
 632	     (let ((se (merge-se (cadr m) new-se))) ;XXX needed?
 633	       (dm `(FIXUP: ,(car m) ,@(map-se se)))
 634	       (set-car! (cdr m) se)))
 635	   sdlist)
 636	  (dm `(EXPORTS:
 637		,(module-name mod)
 638		(DLIST: ,@dlist)
 639		(SDLIST: ,@(map-se sdlist))
 640		(IEXPORTS: ,@(map-se iexports))
 641		(VEXPORTS: ,@(map-se vexports))
 642		(SEXPORTS: ,@(map-se sexports))))
 643	  (set-module-vexports! mod vexports)
 644	  (set-module-sexports! mod sexports)
 645	  (set-module-iexports!
 646	   mod
 647	   (merge-se (module-iexports mod) iexports)) ; "reexport" may already have added some
 648	  (set-module-saved-environments!
 649	   mod
 650	   (cons (merge-se (##sys#current-environment) vexports sexports)
 651		 (##sys#macro-environment))))))))
 652
 653(define ##sys#module-table '())
 654
 655
 656;;; Import-expansion
 657
 658(define (##sys#with-environment thunk)
 659  (parameterize ((##sys#current-module #f)
 660                 (##sys#current-environment '())
 661                 (##sys#current-meta-environment
 662                   (##sys#current-meta-environment))
 663                 (##sys#macro-environment
 664		   (##sys#meta-macro-environment)))
 665    (thunk)))
 666
 667(define (##sys#import-library-hook mname)
 668  (and-let* ((il (chicken.load#find-dynamic-extension
 669		  (string-append (symbol->string mname) ".import")
 670		  #t)))
 671     (##sys#with-environment
 672       (lambda ()
 673         (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
 674           (load il)
 675           (##sys#find-module mname #t 'import))))))
 676
 677(define (find-module/import-library lib loc)
 678  (let ((mname (##sys#resolve-module-name lib loc)))
 679    (or (##sys#find-module mname #f loc)
 680	(##sys#import-library-hook mname))))
 681
 682(define (##sys#decompose-import x r c loc)
 683  (let ((%only (r 'only))
 684	(%rename (r 'rename))
 685	(%except (r 'except))
 686	(%prefix (r 'prefix)))
 687    (define (warn msg mod id)
 688      (##sys#warn (string-append msg " in module `" (symbol->string mod) "'") id))
 689    (define (tostr x)
 690      (cond ((string? x) x)
 691	    ((keyword? x) (##sys#string-append (##sys#symbol->string/shared x) ":")) ; hack
 692	    ((symbol? x) (##sys#symbol->string/shared x))
 693	    ((number? x) (number->string x))
 694	    (else (##sys#syntax-error loc "invalid prefix" ))))
 695    (define (export-rename mod lst)
 696      (let ((ren (module-rename-list mod)))
 697        (if (null? ren)
 698            lst
 699            (map (lambda (a)
 700                   (cond ((assq (car a) ren) =>
 701                          (lambda (b)
 702                            (cons (cdr b) (cdr a))))
 703                         (else a)))
 704              lst))))
 705    (call-with-current-continuation
 706     (lambda (k)
 707       (define (module-imports name)
 708	 (let* ((id  (library-id name))
 709	        (mod (find-module/import-library id loc)))
 710	   (if (not mod)
 711	       (k id id #f #f #f #f)
 712	       (values (module-name mod)
 713		       (module-library mod)
 714		       (module-name mod)
 715		       (export-rename mod (module-vexports mod))
 716		       (export-rename mod (module-sexports mod))
 717		       (module-iexports mod)))))
 718       (let outer ((x x))
 719	 (cond ((symbol? x)
 720		(module-imports (strip-syntax x)))
 721	       ((not (pair? x))
 722		(##sys#syntax-error loc "invalid import specification" x))
 723	       (else
 724		(let ((head (car x)))
 725		  (cond ((c %only head)
 726			 (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
 727			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 728				      ((imports) (strip-syntax (cddr x))))
 729			   (let loop ((ids imports) (v '()) (s '()) (missing '()))
 730			     (cond ((null? ids)
 731				    (for-each
 732				     (lambda (id)
 733				       (warn "imported identifier doesn't exist" name id))
 734				     missing)
 735				    (values name lib `(,head ,spec ,@imports) v s impi))
 736				   ((assq (car ids) impv) =>
 737				    (lambda (a)
 738				      (loop (cdr ids) (cons a v) s missing)))
 739				   ((assq (car ids) imps) =>
 740				    (lambda (a)
 741				      (loop (cdr ids) v (cons a s) missing)))
 742				   (else
 743				    (loop (cdr ids) v s (cons (car ids) missing)))))))
 744			((c %except head)
 745			 (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
 746			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 747				      ((imports) (strip-syntax (cddr x))))
 748			   (let loopv ((impv impv) (v '()) (ids imports))
 749			     (cond ((null? impv)
 750				    (let loops ((imps imps) (s '()) (ids ids))
 751				      (cond ((null? imps)
 752					     (for-each
 753					      (lambda (id)
 754						(warn "excluded identifier doesn't exist" name id))
 755					      ids)
 756					     (values name lib `(,head ,spec ,@imports) v s impi))
 757					    ((memq (caar imps) ids) =>
 758								    (lambda (id)
 759								      (loops (cdr imps) s (delete (car id) ids eq?))))
 760					    (else
 761					     (loops (cdr imps) (cons (car imps) s) ids)))))
 762				   ((memq (caar impv) ids) =>
 763							   (lambda (id)
 764							     (loopv (cdr impv) v (delete (car id) ids eq?))))
 765				   (else
 766				    (loopv (cdr impv) (cons (car impv) v) ids))))))
 767			((c %rename head)
 768			 (##sys#check-syntax loc x '(_ _ . #((symbol symbol) 0)))
 769			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 770				      ((renames) (strip-syntax (cddr x))))
 771			   (let loopv ((impv impv) (v '()) (ids renames))
 772			     (cond ((null? impv)
 773				    (let loops ((imps imps) (s '()) (ids ids))
 774				      (cond ((null? imps)
 775					     (for-each
 776					      (lambda (id)
 777						(warn "renamed identifier doesn't exist" name id))
 778					      (map car ids))
 779					     (values name lib `(,head ,spec ,@renames) v s impi))
 780					    ((assq (caar imps) ids) =>
 781					     (lambda (a)
 782					       (loops (cdr imps)
 783						     (cons (cons (cadr a) (cdar imps)) s)
 784						     (delete a ids eq?))))
 785					    (else
 786					     (loops (cdr imps) (cons (car imps) s) ids)))))
 787				   ((assq (caar impv) ids) =>
 788				    (lambda (a)
 789				      (loopv (cdr impv)
 790					     (cons (cons (cadr a) (cdar impv)) v)
 791					     (delete a ids eq?))))
 792				   (else
 793				    (loopv (cdr impv) (cons (car impv) v) ids))))))
 794			((c %prefix head)
 795			 (##sys#check-syntax loc x '(_ _ _))
 796			 (let-values (((name lib spec impv imps impi) (outer (cadr x)))
 797				      ((prefix) (strip-syntax (caddr x))))
 798			   (define (rename imp)
 799			     (cons
 800			      (##sys#string->symbol
 801			       (##sys#string-append (tostr prefix) (##sys#symbol->string/shared (car imp))))
 802			      (cdr imp)))
 803			   (values name lib `(,head ,spec ,prefix) (map rename impv) (map rename imps) impi)))
 804			(else
 805			 (module-imports (strip-syntax x))))))))))))
 806
 807(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
 808  (##sys#check-syntax loc x '(_ . #(_ 1)))
 809  (for-each
 810   (lambda (x)
 811     (let-values (((name _ spec v s i) (##sys#decompose-import x r c loc)))
 812       (if (not spec)
 813	   (##sys#syntax-error loc "cannot import from undefined module" name x)
 814	   (##sys#import spec v s i import-env macro-env meta? reexp? loc))))
 815   (cdr x))
 816  '(##core#undefined))
 817
 818(define (##sys#import spec vsv vss vsi import-env macro-env meta? reexp? loc)
 819  (let ((cm (##sys#current-module)))
 820    (when cm ; save import form
 821      (if meta?
 822          (set-module-meta-import-forms!
 823           cm
 824           (append (module-meta-import-forms cm) (list spec)))
 825          (set-module-import-forms!
 826           cm
 827           (append (module-import-forms cm) (list spec)))))
 828    (dd `(IMPORT: ,loc))
 829    (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
 830    (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
 831    (for-each
 832     (lambda (imp)
 833       (let ((id (car imp)))
 834         (##sys#put! id '##sys#override #f)
 835         (and-let* ((a (assq id (import-env)))
 836                    (aid (cdr imp))
 837                    ((not (eq? aid (cdr a)))))
 838              (##sys#notice "re-importing already imported identifier" id))))
 839     vsv)
 840    (for-each
 841     (lambda (imp)
 842       (let ((id (car imp)))
 843         (##sys#put! id '##sys#override #f)
 844         (and-let* ((a (assq (car imp) (macro-env)))
 845                    ((not (eq? (cdr imp) (cdr a)))))
 846              (##sys#notice "re-importing already imported syntax" (car imp)))))
 847     vss)
 848    (when reexp?
 849      (unless cm
 850        (##sys#syntax-error loc "`reexport' only valid inside a module"))
 851      (let ((el (module-export-list cm)))
 852        (cond ((eq? #t el)
 853               (set-module-sexports! cm (append vss (module-sexports cm)))
 854               (set-module-exist-list!
 855                cm
 856                (append (module-exist-list cm)
 857                        (map car vsv)
 858                        (map car vss))))
 859              (else
 860               (set-module-export-list!
 861                cm
 862                (append
 863                 (let ((xl (module-export-list cm)))
 864                   (if (eq? #t xl) '() xl))
 865                 (map car vsv)
 866                 (map car vss))))))
 867      (set-module-iexports!
 868       cm
 869       (merge-se (module-iexports cm) vsi))
 870      (dm "export-list: " (module-export-list cm)))
 871    (import-env (merge-se (import-env) vsv))
 872    (macro-env (merge-se (macro-env) vss))))
 873
 874(define (module-rename sym prefix)
 875  (##sys#string->symbol
 876   (string-append
 877    (##sys#symbol->string/shared prefix)
 878    "#"
 879    (##sys#symbol->string/shared sym) ) ) )
 880
 881(define (##sys#alias-global-hook sym assign where)
 882  (define (mrename sym)
 883    (cond ((##sys#current-module) =>
 884	   (lambda (mod)
 885	     (dm "(ALIAS) global alias " sym " in " (module-name mod))
 886	     (unless assign
 887	       (register-undefined sym mod where))
 888	     (module-rename sym (module-name mod))))
 889	  (else sym)))
 890  (cond ((namespaced-symbol? sym) sym)
 891	((assq sym (##sys#current-environment)) =>
 892	 (lambda (a)
 893	   (let ((sym2 (cdr a)))
 894	     (dm "(ALIAS) in current environment " sym " -> " sym2)
 895	     ;; check for macro (XXX can this be?)
 896	     (if (pair? sym2) (mrename sym) sym2))))
 897	(else (mrename sym))))
 898
 899(define (##sys#validate-exports exps loc)
 900  ;; expects "exps" to be stripped
 901  (define (err . args)
 902    (apply ##sys#syntax-error loc args))
 903  (define (iface name)
 904    (or (getp name '##core#interface)
 905	(err "unknown interface" name exps)))
 906  (cond ((eq? '* exps) exps)
 907	((symbol? exps) (iface exps))
 908	((not (list? exps))
 909	 (err "invalid exports" exps))
 910	(else
 911	 (let loop ((xps exps))
 912	   (cond ((null? xps) '())
 913		 ((not (pair? xps))
 914		  (err "invalid exports" exps))
 915		 (else
 916		  (let ((x (car xps)))
 917		    (cond ((symbol? x) (cons x (loop (cdr xps))))
 918			  ((not (list? x))
 919			   (err "invalid export" x exps))
 920			  ((eq? #:syntax (car x))
 921			   (cons (cdr x) (loop (cdr xps)))) ; currently not used
 922			  ((eq? #:interface (car x))
 923			   (if (and (pair? (cdr x)) (symbol? (cadr x)))
 924			       (append (iface (cadr x)) (loop (cdr xps)))
 925			       (err "invalid interface specification" x exps)))
 926			  (else
 927			   (let loop2 ((lst x))
 928			     (cond ((null? lst) (cons x (loop (cdr xps))))
 929				   ((symbol? (car lst)) (loop2 (cdr lst)))
 930				   (else (err "invalid export" x exps)))))))))))))
 931
 932(define (##sys#register-functor name fargs fexps body)
 933  (putp name '##core#functor (cons fargs (cons fexps body))))
 934
 935(define (##sys#instantiate-functor name fname args)
 936  (let ((funcdef (getp fname '##core#functor)))
 937    (define (err . args)
 938      (apply ##sys#syntax-error name args))
 939    (unless funcdef (err "instantation of undefined functor" fname))
 940    (let ((fargs (car funcdef))
 941	  (exports (cadr funcdef))
 942	  (body (cddr funcdef)))
 943      (define (merr)
 944	(err "argument list mismatch in functor instantiation"
 945	     (cons name args) (cons fname (map car fargs))))
 946      `(##core#let-module-alias
 947	,(let loop ((as args) (fas fargs))
 948	   (cond ((null? as)
 949		  ;; use default arguments (if available) or bail out
 950		  (let loop2 ((fas fas))
 951		    (if (null? fas)
 952			'()
 953			(let ((p (car fas)))
 954			  (if (pair? (car p)) ; has default argument?
 955			      (let ((exps (cdr p))
 956				    (alias (caar p))
 957				    (mname (library-id (cadar p))))
 958				(match-functor-argument alias name mname exps fname)
 959				(cons (list alias mname) (loop2 (cdr fas))))
 960			      ;; no default argument, we have too few argument modules
 961			      (merr))))))
 962		 ;; more arguments given as defined for the functor
 963		 ((null? fas) (merr))
 964		 (else
 965		  ;; otherwise match provided argument to functor argument
 966		  (let* ((p (car fas))
 967			 (p1 (car p))
 968			 (exps (cdr p))
 969			 (def? (pair? p1))
 970			 (alias (if def? (car p1) p1))
 971			 (mname (library-id (car as))))
 972		    (match-functor-argument alias name mname exps fname)
 973		    (cons (list alias mname)
 974			  (loop (cdr as) (cdr fas)))))))
 975	(##core#module
 976	 ,name
 977	 ,(if (eq? '* exports) #t exports)
 978	 ,@body)))))
 979
 980(define (match-functor-argument alias name mname exps fname)
 981  (let ((mod (##sys#find-module (##sys#resolve-module-name mname 'module) #t 'module)))
 982    (unless (eq? exps '*)
 983      (let ((missing '()))
 984	(for-each
 985	 (lambda (exp)
 986	   (let ((sym (if (symbol? exp) exp (car exp))))
 987	     (unless (or (assq sym (module-vexports mod))
 988			 (assq sym (module-sexports mod)))
 989	       (set! missing (cons sym missing)))))
 990	 exps)
 991	(when (pair? missing)
 992	  (##sys#syntax-error
 993	   'module
 994	   (apply
 995	    string-append
 996	    "argument module `" (symbol->string mname) "' does not match required signature\n"
 997	    "in instantiation `" (symbol->string name) "' of functor `"
 998	    (symbol->string fname) "', because the following required exports are missing:\n"
 999	    (map (lambda (s) (string-append "\n  " (symbol->string s))) missing))))))))
 1000
1001
1002;;; built-in modules (needed for eval environments)
1003
1004(let ((r4rs-values
1005       '((not . scheme#not) (boolean? . scheme#boolean?)
1006	 (eq? . scheme#eq?) (eqv? . scheme#eqv?) (equal? . scheme#equal?)
1007	 (pair? . scheme#pair?) (cons . scheme#cons)
1008	 (car . scheme#car) (cdr . scheme#cdr)
1009	 (caar . scheme#caar) (cadr . scheme#cadr) (cdar . scheme#cdar)
1010	 (cddr . scheme#cddr)
1011	 (caaar . scheme#caaar) (caadr . scheme#caadr)
1012	 (cadar . scheme#cadar) (caddr . scheme#caddr)
1013	 (cdaar . scheme#cdaar) (cdadr . scheme#cdadr)
1014	 (cddar . scheme#cddar) (cdddr . scheme#cdddr)
1015	 (caaaar . scheme#caaaar) (caaadr . scheme#caaadr)
1016	 (caadar . scheme#caadar) (caaddr . scheme#caaddr)
1017	 (cadaar . scheme#cadaar) (cadadr . scheme#cadadr)
1018	 (caddar . scheme#caddar) (cadddr . scheme#cadddr)
1019	 (cdaaar . scheme#cdaaar) (cdaadr . scheme#cdaadr)
1020	 (cdadar . scheme#cdadar) (cdaddr . scheme#cdaddr)
1021	 (cddaar . scheme#cddaar) (cddadr . scheme#cddadr)
1022	 (cdddar . scheme#cdddar) (cddddr . scheme#cddddr)
1023	 (set-car! . scheme#set-car!) (set-cdr! . scheme#set-cdr!)
1024	 (null? . scheme#null?) (list? . scheme#list?)
1025	 (list . scheme#list) (length . scheme#length)
1026	 (list-tail . scheme#list-tail) (list-ref . scheme#list-ref)
1027	 (append . scheme#append) (reverse . scheme#reverse)
1028	 (memq . scheme#memq) (memv . scheme#memv)
1029	 (member . scheme#member) (assq . scheme#assq)
1030	 (assv . scheme#assv) (assoc . scheme#assoc)
1031	 (symbol? . scheme#symbol?)
1032	 (symbol->string . scheme#symbol->string)
1033	 (string->symbol . scheme#string->symbol)
1034	 (number? . scheme#number?) (integer? . scheme#integer?)
1035	 (exact? . scheme#exact?) (real? . scheme#real?)
1036	 (complex? . scheme#complex?) (inexact? . scheme#inexact?)
1037	 (rational? . scheme#rational?) (zero? . scheme#zero?)
1038	 (odd? . scheme#odd?) (even? . scheme#even?)
1039	 (positive? . scheme#positive?) (negative? . scheme#negative?)
1040	 (max . scheme#max) (min . scheme#min)
1041	 (+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/)
1042	 (= . scheme#=) (> . scheme#>) (< . scheme#<)
1043	 (>= . scheme#>=) (<= . scheme#<=)
1044	 (quotient . scheme#quotient) (remainder . scheme#remainder)
1045	 (modulo . scheme#modulo)
1046	 (gcd . scheme#gcd) (lcm . scheme#lcm) (abs . scheme#abs)
1047	 (floor . scheme#floor) (ceiling . scheme#ceiling)
1048	 (truncate . scheme#truncate) (round . scheme#round)
1049	 (rationalize . scheme#rationalize)
1050	 (exact->inexact . scheme#exact->inexact)
1051	 (inexact->exact . scheme#inexact->exact)
1052	 (exp . scheme#exp) (log . scheme#log) (expt . scheme#expt)
1053	 (sqrt . scheme#sqrt)
1054	 (sin . scheme#sin) (cos . scheme#cos) (tan . scheme#tan)
1055	 (asin . scheme#asin) (acos . scheme#acos) (atan . scheme#atan)
1056	 (number->string . scheme#number->string)
1057	 (string->number . scheme#string->number)
1058	 (char? . scheme#char?) (char=? . scheme#char=?)
1059	 (char>? . scheme#char>?) (char<? . scheme#char<?)
1060	 (char>=? . scheme#char>=?) (char<=? . scheme#char<=?)
1061	 (char-ci=? . scheme#char-ci=?)
1062	 (char-ci<? . scheme#char-ci<?) (char-ci>? . scheme#char-ci>?)
1063	 (char-ci>=? . scheme#char-ci>=?) (char-ci<=? . scheme#char-ci<=?)
1064	 (char-alphabetic? . scheme#char-alphabetic?)
1065	 (char-whitespace? . scheme#char-whitespace?)
1066	 (char-numeric? . scheme#char-numeric?)
1067	 (char-upper-case? . scheme#char-upper-case?)
1068	 (char-lower-case? . scheme#char-lower-case?)
1069	 (char-upcase . scheme#char-upcase)
1070	 (char-downcase . scheme#char-downcase)
1071	 (char->integer . scheme#char->integer)
1072	 (integer->char . scheme#integer->char)
1073	 (string? . scheme#string?) (string=? . scheme#string=?)
1074	 (string>? . scheme#string>?) (string<? . scheme#string<?)
1075	 (string>=? . scheme#string>=?) (string<=? . scheme#string<=?)
1076	 (string-ci=? . scheme#string-ci=?)
1077	 (string-ci<? . scheme#string-ci<?)
1078	 (string-ci>? . scheme#string-ci>?)
1079	 (string-ci>=? . scheme#string-ci>=?)
1080	 (string-ci<=? . scheme#string-ci<=?)
1081	 (make-string . scheme#make-string)
1082	 (string-length . scheme#string-length)
1083	 (string-ref . scheme#string-ref)
1084	 (string-set! . scheme#string-set!)
1085	 (string-append . scheme#string-append)
1086	 (string-copy . scheme#string-copy)
1087	 (string->list . scheme#string->list)
1088	 (list->string . scheme#list->string)
1089	 (substring . scheme#substring)
1090	 (string-fill! . scheme#string-fill!)
1091	 (vector? . scheme#vector?) (make-vector . scheme#make-vector)
1092	 (vector-ref . scheme#vector-ref)
1093	 (vector-set! . scheme#vector-set!)
1094	 (string . scheme#string) (vector . scheme#vector)
1095	 (vector-length . scheme#vector-length)
1096	 (vector->list . scheme#vector->list)
1097	 (list->vector . scheme#list->vector)
1098	 (vector-fill! . scheme#vector-fill!)
1099	 (procedure? . scheme#procedure?)
1100	 (map . scheme#map) (for-each . scheme#for-each)
1101	 (apply . scheme#apply) (force . scheme#force)
1102	 (call-with-current-continuation . scheme#call-with-current-continuation)
1103	 (input-port? . scheme#input-port?)
1104	 (output-port? . scheme#output-port?)
1105	 (current-input-port . scheme#current-input-port)
1106	 (current-output-port . scheme#current-output-port)
1107	 (call-with-input-file . scheme#call-with-input-file)
1108	 (call-with-output-file . scheme#call-with-output-file)
1109	 (open-input-file . scheme#open-input-file)
1110	 (open-output-file . scheme#open-output-file)
1111	 (close-input-port . scheme#close-input-port)
1112	 (close-output-port . scheme#close-output-port)
1113	 (load . scheme#load) (read . scheme#read)
1114	 (read-char . scheme#read-char) (peek-char . scheme#peek-char)
1115	 (write . scheme#write) (display . scheme#display)
1116	 (write-char . scheme#write-char) (newline . scheme#newline)
1117	 (eof-object? . scheme#eof-object?)
1118	 (with-input-from-file . scheme#with-input-from-file)
1119	 (with-output-to-file . scheme#with-output-to-file)
1120	 (char-ready? . scheme#char-ready?)
1121	 (imag-part . scheme#imag-part) (real-part . scheme#real-part)
1122	 (make-rectangular . scheme#make-rectangular)
1123	 (make-polar . scheme#make-polar)
1124	 (angle . scheme#angle) (magnitude . scheme#magnitude)
1125	 (numerator . scheme#numerator)
1126	 (denominator . scheme#denominator)
1127	 (scheme-report-environment . scheme#scheme-report-environment)
1128	 (null-environment . scheme#null-environment)
1129	 (interaction-environment . scheme#interaction-environment)))
1130      (r4rs-syntax ##sys#scheme-macro-environment))
1131  (##sys#register-core-module 'scheme.r4rs 'library r4rs-values r4rs-syntax)
1132  (##sys#register-core-module
1133   'scheme.r5rs 'library
1134   (append '((dynamic-wind . scheme#dynamic-wind)
1135	     (eval . scheme#eval)
1136	     (values . scheme#values)
1137	     (call-with-values . scheme#call-with-values))
1138	   r4rs-values)
1139   r4rs-syntax)
1140  (##sys#register-core-module 'scheme.r4rs-null #f '() r4rs-syntax)
1141  (##sys#register-core-module 'scheme.r5rs-null #f '() r4rs-syntax))
1142
1143(##sys#register-module-alias 'scheme 'scheme.r5rs)
1144
1145(define (se-subset names env)
1146  (map (lambda (n) (assq n env)) names))
1147
1148(##sys#register-core-module 'scheme.base
1149  'library
1150  '((not . scheme#not) (boolean? . scheme#boolean?)
1151    (eq? . scheme#eq?) (eqv? . scheme#eqv?) (equal? . scheme#equal?)
1152    (pair? . scheme#pair?) (cons . scheme#cons)
1153    (car . scheme#car) (cdr . scheme#cdr)
1154    (caar . scheme#caar) (cadr . scheme#cadr) (cdar . scheme#cdar)
1155    (cddr . scheme#cddr)
1156    (set-car! . scheme#set-car!) (set-cdr! . scheme#set-cdr!)
1157    (null? . scheme#null?) (list? . scheme#list?)
1158    (list . scheme#list) (length . scheme#length)
1159    (list-tail . scheme#list-tail) (list-ref . scheme#list-ref)
1160    (list-set! . scheme#list-set!) (list-copy . scheme#list-copy)
1161    (boolean=? . scheme#boolean=?) (symbol=? . scheme#symbol=?)
1162    (append . scheme#append) (reverse . scheme#reverse)
1163    (memq . scheme#memq) (memv . scheme#memv)
1164    (member . scheme#member) (assq . scheme#assq)
1165    (assv . scheme#assv) (assoc . scheme#assoc)
1166    (symbol? . scheme#symbol?)
1167    (port? . scheme#port?)
1168    (input-port-open? . scheme#input-port-open?)
1169    (output-port-open? . scheme#output-port-open?)
1170    (call-with-port . scheme#call-with-port)
1171    (symbol->string . scheme#symbol->string)
1172    (string->symbol . scheme#string->symbol)
1173    (string->vector . scheme#string->vector)
1174    (vector->string . scheme#vector->string)
1175    (vector-append . scheme#vector-append)
1176    (vector-map . scheme#vector-map)
1177    (vector-for-each . scheme#vector-for-each)
1178    (string-map . scheme#string-map)
1179    (string-for-each . scheme#string-for-each)
1180    (number? . scheme#number?) (integer? . scheme#integer?)
1181    (exact? . scheme#exact?) (real? . scheme#real?)
1182    (complex? . scheme#complex?) (inexact? . scheme#inexact?)
1183    (rational? . scheme#rational?) (zero? . scheme#zero?)
1184    (odd? . scheme#odd?) (even? . scheme#even?)
1185    (positive? . scheme#positive?) (negative? . scheme#negative?)
1186    (exact-integer? . scheme#exact-integer?)
1187    (max . scheme#max) (min . scheme#min)
1188    (+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/)
1189    (= . scheme#=) (> . scheme#>) (< . scheme#<)
1190    (>= . scheme#>=) (<= . scheme#<=)
1191    (quotient . scheme#quotient) (remainder . scheme#remainder)
1192    (floor-quotient . scheme#floor-quotient) (floor-remainder . scheme#floor-remainder)
1193    (truncate-quotient . scheme#quotient) (truncate-remainder . scheme#remainder)
1194    (floor/ . scheme#floor/) (truncate/ . scheme#truncate/)
1195    (modulo . scheme#modulo)
1196    (gcd . scheme#gcd) (lcm . scheme#lcm) (abs . scheme#abs)
1197    (floor . scheme#floor) (ceiling . scheme#ceiling)
1198    (truncate . scheme#truncate) (round . scheme#round)
1199    (rationalize . scheme#rationalize)
1200    (inexact . scheme#exact->inexact)
1201    (exact . scheme#inexact->exact)
1202    (sqrt . scheme#sqrt)
1203    (square . scheme#square)
1204    (exact-integer-sqrt . scheme#exact-integer-sqrt)
1205    (expt . scheme#expt)
1206    (number->string . scheme#number->string)
1207    (string->number . scheme#string->number)
1208    (char? . scheme#char?) (char=? . scheme#char=?)
1209    (char>? . scheme#char>?) (char<? . scheme#char<?)
1210    (char>=? . scheme#char>=?) (char<=? . scheme#char<=?)
1211    (char->integer . scheme#char->integer)
1212    (integer->char . scheme#integer->char)
1213    (string? . scheme#string?) (string=? . scheme#string=?)
1214    (string>? . scheme#string>?) (string<? . scheme#string<?)
1215    (string>=? . scheme#string>=?) (string<=? . scheme#string<=?)
1216    (make-string . scheme#make-string)
1217    (make-list . scheme#make-list)
1218    (string-length . scheme#string-length)
1219    (string-ref . scheme#string-ref)
1220    (string-set! . scheme#string-set!)
1221    (string-append . scheme#string-append)
1222    (string-copy . scheme#string-copy)
1223    (string-copy! . scheme#string-copy!)
1224    (string->list . scheme#string->list)
1225    (list->string . scheme#list->string)
1226    (substring . scheme#substring)
1227    (string-fill! . scheme#string-fill!)
1228    (vector? . scheme#vector?) (make-vector . scheme#make-vector)
1229    (vector-ref . scheme#vector-ref)
1230    (vector-set! . scheme#vector-set!)
1231    (string . scheme#string) (vector . scheme#vector)
1232    (vector-length . scheme#vector-length)
1233    (vector->list . scheme#vector->list)
1234    (list->vector . scheme#list->vector)
1235    (vector-copy . scheme#vector-copy)
1236    (vector-copy! . scheme#vector-copy!)
1237    (vector-fill! . scheme#vector-fill!)
1238    (call-with-values . scheme#call-with-values)
1239    (values . scheme#values)
1240    (procedure? . scheme#procedure?)
1241    (make-parameter . scheme#make-parameter)
1242    (map . scheme#map) (for-each . scheme#for-each)
1243    (apply . scheme#apply) (dynamic-wind . scheme#dynamic-wind)
1244    (call-with-current-continuation . scheme#call-with-current-continuation)
1245    (call/cc . scheme#call-with-current-continuation)
1246    (input-port? . scheme#input-port?)
1247    (output-port? . scheme#output-port?)
1248    (current-input-port . scheme#current-input-port)
1249    (current-output-port . scheme#current-output-port)
1250    (current-error-port . chicken.base#current-error-port)
1251    (open-input-file . scheme#open-input-file)
1252    (open-output-file . scheme#open-output-file)
1253    (close-input-port . scheme#close-input-port)
1254    (close-output-port . scheme#close-output-port)
1255    (read-char . scheme#read-char) (peek-char . scheme#peek-char)
1256    (read-string . chicken.io#read-string)
1257    (peek-u8 . scheme#peek-u8) (features . scheme#features)
1258    (read-u8 . chicken.io#read-byte) (write-u8 . chicken.io#write-byte)
1259    (write-char . scheme#write-char) (newline . scheme#newline)
1260    (eof-object? . scheme#eof-object?)
1261    (eof-object . scheme#eof-object)
1262    (flush-output-port . chicken.base#flush-output)
1263    (with-input-from-file . scheme#with-input-from-file)
1264    (with-output-to-file . scheme#with-output-to-file)
1265    (close-port . scheme#close-port)
1266    (char-ready? . scheme#char-ready?)
1267    (u8-ready? . scheme#u8-ready?)
1268    (numerator . scheme#numerator)
1269    (denominator . scheme#denominator)
1270    (scheme-report-environment . scheme#scheme-report-environment)
1271    (null-environment . scheme#null-environment)
1272    (open-input-string . scheme#open-input-string)
1273    (open-output-string . scheme#open-output-string)
1274    (open-output-bytevector . scheme#open-output-bytevector)
1275    (open-input-bytevector . scheme#open-input-bytevector)
1276    (get-output-string . scheme#get-output-string)
1277    (get-output-bytevector . scheme#get-output-bytevector)
1278    (with-exception-handler . scheme#with-exception-handler)
1279    (raise . scheme#raise) (raise-continuable . scheme#raise-continuable)
1280    (error . chicken.base#error)
1281    (file-error? . scheme#file-error?)
1282    (read-error? . scheme#read-error?)
1283    (error-object? . scheme#error-object?)
1284    (error-object-message . scheme#error-object-message)
1285    (error-object-irritants . scheme#error-object-irritants)
1286    (string->utf8 . chicken.bytevector#string->utf8)
1287    (utf8->string . chicken.bytevector#utf8->string)
1288    (write-bytevector . chicken.io#write-bytevector)
1289    (bytevector . chicken.bytevector#bytevector)
1290    (bytevector-length . chicken.bytevector#bytevector-length)
1291    (bytevector? . chicken.bytevector#bytevector?)
1292    (make-bytevector . chicken.bytevector#make-bytevector)
1293    (bytevector-append . chicken.bytevector#bytevector-append)
1294    (bytevector-copy . chicken.bytevector#bytevector-copy)
1295    (bytevector-copy! . chicken.bytevector#bytevector-copy!)
1296    (bytevector-u8-ref . chicken.bytevector#bytevector-u8-ref)
1297    (bytevector-u8-set! . chicken.bytevector#bytevector-u8-set!)
1298    (read-bytevector . chicken.io#read-bytevector)
1299    (read-bytevector! . chicken.io#read-bytevector!)
1300    (read-line . chicken.io#read-line)
1301    (write-string . scheme#write-string) )
1302  (se-subset '(define let let* letrec letrec* let-values define-values let*-values
1303                parameterize when unless do define define-syntax case cond guard
1304                define-record-type include include-ci set! syntax-rules cond-expand
1305                import export begin import-for-syntax and or lambda if quote
1306                case-lambda quasiquote syntax-error)
1307             (##sys#macro-environment)))
1308
1309;; Hack for library.scm to use macros from modules it defines itself.
1310(##sys#register-primitive-module
1311 'chicken.internal.syntax '() (##sys#macro-environment))
1312
1313(##sys#register-primitive-module
1314 'chicken.module '() ##sys#chicken.module-macro-environment)
1315
1316(##sys#register-primitive-module
1317 'chicken.type '() ##sys#chicken.type-macro-environment)
1318
1319(##sys#register-primitive-module
1320 'srfi-2 '() (se-subset '(and-let*) ##sys#chicken.base-macro-environment))
1321
1322(##sys#register-primitive-module
1323 'srfi-8 '() (se-subset '(receive) ##sys#chicken.base-macro-environment))
1324
1325(##sys#register-primitive-module
1326 'srfi-9 '() (se-subset '(define-record-type) ##sys#chicken.base-macro-environment))
1327
1328(##sys#register-core-module
1329 'srfi-10 'read-syntax '((define-reader-ctor . chicken.read-syntax#define-reader-ctor)))
1330
1331(##sys#register-core-module
1332 'srfi-12 'library
1333 '((abort . chicken.condition#abort)
1334   (condition? . chicken.condition#condition?)
1335   (condition-predicate . chicken.condition#condition-predicate)
1336   (condition-property-accessor . chicken.condition#condition-property-accessor)
1337   (current-exception-handler . chicken.condition#current-exception-handler)
1338   (make-composite-condition . chicken.condition#make-composite-condition)
1339   (make-property-condition . chicken.condition#make-property-condition)
1340   (signal . chicken.condition#signal)
1341   (with-exception-handler . chicken.condition#with-exception-handler))
1342 (se-subset '(handle-exceptions) ##sys#chicken.condition-macro-environment))
1343
1344(##sys#register-primitive-module
1345 'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken.base-macro-environment))
1346
1347(##sys#register-core-module
1348  'scheme.case-lambda
1349  'library '()
1350  ##sys#scheme.case-lambda-macro-environment)
1351
1352(##sys#register-core-module
1353  'scheme.lazy 'library
1354  '((force . scheme#force)
1355    (promise? . chicken.base#promise?)
1356    (make-promise . chicken.base#make-promise))
1357  (cons (assq 'delay ##sys#scheme-macro-environment)
1358        (se-subset '(delay-force) ##sys#chicken.base-macro-environment)))
1359
1360(##sys#register-core-module
1361  'scheme.complex 'library
1362  '((imag-part . scheme#imag-part) (real-part . scheme#real-part)
1363    (make-rectangular . scheme#make-rectangular)
1364    (make-polar . scheme#make-polar)
1365    (angle . scheme#angle) (magnitude . scheme#magnitude)))
1366
1367(##sys#register-core-module
1368  'scheme.cxr 'library
1369  '((caaar . scheme#caaar)
1370    (caadr . scheme#caadr)
1371    (cadar . scheme#cadar)
1372    (caddr . scheme#caddr)
1373    (cdaar . scheme#cdaar)
1374    (cdadr . scheme#cdadr)
1375    (cddar . scheme#cddar)
1376    (cdddr . scheme#cdddr)
1377    (caaaar . scheme#caaaar)
1378    (caaadr . scheme#caaadr)
1379    (caadar . scheme#caadar)
1380    (caaddr . scheme#caaddr)
1381    (cadaar . scheme#cadaar)
1382    (cadadr . scheme#cadadr)
1383    (caddar . scheme#caddar)
1384    (cadddr . scheme#cadddr)
1385    (cdaaar . scheme#cdaaar)
1386    (cdaadr . scheme#cdaadr)
1387    (cdadar . scheme#cdadar)
1388    (cdaddr . scheme#cdaddr)
1389    (cddaar . scheme#cddaar)
1390    (cddadr . scheme#cddadr)
1391    (cdddar . scheme#cdddar)
1392    (cddddr . scheme#cddddr)))
1393
1394(##sys#register-core-module
1395 'scheme.inexact 'library
1396 '((exp . scheme#exp) (log . scheme#log)
1397   (sqrt . scheme#sqrt) (nan? . chicken.base#nan?)
1398   (sin . scheme#sin) (cos . scheme#cos) (tan . scheme#tan)
1399   (asin . scheme#asin) (acos . scheme#acos) (atan . scheme#atan)
1400   (finite? . chicken.base#finite?)
1401   (infinite? . chicken.base#infinite?)))
1402
1403(##sys#register-core-module
1404 'srfi-17 'library
1405 '((getter-with-setter . chicken.base#getter-with-setter)
1406   (setter . chicken.base#setter))
1407 (se-subset '(set!) ##sys#default-macro-environment))
1408
1409(##sys#register-primitive-module
1410 'srfi-26 '() (se-subset '(cut cute) ##sys#chicken.base-macro-environment))
1411
1412(##sys#register-core-module
1413 'srfi-28 'extras '((format . chicken.format#format)))
1414
1415(##sys#register-primitive-module
1416 'srfi-31 '() (se-subset '(rec) ##sys#chicken.base-macro-environment))
1417
1418(##sys#register-primitive-module
1419 'srfi-55 '() (se-subset '(require-extension) ##sys#chicken.base-macro-environment))
1420
1421(##sys#register-core-module
1422 'srfi-88 'library
1423 '((keyword? . chicken.keyword#keyword?)
1424   (keyword->string . chicken.keyword#keyword->string)
1425   (string->keyword . chicken.keyword#string->keyword)))
1426
1427(define (chicken.module#module-environment mname #!optional (ename mname))
1428  (let ((mod (find-module/import-library mname 'module-environment)))
1429    (if (not mod)
1430	(##sys#syntax-error
1431	 'module-environment "undefined module" mname)
1432        (let ((senv (module-saved-environments mod)))
1433          (##sys#make-structure 'environment
1434                                ename
1435                                (car senv)
1436                                (cdr senv)
1437                                #t)))))
1438
1439(define (scheme.eval#environment . specs)
1440  (let ((name (gensym "environment-module-")))
1441      (define (delmod)
1442	(and-let* ((modp (assq name ##sys#module-table)))
1443	  (set! ##sys#module-table (delq modp ##sys#module-table))))
1444      (define (delq x lst)
1445        (let loop ([lst lst])
1446          (cond ((null? lst) lst)
1447	        ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
1448	        (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
1449      (dynamic-wind
1450       void
1451       (lambda ()
1452	 ;; create module...
1453	 (scheme#eval `(module ,name ()
1454                        ,@(map (lambda (spec) `(import ,spec)) specs)))
1455	 (let* ((mod (##sys#find-module name))
1456                (env (module-saved-environments mod)))
1457            (##sys#make-structure 'environment
1458                                  (cons 'import specs)
1459                                  (car env)
1460                                  (cdr env)
1461                                  #t)))
1462        ;; ...and remove it right away
1463        delmod)))
1464
1465(##sys#register-core-module
1466 'scheme.eval 'eval
1467 '((eval . scheme#eval)
1468   (environment . scheme.eval#environment)))
1469
1470(##sys#register-core-module
1471 'scheme.load 'eval
1472 '((load . scheme#load)))
1473
1474(##sys#register-core-module
1475 'scheme.read 'library
1476 '((read . scheme#read)))
1477
1478(##sys#register-core-module
1479 'scheme.repl 'eval
1480 '((interaction-environment . scheme#interaction-environment)))
1481
1482(##sys#register-core-module
1483 'scheme.char 'library
1484  '((char-alphabetic? . scheme#char-alphabetic?)
1485    (char-ci<=? . scheme#char-ci<=?)
1486    (char-ci<? . scheme#char-ci<?)
1487    (char-ci=? . scheme#char-ci=?)
1488    (char-ci>=? . scheme#char-ci>=?)
1489    (char-ci>? . scheme#char-ci>?)
1490    (char-downcase . scheme#char-downcase)
1491    (char-foldcase . scheme#char-foldcase)
1492    (char-lower-case? . scheme#char-lower-case?)
1493    (char-numeric? . scheme#char-numeric?)
1494    (char-upcase . scheme#char-upcase)
1495    (char-upper-case? . scheme#char-upper-case?)
1496    (char-whitespace? . scheme#char-whitespace?)
1497    (digit-value . scheme.char#digit-value)
1498    (string-ci<=? . scheme#string-ci<=?)
1499    (string-ci<? . scheme#string-ci<?)
1500    (string-ci=? . scheme#string-ci=?)
1501    (string-ci>=? . scheme#string-ci>=?)
1502    (string-ci>? . scheme#string-ci>?)
1503    (string-downcase . scheme#string-downcase)
1504    (string-foldcase . scheme#string-foldcase)
1505    (string-upcase . scheme#string-upcase)))
1506
1507;; Ensure default modules are available in "eval", too
1508;; TODO: Figure out a better way to make this work for static programs.
1509;; The actual imports are handled lazily by eval when first called.
1510(include "chicken.base.import.scm")
1511(include "chicken.syntax.import.scm")