Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
peg	[ DIR ]	drwxr-xr-x
and-let-star.scm	2.53 KB	-rw-r--r--
arrays.scm	2.63 KB	-rw-r--r--
atomic.scm	1.55 KB	-rw-r--r--
binary-ports.scm	2.71 KB	-rw-r--r--
boot-9.scm	166.42 KB	-rw-r--r--
buffered-input.scm	4.82 KB	-rw-r--r--
calling.scm	10.54 KB	-rw-r--r--
command-line.scm	18.6 KB	-rw-r--r--
common-list.scm	8.95 KB	-rw-r--r--
control.scm	4.08 KB	-rw-r--r--
copy-tree.scm	3.05 KB	-rw-r--r--
curried-definitions.scm	1.79 KB	-rw-r--r--
deprecated.scm	1.54 KB	-rw-r--r--
documentation.scm	7.41 KB	-rw-r--r--
eval-string.scm	2.99 KB	-rw-r--r--
eval.scm	25.08 KB	-rw-r--r--
exceptions.scm	14.38 KB	-rw-r--r--
expect.scm	5.5 KB	-rw-r--r--
fdes-finalizers.scm	1.06 KB	-rw-r--r--
format.scm	65.47 KB	-rw-r--r--
ftw.scm	25.06 KB	-rw-r--r--
futures.scm	10.49 KB	-rw-r--r--
gap-buffer.scm	9.59 KB	-rw-r--r--
getopt-long.scm	16.49 KB	-rw-r--r--
hash-table.scm	1.77 KB	-rw-r--r--
hcons.scm	2.55 KB	-rw-r--r--
history.scm	2.29 KB	-rw-r--r--
i18n.scm	20.51 KB	-rw-r--r--
iconv.scm	3.19 KB	-rw-r--r--
lineio.scm	3.85 KB	-rw-r--r--
list.scm	1.29 KB	-rw-r--r--
local-eval.scm	9.84 KB	-rw-r--r--
ls.scm	3.2 KB	-rw-r--r--
match.scm	2.18 KB	-rw-r--r--
match.upstream.scm	35.93 KB	-rw-r--r--
networking.scm	3.33 KB	-rw-r--r--
null.scm	1.21 KB	-rw-r--r--
occam-channel.scm	7.26 KB	-rw-r--r--
optargs.scm	15.75 KB	-rw-r--r--
peg.scm	1.64 KB	-rw-r--r--
poe.scm	3.3 KB	-rw-r--r--
poll.scm	5.79 KB	-rw-r--r--
popen.scm	9.27 KB	-rw-r--r--
ports.scm	19.08 KB	-rw-r--r--
posix.scm	2.73 KB	-rw-r--r--
pretty-print.scm	16.88 KB	-rw-r--r--
psyntax-pp.scm	182.88 KB	-rw-r--r--
psyntax.scm	148.97 KB	-rw-r--r--
q.scm	4.2 KB	-rw-r--r--
quasisyntax.scm	5.22 KB	-rw-r--r--
r5rs.scm	1.56 KB	-rw-r--r--
r6rs-libraries.scm	10.38 KB	-rw-r--r--
r7rs-libraries.scm	4.28 KB	-rw-r--r--
rdelim.scm	7.72 KB	-rw-r--r--
read.scm	32.52 KB	-rw-r--r--
readline.scm	9.56 KB	-rw-r--r--
receive.scm	1.06 KB	-rw-r--r--
regex.scm	8.87 KB	-rw-r--r--
runq.scm	8.18 KB	-rw-r--r--
rw.scm	1.02 KB	-rw-r--r--
safe-r5rs.scm	7.5 KB	-rw-r--r--
safe.scm	1.25 KB	-rw-r--r--
sandbox.scm	34.24 KB	-rw-r--r--
save-stack.scm	2.15 KB	-rw-r--r--
scm-style-repl.scm	11.62 KB	-rw-r--r--
serialize.scm	3.78 KB	-rw-r--r--
session.scm	17.72 KB	-rw-r--r--
slib.scm	1.55 KB	-rw-r--r--
stack-catch.scm	1.94 KB	-rw-r--r--
streams.scm	5.86 KB	-rw-r--r--
string-fun.scm	9.68 KB	-rw-r--r--
suspendable-ports.scm	29.86 KB	-rw-r--r--
textual-ports.scm	2.29 KB	-rw-r--r--
threads.scm	12.54 KB	-rw-r--r--
time.scm	2.07 KB	-rw-r--r--
top-repl.scm	2.63 KB	-rw-r--r--
unicode.scm	1005 B	-rw-r--r--
vlist.scm	21.56 KB	-rw-r--r--
weak-vector.scm	1.2 KB	-rw-r--r--

