Statistics
| Revision:

root / tmp / org.txm.statsengine.r.core.win32 / res / win32 / library / base / R / base @ 2486

History | View | Annotate | Download (4.3 kB)

1
#  File src/library/base/baseloader.R
2
#  Part of the R package, http://www.R-project.org
3
#
4
#  Copyright (C) 1995-2013 The R Core Team
5
#
6
#  This program is free software; you can redistribute it and/or modify
7
#  it under the terms of the GNU General Public License as published by
8
#  the Free Software Foundation; either version 2 of the License, or
9
#  (at your option) any later version.
10
#
11
#  This program is distributed in the hope that it will be useful,
12
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14
#  GNU General Public License for more details.
15
#
16
#  A copy of the GNU General Public License is available at
17
#  http://www.r-project.org/Licenses/
18

    
19

    
20
## this should be kept in step with code in R/lazyload.R
21
.Internal(eval(quote({
22
..lazyLoad <- function(filebase, envir = parent.frame())
23
{
24
    ##
25
    ## bootstrapping definitions so we can load base
26
    ##
27
    glue <- function (..., sep = " ", collapse = NULL)
28
        .Internal(paste(list(...), sep, collapse))
29
    readRDS <- function (file) {
30
        halt <- function (message) .Internal(stop(TRUE, message))
31
        gzfile <- function (description, open)
32
            .Internal(gzfile(description, open, "", 6))
33
        close <- function (con) .Internal(close(con, "rw"))
34
        if (! is.character(file)) halt("bad file name")
35
        con <- gzfile(file, "rb")
36
        on.exit(close(con))
37
        .Internal(unserializeFromConn(con, baseenv()))
38
    }
39
    `parent.env<-` <-
40
        function (env, value) .Internal(`parent.env<-`(env, value))
41
    existsInFrame <- function (x, env) .Internal(exists(x, env, "any", FALSE))
42
    getFromFrame <- function (x, env) .Internal(get(x, env, "any", FALSE))
43
    set <- function (x, value, env) .Internal(assign(x, value, env, FALSE))
44
    environment <- function () .Internal(environment(NULL))
45
    mkenv <- function() .Internal(new.env(TRUE, baseenv(), 29L))
46

    
47
    ##
48
    ## main body
49
    ##
50
    mapfile <- glue(filebase, "rdx", sep = ".")
51
    datafile <- glue(filebase, "rdb", sep = ".")
52
    env <- mkenv()
53
    map <- readRDS(mapfile)
54
    vars <- names(map$variables)
55
    rvars <- names(map$references)
56
    compressed <- map$compressed
57
    for (i in seq_along(rvars))
58
        set(rvars[i], map$references[[i]], env)
59
    envenv <- mkenv()
60
    envhook <- function(n) {
61
        if (existsInFrame(n, envenv))
62
            getFromFrame(n, envenv)
63
        else {
64
            e <- mkenv()
65
            set(n, e, envenv)           # MUST do this immediately
66
            key <- getFromFrame(n, env)
67
            data <- lazyLoadDBfetch(key, datafile, compressed, envhook)
68
            if (is.null(data$enclos))
69
                parent.env(e) <- emptyenv()
70
            else
71
                parent.env(e) <- data$enclos
72
            vars <- names(data$bindings)
73
            for (i in seq_along(vars))
74
                set(vars[i], data$bindings[[i]], e)
75
            if (! is.null(data$attributes))
76
                attributes(e) <- data$attributes
77
            ## there are no S4 objects in base
78
            if (! is.null(data$locked) && data$locked)
79
                .Internal(lockEnvironment(e, FALSE))
80
            e
81
        }
82
    }
83
    expr <- quote(lazyLoadDBfetch(key, datafile, compressed, envhook))
84
    this <- environment()
85
    .Internal(makeLazy(vars, map$variables, expr, this, envir))
86

    
87
    ## reduce memory use
88
    map <- NULL
89
    vars <- NULL
90
    rvars <- NULL
91
    mapfile <- NULL
92
    readRDS <- NULL
93
}
94

    
95
    existsInBase <- function (x)
96
        .Internal(exists(x, .BaseNamespaceEnv, "any", TRUE))
97
    glue <- function (..., sep = " ", collapse = NULL)
98
        .Internal(paste(list(...), sep, collapse))
99

    
100
    basedb <- glue(.Internal(R.home()), "library", "base", "R",
101
                   "base", sep= .Platform$file.sep)
102

    
103
    ..lazyLoad(basedb, baseenv())
104

    
105
}), .Internal(new.env(FALSE, baseenv(), 29L)), baseenv()))
106

    
107
## keep in sync with R/zzz.R
108
as.numeric <- as.double
109
is.name <- is.symbol
110

    
111

    
112
## populate C/Fortran symbols
113
local({
114
    routines <- getDLLRegisteredRoutines("base")
115
    for (i in c("dchdc", # chol, deprecated
116
                "dqrcf", "dqrdc2", "dqrqty", "dqrqy", "dqrrsd", "dqrxb", # qr
117
                "dtrco")) # .kappa_tri
118
        assign(paste0(".F_", i), routines[[3]][[i]], envir = .BaseNamespaceEnv)
119
    for(i in 1:2)
120
        lapply(routines[[i]],
121
               function(sym) assign(paste0(".C_", sym$name), sym, envir = .BaseNamespaceEnv))
122
})