## 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 |
}) |