Code Editor : r6rs-libraries.scm

;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms

;;      Copyright (C) 2010, 2019 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;; This file is included from boot-9.scm and assumes the existence of (and 
;; expands into) procedures and syntactic forms defined therein.

(define (resolve-r6rs-interface import-spec)
  (define (make-custom-interface mod)
    (let ((iface (make-module)))
      (set-module-kind! iface 'custom-interface)
      (set-module-name! iface (module-name mod))
      iface))
  (define (module-for-each/nonlocal f mod)
    (define (module-and-uses mod)
      (let lp ((in (list mod)) (out '()))
        (cond
         ((null? in) (reverse out))
         ((memq (car in) out) (lp (cdr in) out))
         (else (lp (append (module-uses (car in)) (cdr in))
                   (cons (car in) out))))))
    (for-each (lambda (mod)
                (module-for-each f mod))
              (module-and-uses mod)))
  (define (sym? x) (symbol? (syntax->datum x)))

(syntax-case import-spec (library only except prefix rename srfi)
    ;; (srfi :n ...) -> (srfi srfi-n ...)
    ;; (srfi n ...) -> (srfi srfi-n ...)
    ((library (srfi n rest ... (version ...)))
     (and (and-map sym? #'(srfi rest ...))
          (or (and
               (symbol? (syntax->datum #'n))
               (let ((str (symbol->string (syntax->datum #'n))))
                 (and (string-prefix? ":" str)
                      (and=> (string->number (substring str 1))
                             exact-integer?))))
              (exact-integer? (syntax->datum #'n))))
     (let ((srfi-n (string->symbol
                    (string-append
                     "srfi-"
                     (let ((n (syntax->datum #'n)))
                       (if (symbol? n)
                           (substring (symbol->string n) 1)
                           (number->string n)))))))
       (resolve-r6rs-interface
        (syntax-case #'(rest ...) ()
          (()
           #`(library (srfi #,srfi-n (version ...))))
          ((name rest ...)
           ;; SRFI 97 says that the first identifier after the `n'
           ;; is used for the libraries name, so it must be ignored.
           #`(library (srfi #,srfi-n rest ... (version ...))))))))
    
    ((library (name name* ... (version ...)))
     (and-map sym? #'(name name* ...))
     (resolve-interface (syntax->datum #'(name name* ...))
                        #:version (syntax->datum #'(version ...))))

((library (name name* ...))
     (and-map sym? #'(name name* ...))
     (resolve-r6rs-interface #'(library (name name* ... ()))))
    
    ((only import-set identifier ...)
     (and-map sym? #'(identifier ...))
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod)))
       (for-each (lambda (sym)
                   (module-add! iface sym
                                (or (module-variable mod sym)
                                    (error "no binding `~A' in module ~A"
                                           sym mod)))
                   (when (hashq-ref (module-replacements mod) sym)
                     (hashq-set! (module-replacements iface) sym #t)))
                 (syntax->datum #'(identifier ...)))
       iface))
    
    ((except import-set identifier ...)
     (and-map sym? #'(identifier ...))
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod)))
       (module-for-each/nonlocal (lambda (sym var)
                                   (module-add! iface sym var))
                                 mod)
       (for-each (lambda (sym)
                   (unless (module-local-variable iface sym)
                     (error "no binding `~A' in module ~A" sym mod))
                   (module-remove! iface sym))
                 (syntax->datum #'(identifier ...)))
       iface))

((prefix import-set identifier)
     (sym? #'identifier)
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod))
            (pre (syntax->datum #'identifier)))
       (module-for-each/nonlocal
        (lambda (sym var)
          (let ((sym* (symbol-append pre sym)))
            (module-add! iface sym* var)
            (when (hashq-ref (module-replacements mod) sym)
              (hashq-set! (module-replacements iface) sym* #t))))
        mod)
       iface))

((rename import-set (from to) ...)
     (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (replacements (module-replacements mod))
            (iface (make-custom-interface mod)))
       (module-for-each/nonlocal
        (lambda (sym var) (module-add! iface sym var))
        mod)
       (let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
         (cond
          ((null? in)
           (for-each
            (lambda (v)
              (let ((to (vector-ref v 0))
                    (replace? (vector-ref v 1))
                    (var (vector-ref v 2)))
                (when (module-local-variable iface to)
                  (error "duplicate binding for `~A' in module ~A" to mod))
                (module-add! iface to var)
                (when replace?
                  (hashq-set! replacements to #t))))
            out)
           iface)
          (else
           (let* ((from (caar in))
                  (to (cdar in))
                  (var (module-variable mod from))
                  (replace? (hashq-ref replacements from)))
             (unless var (error "no binding `~A' in module ~A" from mod))
             (module-remove! iface from)
             (hashq-remove! replacements from)
             (lp (cdr in) (cons (vector to replace? var) out))))))))
    
    ((name name* ... (version ...))
     (and-map sym? #'(name name* ...))
     (resolve-r6rs-interface #'(library (name name* ... (version ...)))))

((name name* ...) 
     (and-map sym? #'(name name* ...))
     (resolve-r6rs-interface #'(library (name name* ... ()))))))

(define-syntax library
  (lambda (stx)
    (define (compute-exports ifaces specs)
      (define (re-export? sym)
        (or-map (lambda (iface) (module-variable iface sym)) ifaces))
      (define (replace? sym)
        (module-variable the-scm-module sym))
      
      (let lp ((specs specs) (e '()) (r '()) (x '()))
        (syntax-case specs (rename)
          (() (values e r x))
          (((rename (from to) ...) . rest)
           (and (and-map identifier? #'(from ...))
                (and-map identifier? #'(to ...)))
           (let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x))
             (syntax-case in ()
               (() (lp #'rest e r x))
               (((from . to) . in)
                (cond
                 ((re-export? (syntax->datum #'from))
                  (lp2 #'in e (cons #'(from . to) r) x))
                 ((replace? (syntax->datum #'from))
                  (lp2 #'in e r (cons #'(from . to) x)))
                 (else
                  (lp2 #'in (cons #'(from . to) e) r x)))))))
          ((id . rest)
           (identifier? #'id)
           (let ((sym (syntax->datum #'id)))
             (cond
              ((re-export? sym)
               (lp #'rest e (cons #'id r) x))
              ((replace? sym)
               (lp #'rest e r (cons #'id x)))
              (else
               (lp #'rest (cons #'id e) r x))))))))

(syntax-case stx (export import)
      ((_ (name name* ...)
          (export espec ...)
          (import ispec ...)
          body ...)
       (and-map identifier? #'(name name* ...))
       ;; Add () as the version.
       #'(library (name name* ... ())
           (export espec ...)
           (import ispec ...)
           body ...))

((_ (name name* ... (version ...))
          (export espec ...)
          (import ispec ...)
	  body ...)
       (and-map identifier? #'(name name* ...))
       (call-with-values
           (lambda ()
             (compute-exports 
              (map (lambda (im)
                     (syntax-case im (for)
                       ((for import-set import-level ...)
                        (resolve-r6rs-interface #'import-set))
                       (import-set (resolve-r6rs-interface #'import-set))))
                   #'(ispec ...))
              #'(espec ...)))
         (lambda (exports re-exports replacements)
           (with-syntax (((e ...) exports)
                         ((r ...) re-exports)
                         ((x ...) replacements))
             ;; It would be nice to push the module that was current before the
             ;; definition, and pop it after the library definition, but I
             ;; actually can't see a way to do that. Helper procedures perhaps,
             ;; around a fluid that is rebound in save-module-excursion? Patches
             ;; welcome!
             #'(begin
                 (define-module (name name* ...)
                   #:pure
                   #:version (version ...))
                 (import ispec)
                 ...
                 (export e ...)
                 (re-export r ...)
                 (export! x ...)
                 (@@ @@ (name name* ...) body)
                 ...))))))))
    
(define-syntax import
  (lambda (stx)
    (define (strip-for import-set)
      (syntax-case import-set (for)
        ((for import-set import-level ...)
         #'import-set)
        (import-set
         #'import-set)))
    (syntax-case stx ()
      ((_ import-set ...)
       (with-syntax (((library-reference ...) (map strip-for #'(import-set ...))))
         #'(eval-when (expand load eval)
             (let ((iface (resolve-r6rs-interface 'library-reference)))
               (call-with-deferred-observers
                 (lambda ()
                   (module-use-interfaces! (current-module) (list iface)))))
             ...
             (if #f #f)))))))

${this.title}

Code Editor : r6rs-libraries.scm