;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
(define (call-with-prompt tag thunk handler)
(@prompt tag (thunk) handler))
(define (abort-to-prompt tag . args)
- (@abort tag args))
+ (abort-to-prompt* tag args))
;; Define catch and with-throw-handler, using some common helper routines and a
(define *null-device* "/dev/null")
+;; NOTE: Later in this file, this is redefined to support keywords
(define (open-input-file str)
"Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file
cannot be opened, an error is signalled."
(open-file str OPEN_READ))
+;; NOTE: Later in this file, this is redefined to support keywords
(define (open-output-file str)
"Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
(apply f (car l1) (map car rest))
(lp (cdr l1) (map cdr rest))))))))
+;; Temporary definition used in the include-from-path expansion;
+;; replaced later.
+
+(define (absolute-file-name? file-name)
+ #t)
+
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
datum
(syntax->datum clause)
(syntax->datum whole-expr)))
- (if (memv datum seen)
- (warn-datum 'duplicate-case-datum))
- (if (or (pair? datum)
- (array? datum)
- (generalized-vector? datum))
- (warn-datum 'bad-case-datum))
+ (when (memv datum seen)
+ (warn-datum 'duplicate-case-datum))
+ (when (or (pair? datum) (array? datum))
+ (warn-datum 'bad-case-datum))
(cons datum seen))
seen
(map syntax->datum #'(datums ...)))))
#'(define-macro macro doc (lambda args body1 body ...)))
((_ (macro . args) body ...)
#'(define-macro macro #f (lambda args body ...)))
+ ((_ macro transformer)
+ #'(define-macro macro #f transformer))
((_ macro doc transformer)
(or (string? (syntax->datum #'doc))
(not (syntax->datum #'doc)))
(lambda _
value))
-(define (and=> value procedure) (and value (procedure value)))
+(define (and=> value procedure)
+ "When VALUE is #f, return #f. Otherwise, return (PROC VALUE)."
+ (and value (procedure value)))
+
(define call/cc call-with-current-continuation)
-(define-syntax-rule (false-if-exception expr)
- (catch #t
- (lambda () expr)
- (lambda (k . args) #f)))
+(define-syntax false-if-exception
+ (syntax-rules ()
+ ((false-if-exception expr)
+ (catch #t
+ (lambda () expr)
+ (lambda args #f)))
+ ((false-if-exception expr #:warning template arg ...)
+ (catch #t
+ (lambda () expr)
+ (lambda (key . args)
+ (for-each (lambda (s)
+ (if (not (string-null? s))
+ (format (current-warning-port) ";;; ~a\n" s)))
+ (string-split
+ (call-with-output-string
+ (lambda (port)
+ (format port template arg ...)
+ (print-exception port #f key args)))
+ #\newline))
+ #f)))))
\f
(set-struct-vtable-name! <parameter> '<parameter>)
(define* (make-parameter init #:optional (conv (lambda (x) x)))
+ "Make a new parameter.
+
+A parameter is a dynamically bound value, accessed through a procedure.
+To access the current value, apply the procedure with no arguments:
+
+ (define p (make-parameter 10))
+ (p) => 10
+
+To provide a new value for the parameter in a dynamic extent, use
+`parameterize':
+
+ (parameterize ((p 20))
+ (p)) => 20
+ (p) => 10
+
+The value outside of the dynamic extent of the body is unaffected. To
+update the current value, apply it to one argument:
+
+ (p 20) => 10
+ (p) => 20
+
+As you can see, the call that updates a parameter returns its previous
+value.
+
+All values for the parameter are first run through the CONV procedure,
+including INIT, the initial value. The default CONV procedure is the
+identity procedure. CONV is commonly used to ensure some set of
+invariants on the values that a parameter may have."
(let ((fluid (make-fluid (conv init))))
(make-struct <parameter> 0
(case-lambda
...)
body body* ...)))))))
+(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
+ "Make a parameter that wraps a fluid.
+
+The value of the parameter will be the same as the value of the fluid.
+If the parameter is rebound in some dynamic extent, perhaps via
+`parameterize', the new value will be run through the optional CONV
+procedure, as with any parameter. Note that unlike `make-parameter',
+CONV is not applied to the initial value."
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv))
+
\f
;;; Once parameters have booted, define the default prompt tag as being
;;; Current ports as parameters.
;;;
-(let ((fluid->parameter
- (lambda (fluid conv)
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv))))
+(let ()
(define-syntax-rule (port-parameterize! binding fluid predicate msg)
(begin
(set! binding (fluid->parameter (module-ref (current-module) 'fluid)
x
(error "expected an output port" x)))))
+
+\f
+
+;;; {Languages}
+;;;
+
+;; The language can be a symbolic name or a <language> object from
+;; (system base language).
+;;
+(define current-language (make-parameter 'scheme))
+
+
\f
;;; {High-Level Port Routines}
;;;
-(define (call-with-input-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The file must already exist. These procedures
-call PROC with one argument: the port obtained by opening the named file
-for input or output. If the file cannot be opened, an error is
+(define* (open-input-file
+ file #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file file (if binary "rb" "r")
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
+
+(define* (open-output-file file #:key (binary #f) (encoding #f))
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file file (if binary "wb" "w")
+ #:encoding encoding))
+
+(define* (call-with-input-file
+ file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned. If
-the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will never
-again be used for a read or write operation."
- (let ((p (open-input-file str)))
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-input-file file
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-input-port p)
(apply values vals)))))
-(define (call-with-output-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The behaviour is unspecified if the file
+(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The behaviour is unspecified if the file
already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
- (let ((p (open-output-file str)))
+ (let ((p (open-output-file file #:binary binary #:encoding encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(parameterize ((current-error-port port))
(thunk)))
-(define (with-input-from-file file thunk)
+(define* (with-input-from-file
+ file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The file must already exist. The file is opened for
input, an input port connected to it is made
-the default value returned by `current-input-port',
+the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-file file
- (lambda (p) (with-input-from-port p thunk))))
+ (lambda (p) (with-input-from-port p thunk))
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
-(define (with-output-to-file file thunk)
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
+string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
+the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
- (lambda (p) (with-output-to-port p thunk))))
+ (lambda (p) (with-output-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
-(define (with-error-to-file file thunk)
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
+string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
+the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
- (lambda (p) (with-error-to-port p thunk))))
+ (lambda (p) (with-error-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
(define (call-with-input-string string proc)
"Calls the one-argument procedure @var{proc} with a newly created
;;; {Load Paths}
;;;
+(let-syntax ((compile-time-case
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ exp clauses ...)
+ (let ((val (primitive-eval (syntax->datum #'exp))))
+ (let next-clause ((clauses #'(clauses ...)))
+ (syntax-case clauses (else)
+ (()
+ (syntax-violation 'compile-time-case
+ "all clauses failed to match" stx))
+ (((else form ...))
+ #'(begin form ...))
+ ((((k ...) form ...) clauses ...)
+ (if (memv val (syntax->datum #'(k ...)))
+ #'(begin form ...)
+ (next-clause #'(clauses ...))))))))))))
+ ;; emacs: (put 'compile-time-case 'scheme-indent-function 1)
+ (compile-time-case (system-file-name-convention)
+ ((posix)
+ (define (file-name-separator? c)
+ (char=? c #\/))
+
+ (define file-name-separator-string "/")
+
+ (define (absolute-file-name? file-name)
+ (string-prefix? "/" file-name)))
+
+ ((windows)
+ (define (file-name-separator? c)
+ (or (char=? c #\/)
+ (char=? c #\\)))
+
+ (define file-name-separator-string "\\")
+
+ (define (absolute-file-name? file-name)
+ (define (file-name-separator-at-index? idx)
+ (and (> (string-length file-name) idx)
+ (file-name-separator? (string-ref file-name idx))))
+ (define (unc-file-name?)
+ ;; Universal Naming Convention (UNC) file-names start with \\,
+ ;; and are always absolute. See:
+ ;; http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#fully_qualified_vs._relative_paths
+ (and (file-name-separator-at-index? 0)
+ (file-name-separator-at-index? 1)))
+ (define (has-drive-specifier?)
+ (and (>= (string-length file-name) 2)
+ (let ((drive (string-ref file-name 0)))
+ (or (char<=? #\a drive #\z)
+ (char<=? #\A drive #\Z)))
+ (eqv? (string-ref file-name 1) #\:)))
+ (or (unc-file-name?)
+ (if (has-drive-specifier?)
+ (file-name-separator-at-index? 2)
+ (file-name-separator-at-index? 0)))))))
+
(define (in-vicinity vicinity file)
(let ((tail (let ((len (string-length vicinity)))
(if (zero? len)
#f
(string-ref vicinity (- len 1))))))
(string-append vicinity
- (if (or (not tail)
- (eq? tail #\/))
+ (if (or (not tail) (file-name-separator? tail))
""
- "/")
+ file-name-separator-string)
file)))
\f
(define (load-user-init)
(let* ((home (or (getenv "HOME")
(false-if-exception (passwd:dir (getpwuid (getuid))))
- "/")) ;; fallback for cygwin etc.
+ file-name-separator-string)) ;; fallback for cygwin etc.
(init-file (in-vicinity home ".guile")))
(if (file-exists? init-file)
(primitive-load init-file))))
;;; Every module object is of the type 'module-type', which is a record
;;; consisting of the following members:
;;;
-;;; - eval-closure: the function that defines for its module the strategy that
-;;; shall be followed when looking up symbols in the module.
-;;;
-;;; An eval-closure is a function taking two arguments: the symbol to be
-;;; looked up and a boolean value telling whether a binding for the symbol
-;;; should be created if it does not exist yet. If the symbol lookup
-;;; succeeded (either because an existing binding was found or because a new
-;;; binding was created), a variable object representing the binding is
-;;; returned. Otherwise, the value #f is returned. Note that the eval
-;;; closure does not take the module to be searched as an argument: During
-;;; construction of the eval-closure, the eval-closure has to store the
-;;; module it belongs to in its environment. This means, that any
-;;; eval-closure can belong to only one module.
-;;;
-;;; The eval-closure of a module can be defined arbitrarily. However, three
-;;; special cases of eval-closures are to be distinguished: During startup
-;;; the module system is not yet activated. In this phase, no modules are
-;;; defined and all bindings are automatically stored by the system in the
-;;; pre-modules-obarray. Since no eval-closures exist at this time, the
-;;; functions which require an eval-closure as their argument need to be
-;;; passed the value #f.
-;;;
-;;; The other two special cases of eval-closures are the
-;;; standard-eval-closure and the standard-interface-eval-closure. Both
-;;; behave equally for the case that no new binding is to be created. The
-;;; difference between the two comes in, when the boolean argument to the
-;;; eval-closure indicates that a new binding shall be created if it is not
-;;; found.
-;;;
-;;; Given that no new binding shall be created, both standard eval-closures
-;;; define the following standard strategy of searching bindings in the
-;;; module: First, the module's obarray is searched for the symbol. Second,
-;;; if no binding for the symbol was found in the module's obarray, the
-;;; module's binder procedure is exececuted. If this procedure did not
-;;; return a binding for the symbol, the modules referenced in the module's
-;;; uses list are recursively searched for a binding of the symbol. If the
-;;; binding can not be found in these modules also, the symbol lookup has
-;;; failed.
-;;;
-;;; If a new binding shall be created, the standard-interface-eval-closure
-;;; immediately returns indicating failure. That is, it does not even try
-;;; to look up the symbol. In contrast, the standard-eval-closure would
-;;; first search the obarray, and if no binding was found there, would
-;;; create a new binding in the obarray, therefore not calling the binder
-;;; procedure or searching the modules in the uses list.
-;;;
-;;; The explanation of the following members obarray, binder and uses
-;;; assumes that the symbol lookup follows the strategy that is defined in
-;;; the standard-eval-closure and the standard-interface-eval-closure.
+;;; - eval-closure: A deprecated field, to be removed in Guile 2.2.
;;;
;;; - obarray: a hash table that maps symbols to variable objects. In this
;;; hash table, the definitions are found that are local to the module (that
;; NOTE: If you change the set of fields or their order, you also need to
;; change the constants in libguile/modules.h.
;;
- ;; NOTE: The getter `module-eval-closure' is used in libguile/modules.c.
;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
;; NOTE: The getter `module-name' is defined later, due to boot reasons.
;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
(error
"Lazy-binder expected to be a procedure or #f." binder))
- (let ((module (module-constructor (make-hash-table size)
- uses binder #f macroexpand
- #f #f #f
- (make-hash-table)
- '()
- (make-weak-key-hash-table 31) #f
- (make-hash-table 7) #f #f #f)))
-
- ;; We can't pass this as an argument to module-constructor,
- ;; because we need it to close over a pointer to the module
- ;; itself.
- (set-module-eval-closure! module (standard-eval-closure module))
-
- module))
+ (module-constructor (make-hash-table size)
+ uses binder #f macroexpand
+ #f #f #f
+ (make-hash-table)
+ '()
+ (make-weak-key-hash-table 31) #f
+ (make-hash-table 7) #f #f #f))
\f
;;; better thought of as a root.
;;;
-(define (set-system-module! m s)
- (set-procedure-property! (module-eval-closure m) 'system-module s))
-
;; The root module uses the pre-modules-obarray as its obarray. This
;; special obarray accumulates all bindings that have been established
;; before the module system is fully booted.
(let ((m (make-module 0)))
(set-module-obarray! m (%get-pre-modules-obarray))
(set-module-name! m '(guile))
- (set-system-module! m #t)
m))
;; The root interface is a module that uses the same obarray as the
(define the-scm-module
(let ((m (make-module 0)))
(set-module-obarray! m (%get-pre-modules-obarray))
- (set-module-eval-closure! m (standard-interface-eval-closure m))
(set-module-name! m '(guile))
(set-module-kind! m 'interface)
- (set-system-module! m #t)
;; In Guile 1.8 and earlier M was its own public interface.
(set-module-public-interface! m m)
version)
(let* ((module (resolve-module name #t version #:ensure #f))
(public-i (and module (module-public-interface module))))
- (and (or (not module) (not public-i))
- (error "no code for module" name))
+ (unless public-i
+ (error "no code for module" name))
(if (and (not select) (null? hide) (eq? renamer identity))
public-i
(let ((selection (or select (module-map (lambda (sym var) sym)
(define (make-autoload-interface module name bindings)
(let ((b (lambda (a sym definep)
- (and (memq sym bindings)
- (let ((i (module-public-interface (resolve-module name))))
- (if (not i)
- (error "missing interface for module" name))
- (let ((autoload (memq a (module-uses module))))
- ;; Replace autoload-interface with actual interface if
- ;; that has not happened yet.
- (if (pair? autoload)
- (set-car! autoload i)))
- (module-local-variable i sym))))))
+ (false-if-exception
+ (and (memq sym bindings)
+ (let ((i (module-public-interface (resolve-module name))))
+ (if (not i)
+ (error "missing interface for module" name))
+ (let ((autoload (memq a (module-uses module))))
+ ;; Replace autoload-interface with actual interface if
+ ;; that has not happened yet.
+ (if (pair? autoload)
+ (set-car! autoload i)))
+ (module-local-variable i sym)))
+ #:warning "Failed to autoload ~a in ~a:\n" sym name))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
(make-hash-table 0) '() (make-weak-value-hash-table 31) #f
(make-hash-table 0) #f #f #f)))
(define autoloads-in-progress '())
-;; This function is called from "modules.c". If you change it, be
-;; sure to update "modules.c" as well.
-
+;; This function is called from scm_load_scheme_module in
+;; "deprecated.c". Please do not change its interface.
+;;
(define* (try-module-autoload module-name #:optional version)
+ "Try to load a module of the given name. If it is not found, return
+#f. Otherwise return #t. May raise an exception if a file is found,
+but it fails to load."
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
- (string-append (symbol->string elt) "/"))
+ (string-append (symbol->string elt)
+ file-name-separator-string))
dir-hint-module-name))))
(resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
(with-fluids ((current-reader #f))
(save-module-excursion
(lambda ()
+ (define (call/ec proc)
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (proc (lambda () (abort-to-prompt tag))))
+ (lambda (k) (values)))))
;; The initial environment when loading a module is a fresh
;; user module.
(set-current-module (make-fresh-user-module))
;; out how to locate the compiled file, do auto-compilation,
;; etc. Punt for now, and don't use versions when locating
;; the file.
- (primitive-load-path (in-vicinity dir-hint name) #f)
- (set! didit #t)))))
+ (call/ec
+ (lambda (abort)
+ (primitive-load-path (in-vicinity dir-hint name)
+ abort)
+ (set! didit #t)))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
(lambda (option)
(apply (lambda (name value documentation)
(display name)
- (if (< (string-length (symbol->string name)) 8)
- (display #\tab))
+ (let ((len (string-length (symbol->string name))))
+ (when (< len 16)
+ (display #\tab)
+ (when (< len 8)
+ (display #\tab))))
(display #\tab)
(display value)
(display #\tab)
(define-syntax define-public
(syntax-rules ()
((_ (name . args) . body)
- (define-public name (lambda args . body)))
+ (begin
+ (define name (lambda args . body))
+ (export name)))
((_ name val)
(begin
(define name val)
;;; {`load'.}
;;;
-;;; Load is tricky when combined with relative paths, compilation, and
-;;; the file system. If a path is relative, what is it relative to? The
-;;; path of the source file at the time it was compiled? The path of
-;;; the compiled file? What if both or either were installed? And how
-;;; do you get that information? Tricky, I say.
+;;; Load is tricky when combined with relative file names, compilation,
+;;; and the file system. If a file name is relative, what is it
+;;; relative to? The name of the source file at the time it was
+;;; compiled? The name of the compiled file? What if both or either
+;;; were installed? And how do you get that information? Tricky, I
+;;; say.
;;;
;;; To get around all of this, we're going to do something nasty, and
-;;; turn `load' into a macro. That way it can know the path of the
+;;; turn `load' into a macro. That way it can know the name of the
;;; source file with respect to which it was invoked, so it can resolve
-;;; relative paths with respect to the original source path.
+;;; relative file names with respect to the original source file.
;;;
;;; There is an exception, and that is that if the source file was in
;;; the load path when it was compiled, instead of looking up against
(define %auto-compilation-options
;; Default `compile-file' option when auto-compiling.
- '(#:warnings (unbound-variable arity-mismatch format)))
-
-(define* (load-in-vicinity dir path #:optional reader)
+ '(#:warnings (unbound-variable arity-mismatch format
+ duplicate-case-datum bad-case-datum)))
+
+(define* (load-in-vicinity dir file-name #:optional reader)
+ "Load source file FILE-NAME in vicinity of directory DIR. Use a
+pre-compiled version of FILE-NAME when available, and auto-compile one
+when none is available, reading FILE-NAME with READER."
+
+ ;; The auto-compilation code will residualize a .go file in the cache
+ ;; dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This
+ ;; function determines the PATH to use as a key into the compilation
+ ;; cache.
(define (canonical->suffix canon)
(cond
- ((string-prefix? "/" canon) canon)
- ((and (> (string-length canon) 2)
- (eqv? (string-ref canon 1) #\:))
- ;; Paths like C:... transform to /C...
- (string-append "/" (substring canon 0 1) (substring canon 2)))
+ ((and (not (string-null? canon))
+ (file-name-separator? (string-ref canon 0)))
+ canon)
+ ((and (eq? (system-file-name-convention) 'windows)
+ (absolute-file-name? canon))
+ ;; An absolute file name that doesn't start with a separator
+ ;; starts with a drive component. Transform the drive component
+ ;; to a file name element: c:\foo -> \c\foo.
+ (string-append file-name-separator-string
+ (substring canon 0 1)
+ (substring canon 2)))
(else canon)))
- ;; Returns the .go file corresponding to `name'. Does not search load
- ;; paths, only the fallback path. If the .go file is missing or out of
- ;; date, and auto-compilation is enabled, will try auto-compilation, just
- ;; as primitive-load-path does internally. primitive-load is
- ;; unaffected. Returns #f if auto-compilation failed or was disabled.
- ;;
- ;; NB: Unless we need to compile the file, this function should not cause
- ;; (system base compile) to be loaded up. For that reason compiled-file-name
- ;; partially duplicates functionality from (system base compile).
- ;;
- (define (compiled-file-name canon-path)
- ;; FIXME: would probably be better just to append SHA1(canon-path)
- ;; to the %compile-fallback-path, to avoid deep directory stats.
+ (define compiled-extension
+ ;; File name extension of compiled files.
+ (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions))))
+
+ (define (more-recent? stat1 stat2)
+ ;; Return #t when STAT1 has an mtime greater than that of STAT2.
+ (or (> (stat:mtime stat1) (stat:mtime stat2))
+ (and (= (stat:mtime stat1) (stat:mtime stat2))
+ (>= (stat:mtimensec stat1)
+ (stat:mtimensec stat2)))))
+
+ (define (fallback-file-name canon-file-name)
+ ;; Return the in-cache compiled file name for source file
+ ;; CANON-FILE-NAME.
+
+ ;; FIXME: would probably be better just to append
+ ;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid
+ ;; deep directory stats.
(and %compile-fallback-path
- (string-append
- %compile-fallback-path
- (canonical->suffix canon-path)
- (cond ((or (null? %load-compiled-extensions)
- (string-null? (car %load-compiled-extensions)))
- (warn "invalid %load-compiled-extensions"
- %load-compiled-extensions)
- ".go")
- (else (car %load-compiled-extensions))))))
-
- (define (fresh-compiled-file-name name go-path)
- (catch #t
- (lambda ()
- (let* ((scmstat (stat name))
- (gostat (and (not %fresh-auto-compile)
- (stat go-path #f))))
- (if (and gostat
- (or (> (stat:mtime gostat) (stat:mtime scmstat))
- (and (= (stat:mtime gostat) (stat:mtime scmstat))
- (>= (stat:mtimensec gostat)
- (stat:mtimensec scmstat)))))
- go-path
- (begin
- (if gostat
- (format (current-warning-port)
- ";;; note: source file ~a\n;;; newer than compiled ~a\n"
- name go-path))
- (cond
- (%load-should-auto-compile
- (%warn-auto-compilation-enabled)
- (format (current-warning-port) ";;; compiling ~a\n" name)
- (let ((cfn
- ((module-ref
- (resolve-interface '(system base compile))
- 'compile-file)
- name
- #:opts %auto-compilation-options
- #:env (current-module))))
- (format (current-warning-port) ";;; compiled ~a\n" cfn)
- cfn))
- (else #f))))))
- (lambda (k . args)
- (format (current-warning-port)
- ";;; WARNING: compilation of ~a failed:\n" name)
- (for-each (lambda (s)
- (if (not (string-null? s))
- (format (current-warning-port) ";;; ~a\n" s)))
- (string-split
- (call-with-output-string
- (lambda (port) (print-exception port #f k args)))
- #\newline))
- #f)))
-
- (define (absolute-path? path)
- (string-prefix? "/" path))
-
- (define (load-absolute abs-path)
- (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
- (and canon
- (let ((go-path (compiled-file-name canon)))
- (and go-path
- (fresh-compiled-file-name abs-path go-path)))))))
- (if cfn
+ (string-append %compile-fallback-path
+ (canonical->suffix canon-file-name)
+ compiled-extension)))
+
+ (define (compile file)
+ ;; Compile source FILE, lazily loading the compiler.
+ ((module-ref (resolve-interface '(system base compile))
+ 'compile-file)
+ file
+ #:opts %auto-compilation-options
+ #:env (current-module)))
+
+ ;; Returns the .go file corresponding to `name'. Does not search load
+ ;; paths, only the fallback path. If the .go file is missing or out
+ ;; of date, and auto-compilation is enabled, will try
+ ;; auto-compilation, just as primitive-load-path does internally.
+ ;; primitive-load is unaffected. Returns #f if auto-compilation
+ ;; failed or was disabled.
+ ;;
+ ;; NB: Unless we need to compile the file, this function should not
+ ;; cause (system base compile) to be loaded up. For that reason
+ ;; compiled-file-name partially duplicates functionality from (system
+ ;; base compile).
+
+ (define (fresh-compiled-file-name name scmstat go-file-name)
+ ;; Return GO-FILE-NAME after making sure that it contains a freshly
+ ;; compiled version of source file NAME with stat SCMSTAT; return #f
+ ;; on failure.
+ (false-if-exception
+ (let ((gostat (and (not %fresh-auto-compile)
+ (stat go-file-name #f))))
+ (if (and gostat (more-recent? gostat scmstat))
+ go-file-name
+ (begin
+ (if gostat
+ (format (current-warning-port)
+ ";;; note: source file ~a\n;;; newer than compiled ~a\n"
+ name go-file-name))
+ (cond
+ (%load-should-auto-compile
+ (%warn-auto-compilation-enabled)
+ (format (current-warning-port) ";;; compiling ~a\n" name)
+ (let ((cfn (compile name)))
+ (format (current-warning-port) ";;; compiled ~a\n" cfn)
+ cfn))
+ (else #f)))))
+ #:warning "WARNING: compilation of ~a failed:\n" name))
+
+ (define (sans-extension file)
+ (let ((dot (string-rindex file #\.)))
+ (if dot
+ (substring file 0 dot)
+ file)))
+
+ (define (load-absolute abs-file-name)
+ ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling
+ ;; if needed.
+ (define scmstat
+ (false-if-exception
+ (stat abs-file-name)
+ #:warning "Stat of ~a failed:\n" abs-file-name))
+
+ (define (pre-compiled)
+ (and=> (search-path %load-compiled-path (sans-extension file-name)
+ %load-compiled-extensions #t)
+ (lambda (go-file-name)
+ (let ((gostat (stat go-file-name #f)))
+ (and gostat (more-recent? gostat scmstat)
+ go-file-name)))))
+
+ (define (fallback)
+ (and=> (false-if-exception (canonicalize-path abs-file-name))
+ (lambda (canon)
+ (and=> (fallback-file-name canon)
+ (lambda (go-file-name)
+ (fresh-compiled-file-name abs-file-name
+ scmstat
+ go-file-name))))))
+
+ (let ((compiled (and scmstat (or (pre-compiled) (fallback)))))
+ (if compiled
(begin
(if %load-hook
- (%load-hook abs-path))
- (load-compiled cfn))
+ (%load-hook abs-file-name))
+ (load-compiled compiled))
(start-stack 'load-stack
- (primitive-load abs-path)))))
-
+ (primitive-load abs-file-name)))))
+
(save-module-excursion
(lambda ()
(with-fluids ((current-reader reader)
(%file-port-name-canonicalization 'relative))
(cond
- ((or (absolute-path? path))
- (load-absolute path))
- ((absolute-path? dir)
- (load-absolute (in-vicinity dir path)))
+ ((absolute-file-name? file-name)
+ (load-absolute file-name))
+ ((absolute-file-name? dir)
+ (load-absolute (in-vicinity dir file-name)))
(else
- (load-from-path (in-vicinity dir path))))))))
+ (load-from-path (in-vicinity dir file-name))))))))
(define-syntax load
(make-variable-transformer
;;; <feature-identifier>s `guile' and `r5rs', so that programs can
;;; determine the implementation type and the supported standard.
;;;
-;;; Currently, the following feature identifiers are supported:
-;;;
-;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
-;;;
;;; Remember to update the features list when adding more SRFIs.
;;;
(define %cond-expand-features
- ;; Adjust the above comment when changing this.
+ ;; This should contain only features that are present in core Guile,
+ ;; before loading any modules. Modular features are handled by
+ ;; placing 'cond-expand-provide' in the relevant module.
'(guile
guile-2
guile-2.2
r5rs
srfi-0 ;; cond-expand itself
- srfi-4 ;; homogenous numeric vectors
- srfi-6 ;; open-input-string etc, in the guile core
+ srfi-4 ;; homogeneous numeric vectors
+ ;; We omit srfi-6 because the 'open-input-string' etc in Guile
+ ;; core are not conformant with SRFI-6; they expose details
+ ;; of the binary I/O model and may fail to support some characters.
srfi-13 ;; string library
srfi-14 ;; character sets
srfi-23 ;; `error` procedure
srfi-39 ;; parameterize
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
+ srfi-105 ;; curly infix expressions
))
;; This table maps module public interfaces to the list of features.
HCoop / bpt / guile.git / blobdiff