1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
4 * Copyright (C) 2001, 2006 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 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 *
20 *
21 *
22 * Basic List Handling Features
23 *
24 * These remain here to show that R is truly descended from Lisp :-).
25 * There is one real function "allnames" shich should probably be
26 * elsewhere.
27 */
28
29 #ifdef HAVE_CONFIG_H
30 #include <config.h>
31 #endif
32
33 #include <Defn.h>
34 #include <Internal.h>
35
36 /* Utility functions moved to Rinlinedfuns.h */
37
38 /* The following code is used to recursive traverse a block */
39 /* of code and extract all the symbols present in that code. */
40
41 typedef struct {
42 SEXP ans;
43 int UniqueNames;
44 int IncludeFunctions;
45 int StoreValues;
46 int ItemCounts;
47 int MaxCount;
48 } NameWalkData;
49
namewalk(SEXP s,NameWalkData * d)50 static void namewalk(SEXP s, NameWalkData *d)
51 {
52 SEXP name;
53
54 switch(TYPEOF(s)) {
55 case SYMSXP:
56 name = PRINTNAME(s);
57 /* skip blank symbols */
58 if(CHAR(name)[0] == '\0') goto ignore;
59 if(d->ItemCounts < d->MaxCount) {
60 if(d->StoreValues) {
61 if(d->UniqueNames) {
62 for(int j = 0 ; j < d->ItemCounts ; j++) {
63 if(STRING_ELT(d->ans, j) == name)
64 goto ignore;
65 }
66 }
67 SET_STRING_ELT(d->ans, d->ItemCounts, name);
68 }
69 d->ItemCounts++;
70 }
71 ignore:
72 break;
73 case LANGSXP:
74 if(!d->IncludeFunctions) s = CDR(s);
75 while(s != R_NilValue) {
76 namewalk(CAR(s), d);
77 s = CDR(s);
78 }
79 break;
80 case EXPRSXP:
81 for(R_xlen_t i = 0 ; i < XLENGTH(s) ; i++)
82 namewalk(VECTOR_ELT(s, i), d);
83 break;
84 default:
85 /* it seems the intention is to do nothing here! */
86 break;
87 }
88 }
89
90 /* Also does all.vars with functions=FALSE
91 .Internal(all.names(expr, functions, max.names, unique)) */
do_allnames(SEXP call,SEXP op,SEXP args,SEXP env)92 SEXP attribute_hidden do_allnames(SEXP call, SEXP op, SEXP args, SEXP env)
93 {
94 SEXP expr;
95 int i, savecount;
96 NameWalkData data = {NULL, 0, 0, 0, 0, 0};
97
98 checkArity(op, args);
99
100 expr = CAR(args);
101 args = CDR(args);
102
103 data.IncludeFunctions = asLogical(CAR(args));
104 if(data.IncludeFunctions == NA_LOGICAL)
105 data.IncludeFunctions = 0;
106 args = CDR(args);
107
108 data.MaxCount = asInteger(CAR(args));
109 if(data.MaxCount == -1) data.MaxCount = INT_MAX;
110 if(data.MaxCount < 0 || data.MaxCount == NA_INTEGER)
111 data.MaxCount = 0;
112 args = CDR(args);
113
114 data.UniqueNames = asLogical(CAR(args));
115 if(data.UniqueNames == NA_LOGICAL)
116 data.UniqueNames = 1;
117
118 namewalk(expr, &data);
119 savecount = data.ItemCounts;
120
121 data.ans = allocVector(STRSXP, data.ItemCounts);
122
123 data.StoreValues = 1;
124 data.ItemCounts = 0;
125 namewalk(expr, &data);
126
127 if(data.ItemCounts != savecount) {
128 PROTECT(expr = data.ans);
129 data.ans = allocVector(STRSXP, data.ItemCounts);
130 for(i = 0 ; i < data.ItemCounts ; i++)
131 SET_STRING_ELT(data.ans, i, STRING_ELT(expr, i));
132 UNPROTECT(1);
133 }
134
135 return data.ans;
136 }
137