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