~ 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 '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    (max . scheme#max) (min . scheme#min)
1179    (+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/)
1180    (= . scheme#=) (> . scheme#>) (< . scheme#<)
1181    (>= . scheme#>=) (<= . scheme#<=)
1182    (quotient . scheme#quotient) (remainder . scheme#remainder)
1183    (floor-quotient . scheme#floor-quotient) (floor-remainder . scheme#floor-remainder)
1184    (truncate-quotient . scheme#quotient) (truncate-remainder . scheme#remainder)
1185    (floor/ . scheme#floor/) (truncate/ . scheme#truncate/)
1186    (modulo . scheme#modulo)
1187    (gcd . scheme#gcd) (lcm . scheme#lcm) (abs . scheme#abs)
1188    (floor . scheme#floor) (ceiling . scheme#ceiling)
1189    (truncate . scheme#truncate) (round . scheme#round)
1190    (rationalize . scheme#rationalize)
1191    (inexact . scheme#exact->inexact)
1192    (exact . scheme#inexact->exact)
1193    (sqrt . scheme#sqrt)
1194    (square . scheme#square)
1195    (exact-integer-sqrt . scheme#exact-integer-sqrt)
1196    (number->string . scheme#number->string)
1197    (string->number . scheme#string->number)
1198    (char? . scheme#char?) (char=? . scheme#char=?)
1199    (char>? . scheme#char>?) (char<? . scheme#char<?)
1200    (char>=? . scheme#char>=?) (char<=? . scheme#char<=?)
1201    (char->integer . scheme#char->integer)
1202    (integer->char . scheme#integer->char)
1203    (string? . scheme#string?) (string=? . scheme#string=?)
1204    (string>? . scheme#string>?) (string<? . scheme#string<?)
1205    (string>=? . scheme#string>=?) (string<=? . scheme#string<=?)
1206    (make-string . scheme#make-string)
1207    (make-list . scheme#make-list)
1208    (string-length . scheme#string-length)
1209    (string-ref . scheme#string-ref)
1210    (string-set! . scheme#string-set!)
1211    (string-append . scheme#string-append)
1212    (string-copy . scheme#string-copy)
1213    (string-copy! . scheme#string-copy!)
1214    (string->list . scheme#string->list)
1215    (list->string . scheme#list->string)
1216    (substring . scheme#substring)
1217    (string-fill! . scheme#string-fill!)
1218    (vector? . scheme#vector?) (make-vector . scheme#make-vector)
1219    (vector-ref . scheme#vector-ref)
1220    (vector-set! . scheme#vector-set!)
1221    (string . scheme#string) (vector . scheme#vector)
1222    (vector-length . scheme#vector-length)
1223    (vector->list . scheme#vector->list)
1224    (list->vector . scheme#list->vector)
1225    (vector-copy . scheme#vector-copy)
1226    (vector-copy! . scheme#vector-copy!)
1227    (vector-fill! . scheme#vector-fill!)
1228    (call-with-values . scheme#call-with-values)
1229    (values . scheme#values)
1230    (procedure? . scheme#procedure?)
1231    (make-parameter . scheme#make-parameter)
1232    (map . scheme#map) (for-each . scheme#for-each)
1233    (apply . scheme#apply) (dynamic-wind . scheme#dynamic-wind)
1234    (call-with-current-continuation . scheme#call-with-current-continuation)
1235    (call/cc . scheme#call-with-current-continuation)
1236    (input-port? . scheme#input-port?)
1237    (output-port? . scheme#output-port?)
1238    (current-input-port . scheme#current-input-port)
1239    (current-output-port . scheme#current-output-port)
1240    (current-error-port . chicken.base#current-error-port)
1241    (open-input-file . scheme#open-input-file)
1242    (open-output-file . scheme#open-output-file)
1243    (close-input-port . scheme#close-input-port)
1244    (close-output-port . scheme#close-output-port)
1245    (read-char . scheme#read-char) (peek-char . scheme#peek-char)
1246    (read-string . chicken.io#read-string)
1247    (peek-u8 . scheme#peek-u8) (features . scheme#features)
1248    (read-u8 . chicken.io#read-byte) (write-u8 . chicken.io#write-byte)
1249    (write-char . scheme#write-char) (newline . scheme#newline)
1250    (eof-object? . scheme#eof-object?)
1251    (eof-object . scheme#eof-object)
1252    (flush-output-port . chicken.base#flush-output)
1253    (with-input-from-file . scheme#with-input-from-file)
1254    (with-output-to-file . scheme#with-output-to-file)
1255    (close-port . scheme#close-port)
1256    (char-ready? . scheme#char-ready?)
1257    (u8-ready? . scheme#u8-ready?)
1258    (numerator . scheme#numerator)
1259    (denominator . scheme#denominator)
1260    (scheme-report-environment . scheme#scheme-report-environment)
1261    (null-environment . scheme#null-environment)
1262    (open-input-string . scheme#open-input-string)
1263    (open-output-string . scheme#open-output-string)
1264    (open-output-bytevector . scheme#open-output-bytevector)
1265    (open-input-bytevector . scheme#open-input-bytevector)
1266    (get-output-string . scheme#get-output-string)
1267    (get-output-bytevector . scheme#get-output-bytevector)
1268    (with-exception-handler . scheme#with-exception-handler)
1269    (raise . scheme#raise) (raise-continuable . scheme#raise-continuable)
1270    (error . chicken.base#error)
1271    (file-error? . scheme#file-error?)
1272    (read-error? . scheme#read-error?)
1273    (error-object? . scheme#error-object?)
1274    (error-object-message . scheme#error-object-message)
1275    (error-object-irritants . scheme#error-object-irritants)
1276    (string->utf8 . chicken.bytevector#string->utf8)
1277    (utf8->string . chicken.bytevector#utf8->string)
1278    (write-bytevector . chicken.io#write-bytevector)
1279    (bytevector . chicken.bytevector#bytevector)
1280    (bytevector-length . chicken.bytevector#bytevector-length)
1281    (bytevector? . chicken.bytevector#bytevector?)
1282    (make-bytevector . chicken.bytevector#make-bytevector)
1283    (bytevector-append . chicken.bytevector#bytevector-append)
1284    (bytevector-copy . chicken.bytevector#bytevector-copy)
1285    (bytevector-copy! . chicken.bytevector#bytevector-copy!)
1286    (bytevector-u8-ref . chicken.bytevector#bytevector-u8-ref)
1287    (bytevector-u8-set! . chicken.bytevector#bytevector-u8-set!)
1288    (read-bytevector . chicken.io#read-bytevector)
1289    (read-bytevector! . chicken.io#read-bytevector!)
1290    (read-line . chicken.io#read-line)
1291    (write-string . scheme#write-string) )
1292  (se-subset '(define let let* letrec letrec* let-values define-values let*-values
1293                parameterize when unless do define define-syntax case cond guard
1294                define-record-type include include-ci set! syntax-rules cond-expand
1295                import export begin import-for-syntax and or lambda if quote
1296                case-lambda quasiquote syntax-error)
1297             (##sys#macro-environment)))
1298
1299;; Hack for library.scm to use macros from modules it defines itself.
1300(##sys#register-primitive-module
1301 'chicken.internal.syntax '() (##sys#macro-environment))
1302
1303(##sys#register-primitive-module
1304 'chicken.module '() ##sys#chicken.module-macro-environment)
1305
1306(##sys#register-primitive-module
1307 'chicken.type '() ##sys#chicken.type-macro-environment)
1308
1309(##sys#register-primitive-module
1310 'srfi-2 '() (se-subset '(and-let*) ##sys#chicken.base-macro-environment))
1311
1312(##sys#register-primitive-module
1313 'srfi-8 '() (se-subset '(receive) ##sys#chicken.base-macro-environment))
1314
1315(##sys#register-primitive-module
1316 'srfi-9 '() (se-subset '(define-record-type) ##sys#chicken.base-macro-environment))
1317
1318(##sys#register-core-module
1319 'srfi-10 'read-syntax '((define-reader-ctor . chicken.read-syntax#define-reader-ctor)))
1320
1321(##sys#register-core-module
1322 'srfi-12 'library
1323 '((abort . chicken.condition#abort)
1324   (condition? . chicken.condition#condition?)
1325   (condition-predicate . chicken.condition#condition-predicate)
1326   (condition-property-accessor . chicken.condition#condition-property-accessor)
1327   (current-exception-handler . chicken.condition#current-exception-handler)
1328   (make-composite-condition . chicken.condition#make-composite-condition)
1329   (make-property-condition . chicken.condition#make-property-condition)
1330   (signal . chicken.condition#signal)
1331   (with-exception-handler . chicken.condition#with-exception-handler))
1332 (se-subset '(handle-exceptions) ##sys#chicken.condition-macro-environment))
1333
1334(##sys#register-primitive-module
1335 'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken.base-macro-environment))
1336
1337(##sys#register-core-module
1338  'scheme.case-lambda
1339  'library '()
1340  ##sys#scheme.case-lambda-macro-environment)
1341
1342(##sys#register-core-module
1343  'scheme.lazy 'library
1344  '((force . scheme#force)
1345    (promise? . chicken.base#promise?)
1346    (make-promise . chicken.base#make-promise))
1347  (cons (assq 'delay ##sys#scheme-macro-environment)
1348        (se-subset '(delay-force) ##sys#chicken.base-macro-environment)))
1349
1350(##sys#register-core-module
1351  'scheme.complex 'library
1352  '((imag-part . scheme#imag-part) (real-part . scheme#real-part)
1353    (make-rectangular . scheme#make-rectangular)
1354    (make-polar . scheme#make-polar)
1355    (angle . scheme#angle) (magnitude . scheme#magnitude)))
1356
1357(##sys#register-core-module
1358  'scheme.cxr 'library
1359  '((caaar . scheme#caaar)
1360    (caadr . scheme#caadr)
1361    (cadar . scheme#cadar)
1362    (caddr . scheme#caddr)
1363    (cdaar . scheme#cdaar)
1364    (cdadr . scheme#cdadr)
1365    (cddar . scheme#cddar)
1366    (cdddr . scheme#cdddr)
1367    (caaaar . scheme#caaaar)
1368    (caaadr . scheme#caaadr)
1369    (caadar . scheme#caadar)
1370    (caaddr . scheme#caaddr)
1371    (cadaar . scheme#cadaar)
1372    (cadadr . scheme#cadadr)
1373    (caddar . scheme#caddar)
1374    (cadddr . scheme#cadddr)
1375    (cdaaar . scheme#cdaaar)
1376    (cdaadr . scheme#cdaadr)
1377    (cdadar . scheme#cdadar)
1378    (cdaddr . scheme#cdaddr)
1379    (cddaar . scheme#cddaar)
1380    (cddadr . scheme#cddadr)
1381    (cdddar . scheme#cdddar)
1382    (cddddr . scheme#cddddr)))
1383
1384(##sys#register-core-module
1385 'scheme.inexact 'library
1386 '((exp . scheme#exp) (log . scheme#log) (expt . scheme#expt)
1387   (sqrt . scheme#sqrt) (nan? . chicken.base#nan?)
1388   (sin . scheme#sin) (cos . scheme#cos) (tan . scheme#tan)
1389   (asin . scheme#asin) (acos . scheme#acos) (atan . scheme#atan)
1390   (finite? . chicken.base#finite?)
1391   (infinite? . chicken.base#infinite?)))
1392
1393(##sys#register-core-module
1394 'srfi-17 'library
1395 '((getter-with-setter . chicken.base#getter-with-setter)
1396   (setter . chicken.base#setter))
1397 (se-subset '(set!) ##sys#default-macro-environment))
1398
1399(##sys#register-primitive-module
1400 'srfi-26 '() (se-subset '(cut cute) ##sys#chicken.base-macro-environment))
1401
1402(##sys#register-core-module
1403 'srfi-28 'extras '((format . chicken.format#format)))
1404
1405(##sys#register-primitive-module
1406 'srfi-31 '() (se-subset '(rec) ##sys#chicken.base-macro-environment))
1407
1408(##sys#register-primitive-module
1409 'srfi-55 '() (se-subset '(require-extension) ##sys#chicken.base-macro-environment))
1410
1411(##sys#register-core-module
1412 'srfi-88 'library
1413 '((keyword? . chicken.keyword#keyword?)
1414   (keyword->string . chicken.keyword#keyword->string)
1415   (string->keyword . chicken.keyword#string->keyword)))
1416
1417(define (chicken.module#module-environment mname #!optional (ename mname))
1418  (let ((mod (find-module/import-library mname 'module-environment)))
1419    (if (not mod)
1420	(##sys#syntax-error
1421	 'module-environment "undefined module" mname)
1422        (let ((senv (module-saved-environments mod)))
1423          (##sys#make-structure 'environment
1424                                ename
1425                                (car senv)
1426                                (cdr senv)
1427                                #t)))))
1428
1429(define (scheme.eval#environment . specs)
1430  (let ((name (gensym "environment-module-")))
1431      (define (delmod)
1432	(and-let* ((modp (assq name ##sys#module-table)))
1433	  (set! ##sys#module-table (delq modp ##sys#module-table))))
1434      (define (delq x lst)
1435        (let loop ([lst lst])
1436          (cond ((null? lst) lst)
1437	        ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
1438	        (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
1439      (dynamic-wind
1440       void
1441       (lambda ()
1442	 ;; create module...
1443	 (scheme#eval `(module ,name ()
1444                        ,@(map (lambda (spec) `(import ,spec)) specs)))
1445	 (let* ((mod (##sys#find-module name))
1446                (env (module-saved-environments mod)))
1447            (##sys#make-structure 'environment
1448                                  (cons 'import specs)
1449                                  (car env)
1450                                  (cdr env)
1451                                  #t)))
1452        ;; ...and remove it right away
1453        delmod)))
1454
1455(##sys#register-core-module
1456 'scheme.eval 'eval
1457 '((eval . scheme#eval)
1458   (environment . scheme.eval#environment)))
1459
1460(##sys#register-core-module
1461 'scheme.load 'eval
1462 '((load . scheme#load)))
1463
1464(##sys#register-core-module
1465 'scheme.read 'library
1466 '((read . scheme#read)))
1467
1468(##sys#register-core-module
1469 'scheme.repl 'eval
1470 '((interaction-environment . scheme#interaction-environment)))
1471
1472(##sys#register-core-module
1473 'scheme.char 'library
1474  '((char-alphabetic? . scheme#char-alphabetic?)
1475    (char-ci<=? . scheme#char-ci<=?)
1476    (char-ci<? . scheme#char-ci<?)
1477    (char-ci=? . scheme#char-ci=?)
1478    (char-ci>=? . scheme#char-ci>=?)
1479    (char-ci>? . scheme#char-ci>?)
1480    (char-downcase . scheme#char-downcase)
1481    (char-foldcase . scheme#char-foldcase)
1482    (char-lower-case? . scheme#char-lower-case?)
1483    (char-numeric? . scheme#char-numeric?)
1484    (char-upcase . scheme#char-upcase)
1485    (char-upper-case? . scheme#char-upper-case?)
1486    (char-whitespace? . scheme#char-whitespace?)
1487    (digit-value . scheme.char#digit-value)
1488    (string-ci<=? . scheme#string-ci<=?)
1489    (string-ci<? . scheme#string-ci<?)
1490    (string-ci=? . scheme#string-ci=?)
1491    (string-ci>=? . scheme#string-ci>=?)
1492    (string-ci>? . scheme#string-ci>?)
1493    (string-downcase . scheme#string-downcase)
1494    (string-foldcase . scheme#string-foldcase)
1495    (string-upcase . scheme#string-upcase)))
1496
1497;; Ensure default modules are available in "eval", too
1498;; TODO: Figure out a better way to make this work for static programs.
1499;; The actual imports are handled lazily by eval when first called.
1500(include "chicken.base.import.scm")
1501(include "chicken.syntax.import.scm")