The R Project SVN R

Rev

Rev 28254 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
2 
 *  R : A Computer Langage for Statistical Data Analysis
3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
22926 ripley 4 
 *  Copyright (C) 2001-3  The R Development 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
17 
 *  along with this program; if not, write to the Free Software
5458 ripley 18 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
2 r 19 
 */
20 
 
5187 hornik 21 
#ifdef HAVE_CONFIG_H
7701 hornik 22 
#include <config.h>
5187 hornik 23 
#endif
24 
 
2 r 25 
#include "Defn.h"
26 
 
1895 ihaka 27 
/*  append - append second to the tail of first    */
28 
/*           This operation is non-destructive     */
29 
/*           i.e. first and second are duplicated  */
2 r 30 
 
22926 ripley 31 
SEXP Rf_append(SEXP first, SEXP second)
2 r 32 
{
1895 ihaka 33 
    SEXP e;
2 r 34 
 
1895 ihaka 35 
    PROTECT(second);
36 
    first = duplicate(first);
37 
    UNPROTECT(1);
38 
    PROTECT(first);
39 
    second = duplicate(second);
40 
    UNPROTECT(1);
41 
    for (e = first; CDR(e) != R_NilValue; e = CDR(e));
42 
    SETCDR(e, second);
43 
    return first;
2 r 44 
}
45 
 
46 
 
1895 ihaka 47 
/*  mkPRIMSXP - return a builtin function      */
48 
/*              either "builtin" or "special"  */
2 r 49 
 
50 
SEXP mkPRIMSXP(int offset, int eval)
51 
{
1895 ihaka 52 
    SEXP result = allocSExp(eval ? BUILTINSXP : SPECIALSXP);
10172 luke 53 
    SET_PRIMOFFSET(result, offset);
1895 ihaka 54 
    return (result);
2 r 55 
}
56 
 
57 
 
1895 ihaka 58 
/*  mkCLOSXP - return a closure with formals f,  */
59 
/*             body b, and environment rho       */
2 r 60 
 
61 
SEXP mkCLOSXP(SEXP formals, SEXP body, SEXP rho)
62 
{
1895 ihaka 63 
    SEXP c;
64 
    PROTECT(formals);
65 
    PROTECT(body);
66 
    PROTECT(rho);
67 
    c = allocSExp(CLOSXP);
6994 pd 68 
 
69 
#ifdef not_used_CheckFormals
70 
    if(isList(formals))
10172 luke 71 
	SET_FORMALS(c, formals);
6994 pd 72 
    else
73 
        error("invalid formal arguments for \"function\"");
74 
#else
10172 luke 75 
    SET_FORMALS(c, formals);
6994 pd 76 
#endif
77 
    if(isList(body) || isLanguage(body) || isSymbol(body)
24527 luke 78 
       || isExpression(body) || isVector(body)
79 
#ifdef BYTECODE
80 
       || isByteCode(body)
81 
#endif
82 
       )
10172 luke 83 
	SET_BODY(c, body);
6994 pd 84 
    else
85 
        error("invalid body argument for \"function\"\n"
86 
	      "Should NEVER happen; please bug.report() [mkCLOSXP]\n");
87 
 
1895 ihaka 88 
    if(rho == R_NilValue)
10172 luke 89 
	SET_CLOENV(c, R_GlobalEnv);
1895 ihaka 90 
    else
10172 luke 91 
	SET_CLOENV(c, rho);
1895 ihaka 92 
    UNPROTECT(3);
93 
    return c;
2 r 94 
}
95 
 
1895 ihaka 96 
/* mkChar - make a character (CHARSXP) variable */
2 r 97 
 
4855 ihaka 98 
SEXP mkChar(const char *name)
2 r 99 
{
1895 ihaka 100 
    SEXP c;
2 r 101 
 
18940 ripley 102 
#if 0
1895 ihaka 103 
    if (streql(name, "NA"))
104 
	return (NA_STRING);
18940 ripley 105 
#endif
1895 ihaka 106 
    c = allocString(strlen(name));
107 
    strcpy(CHAR(c), name);
108 
    return c;
2 r 109 
}
110 
 
111 
 
1895 ihaka 112 
/*  mkSYMSXP - return a symsxp with the string  */
113 
/*             name inserted in the name field  */
2 r 114 
 
16254 luke 115 
static int isDDName(SEXP name)
1916 rgentlem 116 
{
6676 pd 117 
    char *buf, *endp;
1916 rgentlem 118 
 
6676 pd 119 
    buf = CHAR(name);
1916 rgentlem 120 
    if( !strncmp(buf,"..",2) && strlen(buf) > 2 ) {
6676 pd 121 
        buf += 2;
12976 pd 122 
	strtol(buf, &endp, 10);
1916 rgentlem 123 
        if( *endp != '\0')
12976 pd 124 
	    return 0;
1916 rgentlem 125 
	else
12976 pd 126 
	    return 1;
1916 rgentlem 127 
    }
128 
    return 0;
129 
}
130 
 
2 r 131 
SEXP mkSYMSXP(SEXP name, SEXP value)
1916 rgentlem 132 
 
2 r 133 
{
12976 pd 134 
    SEXP c;
135 
    int i;
136 
    PROTECT(name);
137 
    PROTECT(value);
16254 luke 138 
    i = isDDName(name);
12976 pd 139 
    c = allocSExp(SYMSXP);
140 
    SET_PRINTNAME(c, name);
141 
    SET_SYMVALUE(c, value);
142 
    SET_DDVAL(c, i);
143 
    UNPROTECT(2);
144 
    return c;
2 r 145 
}
146 
 
147 
 
1895 ihaka 148 
/*  length - length of objects  */
2 r 149 
 
28362 murdoch 150 
R_len_t length(SEXP s)
2 r 151 
{
1895 ihaka 152 
    int i;
153 
    switch (TYPEOF(s)) {
154 
    case NILSXP:
155 
	return 0;
156 
    case LGLSXP:
157 
    case INTSXP:
158 
    case REALSXP:
159 
    case CPLXSXP:
160 
    case STRSXP:
161 
    case CHARSXP:
162 
    case VECSXP:
163 
    case EXPRSXP:
164 
	return LENGTH(s);
165 
    case LISTSXP:
166 
    case LANGSXP:
167 
    case DOTSXP:
168 
	i = 0;
169 
	while (s != NULL && s != R_NilValue) {
170 
	    i++;
171 
	    s = CDR(s);
2 r 172 
	}
1895 ihaka 173 
	return i;
174 
    case ENVSXP:
175 
	return length(FRAME(s));
176 
    default:
177 
	return 1;
178 
    }
2 r 179 
}