Ticket #1548: 0001-Preserve-global-environment-when-executing-module-re.patch

File 0001-Preserve-global-environment-when-executing-module-re.patch, 5.4 KB (added by felix winkelmann, 5 years ago)

with-environment

  • modules.scm 

    From 743be862e89375e46fa69b244d4dea4495fa5591 Mon Sep 17 00:00:00 2001
From: felix <felix@p.callcc.org>
Date: Sun, 25 Aug 2019 15:13:57 +0200
Subject: [PATCH] Preserve global environment when executing
 module-registration code

Factors out preservation of the current environment into internal
procedure "##sys#with-environment" and use it in generated module-
registration code to avoid polluting the global namespace.

See also: #1548
---
 modules.scm | 101 ++++++++++++++++++++++++++++++++----------------------------
 1 file changed, 54 insertions(+), 47 deletions(-)

diff --git a/modules.scm b/modules.scm
index a7fb3f18..6bbae798 100644
    a b  
    317317        (ifs (module-import-forms mod))
    318318        (sexports (module-sexports mod))
    319319        (mifs (module-meta-import-forms mod)))
    320     `(,@(if (and (pair? ifs) (pair? sexports))
    321             `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
    322             '())
    323       ,@(if (and (pair? mifs) (pair? sexports))
    324             `((import-syntax ,@(strip-syntax mifs)))
    325             '())
    326       ,@(if (or (getp mname '##core#functor) (pair? sexports))
    327             (##sys#fast-reverse (strip-syntax (module-meta-expressions mod)))
    328             '())
    329       (##sys#register-compiled-module
    330        ',(module-name mod)
    331        ',(module-library mod)
    332        (scheme#list                     ; iexports
    333         ,@(map (lambda (ie)
    334                  (if (symbol? (cdr ie))
    335                      `'(,(car ie) . ,(cdr ie))
    336                      `(scheme#list ',(car ie) '() ,(cdr ie))))
    337                (module-iexports mod)))
    338        ',(module-vexports mod)          ; vexports
    339        (scheme#list                     ; sexports
    340         ,@(map (lambda (sexport)
    341                  (let* ((name (car sexport))
    342                         (a (assq name dlist)))
    343                    (cond ((pair? a)
    344                           `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
    345                          (else
    346                           (dm "re-exported syntax" name mname)
     320    `((##sys#with-environment
     321        (lambda ()
     322          ,@(if (and (pair? ifs) (pair? sexports))
     323                `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
     324                '())
     325          ,@(if (and (pair? mifs) (pair? sexports))
     326                `((import-syntax ,@(strip-syntax mifs)))
     327                '())
     328          ,@(if (or (getp mname '##core#functor) (pair? sexports))
     329                (##sys#fast-reverse (strip-syntax (module-meta-expressions mod)))
     330                '())
     331          (##sys#register-compiled-module
     332            ',(module-name mod)
     333            ',(module-library mod)
     334            (scheme#list                        ; iexports
     335              ,@(map (lambda (ie)
     336                       (if (symbol? (cdr ie))
     337                           `'(,(car ie) . ,(cdr ie))
     338                           `(scheme#list ',(car ie) '() ,(cdr ie))))
     339                 (module-iexports mod)))
     340            ',(module-vexports mod)             ; vexports
     341            (scheme#list                        ; sexports
     342            ,@(map (lambda (sexport)
     343                     (let* ((name (car sexport))
     344                            (a (assq name dlist)))
     345                       (cond ((pair? a)
     346                              `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
     347                             (else
     348                               (dm "re-exported syntax" name mname)
    347349                          `',name))))
    348                sexports))
    349        (scheme#list                     ; sdefs
    350         ,@(if (null? sexports)
    351               '()                       ; no syntax exported - no more info needed
    352               (let loop ((sd (module-defined-syntax-list mod)))
    353                 (cond ((null? sd) '())
    354                       ((assq (caar sd) sexports) (loop (cdr sd)))
    355                       (else
    356                        (let ((name (caar sd)))
    357                         (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd)))
    358                                (loop (cdr sd)))))))))))))
     350                sexports))
     351            (scheme#list                        ; sdefs
     352              ,@(if (null? sexports)
     353                    '()                         ; no syntax exported - no more info needed
     354                    (let loop ((sd (module-defined-syntax-list mod)))
     355                      (cond ((null? sd) '())
     356                            ((assq (caar sd) sexports) (loop (cdr sd)))
     357                            (else
     358                              (let ((name (caar sd)))
     359                                (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd)))
     360                                      (loop (cdr sd)))))))))))))))
    359361
    360362;; iexports = indirect exports (syntax dependencies on value idents, explicitly included in module export list)
    361363;; vexports = value (non-syntax) exports
    … …  
    561563
    562564;;; Import-expansion
    563565
     566(define (##sys#with-environment thunk)
     567  (parameterize ((##sys#current-module #f)
     568                 (##sys#current-environment '())
     569                 (##sys#current-meta-environment
     570                   (##sys#current-meta-environment))
     571                 (##sys#macro-environment
     572                   (##sys#meta-macro-environment)))
     573    (thunk)))
     574
    564575(define (##sys#import-library-hook mname)
    565576  (and-let* ((il (chicken.load#find-dynamic-extension
    566577                  (string-append (symbol->string mname) ".import")
    567578                  #t)))
    568      (parameterize ((##sys#current-module #f)
    569                     (##sys#current-environment '())
    570                     (##sys#current-meta-environment
    571                      (##sys#current-meta-environment))
    572                       (##sys#macro-environment
    573                        (##sys#meta-macro-environment)))
    574         (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
    575           (load il)
    576           (##sys#find-module mname 'import)))))
     579     (##sys#with-environment
     580       (lambda ()
     581         (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
     582           (load il)
     583           (##sys#find-module mname 'import))))))
    577584
    578585(define (find-module/import-library lib loc)
    579586  (let ((mname (##sys#resolve-module-name lib loc)))