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