The R Project SVN R

Rev

Rev 68947 | Rev 84211 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
73256 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
67595 ripley 4 
 *  Copyright (C) 2001-2014  The R Core Team
2 r 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 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
68947 ripley 18 
 *  https://www.R-project.org/Licenses/
2 r 19 
 */
20 
 
32380 ripley 21 
 
5187 hornik 22 
#ifdef HAVE_CONFIG_H
7701 hornik 23 
#include <config.h>
5187 hornik 24 
#endif
25 
 
2 r 26 
#include "Defn.h"
27 
 
28 
 
1895 ihaka 29 
/*  mkPRIMSXP - return a builtin function      */
30 
/*              either "builtin" or "special"  */
2 r 31 
 
54432 luke 32 
/*  The value produced is cached do avoid the need for GC protection
33 
    in cases where a .Primitive is produced by unserializing or
34 
    reconstructed after a package has clobbered the value assigned to
35 
    a symbol in the base package. */
36 
 
37001 ripley 37 
SEXP attribute_hidden mkPRIMSXP(int offset, int eval)
2 r 38 
{
54432 luke 39 
    SEXP result;
40 
    SEXPTYPE type = eval ? BUILTINSXP : SPECIALSXP;
41 
    static SEXP PrimCache = NULL;
42 
    static int FunTabSize = 0;
43 
 
44 
    if (PrimCache == NULL) {
45 
	/* compute the number of entires in R_FunTab */
46 
	while (R_FunTab[FunTabSize].name)
47 
	    FunTabSize++;
48 
 
49 
	/* allocate and protect the cache */
50 
	PrimCache = allocVector(VECSXP, FunTabSize);
51 
	R_PreserveObject(PrimCache);
52 
    }
53 
 
54 
    if (offset < 0 || offset >= FunTabSize)
55 
	error("offset is out of R_FunTab range");
56 
 
57 
    result = VECTOR_ELT(PrimCache, offset);
58 
 
59 
    if (result == R_NilValue) {
60 
	result = allocSExp(type);
61 
	SET_PRIMOFFSET(result, offset);
62114 luke 62 
	SET_VECTOR_ELT(PrimCache, offset, result);
54432 luke 63 
    }
64 
    else if (TYPEOF(result) != type)
65 
	error("requested primitive type is not consistent with cached value");
66 
 
67 
    return result;
2 r 68 
}
69 
 
34549 tlumley 70 
/* This is called by function() {}, where an invalid
45446 ripley 71 
   body should be impossible. When called from
72 
   other places (eg do_asfunction) they
34549 tlumley 73 
   should do this checking in advance */
2 r 74 
 
1895 ihaka 75 
/*  mkCLOSXP - return a closure with formals f,  */
76 
/*             body b, and environment rho       */
2 r 77 
 
37001 ripley 78 
SEXP attribute_hidden mkCLOSXP(SEXP formals, SEXP body, SEXP rho)
2 r 79 
{
1895 ihaka 80 
    SEXP c;
81 
    PROTECT(formals);
82 
    PROTECT(body);
83 
    PROTECT(rho);
84 
    c = allocSExp(CLOSXP);
6994 pd 85 
 
86 
#ifdef not_used_CheckFormals
87 
    if(isList(formals))
10172 luke 88 
	SET_FORMALS(c, formals);
6994 pd 89 
    else
56493 ripley 90 
	error(_("invalid formal arguments for 'function'"));
6994 pd 91 
#else
10172 luke 92 
    SET_FORMALS(c, formals);
6994 pd 93 
#endif
56493 ripley 94 
    switch (TYPEOF(body)) {
95 
    case CLOSXP:
96 
    case BUILTINSXP:
97 
    case SPECIALSXP:
98 
    case DOTSXP:
99 
    case ANYSXP:
100 
	error(_("invalid body argument for 'function'"));
101 
	break;
102 
    default:
10172 luke 103 
	SET_BODY(c, body);
56493 ripley 104 
	break;
105 
    }
6994 pd 106 
 
1895 ihaka 107 
    if(rho == R_NilValue)
10172 luke 108 
	SET_CLOENV(c, R_GlobalEnv);
1895 ihaka 109 
    else
10172 luke 110 
	SET_CLOENV(c, rho);
1895 ihaka 111 
    UNPROTECT(3);
112 
    return c;
2 r 113 
}
114 
 
37088 ripley 115 
/* mkChar - make a character (CHARSXP) variable -- see Rinlinedfuns.h */
2 r 116 
 
1895 ihaka 117 
/*  mkSYMSXP - return a symsxp with the string  */
118 
/*             name inserted in the name field  */
2 r 119 
 
16254 luke 120 
static int isDDName(SEXP name)
1916 rgentlem 121 
{
41807 rgentlem 122 
    const char *buf;
123 
    char *endp;
1916 rgentlem 124 
 
6676 pd 125 
    buf = CHAR(name);
39507 ripley 126 
    if( !strncmp(buf, "..", 2) && strlen(buf) > 2 ) {
45446 ripley 127 
	buf += 2;
55061 ripley 128 
	strtol(buf, &endp, 10); // discard value
45446 ripley 129 
	if( *endp != '\0')
12976 pd 130 
	    return 0;
1916 rgentlem 131 
	else
12976 pd 132 
	    return 1;
1916 rgentlem 133 
    }
134 
    return 0;
135 
}
136 
 
37001 ripley 137 
SEXP attribute_hidden mkSYMSXP(SEXP name, SEXP value)
1916 rgentlem 138 
 
2 r 139 
{
12976 pd 140 
    SEXP c;
141 
    int i;
142 
    PROTECT(name);
143 
    PROTECT(value);
16254 luke 144 
    i = isDDName(name);
12976 pd 145 
    c = allocSExp(SYMSXP);
146 
    SET_PRINTNAME(c, name);
147 
    SET_SYMVALUE(c, value);
148 
    SET_DDVAL(c, i);
149 
    UNPROTECT(2);
150 
    return c;
2 r 151 
}