← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/procprop.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/procprop.c
 
1
/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006 Free Software Foundation, Inc.
 
2
 * 
 
3
 * This library is free software; you can redistribute it and/or
 
4
 * modify it under the terms of the GNU Lesser General Public
 
5
 * License as published by the Free Software Foundation; either
 
6
 * version 2.1 of the License, or (at your option) any later version.
 
7
 *
 
8
 * This library is distributed in the hope that it will be useful,
 
9
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 
10
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
11
 * Lesser General Public License for more details.
 
12
 *
 
13
 * You should have received a copy of the GNU Lesser General Public
 
14
 * License along with this library; if not, write to the Free Software
 
15
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
16
 */
 
17
 
 
18
 
 
19
 
 
20
 
 
21
#include "libguile/_scm.h"
 
22
 
 
23
#include "libguile/alist.h"
 
24
#include "libguile/eval.h"
 
25
#include "libguile/procs.h"
 
26
#include "libguile/gsubr.h"
 
27
#include "libguile/objects.h"
 
28
#include "libguile/smob.h"
 
29
#include "libguile/root.h"
 
30
#include "libguile/vectors.h"
 
31
#include "libguile/hashtab.h"
 
32
 
 
33
#include "libguile/validate.h"
 
34
#include "libguile/procprop.h"
 
35
 
 
36
 
 
37
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
 
38
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
 
39
 
 
40
SCM
 
41
scm_i_procedure_arity (SCM proc)
 
42
{
 
43
  int a = 0, o = 0, r = 0;
 
44
  if (SCM_IMP (proc))
 
45
    return SCM_BOOL_F;
 
46
 loop:
 
47
  switch (SCM_TYP7 (proc))
 
48
    {
 
49
    case scm_tc7_subr_1o:
 
50
      o = 1;
 
51
    case scm_tc7_subr_0:
 
52
      break;
 
53
    case scm_tc7_subr_2o:
 
54
      o = 1;
 
55
    case scm_tc7_subr_1:
 
56
    case scm_tc7_dsubr:
 
57
    case scm_tc7_cxr:
 
58
      a += 1;
 
59
      break;
 
60
    case scm_tc7_subr_2:
 
61
      a += 2;
 
62
      break;
 
63
    case scm_tc7_subr_3:
 
64
      a += 3;
 
65
      break;
 
66
    case scm_tc7_asubr:
 
67
    case scm_tc7_rpsubr:
 
68
    case scm_tc7_lsubr:
 
69
      r = 1;
 
70
      break;
 
71
    case scm_tc7_lsubr_2:
 
72
      a += 2;
 
73
      r = 1;
 
74
      break;
 
75
    case scm_tc7_smob:
 
76
      if (SCM_SMOB_APPLICABLE_P (proc))
 
77
        {
 
78
          int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
 
79
          a += SCM_GSUBR_REQ (type);
 
80
          o = SCM_GSUBR_OPT (type);
 
81
          r = SCM_GSUBR_REST (type);
 
82
          break;
 
83
        }
 
84
      else
 
85
        {
 
86
          return SCM_BOOL_F;
 
87
        }
 
88
    case scm_tc7_cclo:
 
89
      if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply))
 
90
        {
 
91
          int type = scm_to_int (SCM_GSUBR_TYPE (proc));
 
92
          a += SCM_GSUBR_REQ (type);
 
93
          o = SCM_GSUBR_OPT (type);
 
94
          r = SCM_GSUBR_REST (type);
 
95
          break;
 
96
        }
 
97
      else
 
98
        {
 
99
          proc = SCM_CCLO_SUBR (proc);
 
100
          a -= 1;
 
101
          goto loop;
 
102
        }
 
103
    case scm_tc7_pws:
 
104
      proc = SCM_PROCEDURE (proc);
 
105
      goto loop;
 
106
    case scm_tcs_closures:
 
107
      proc = SCM_CLOSURE_FORMALS (proc);
 
108
      if (scm_is_null (proc))
 
109
        break;
 
110
      while (scm_is_pair (proc))
 
111
        {
 
112
          ++a;
 
113
          proc = SCM_CDR (proc);
 
114
        }
 
115
      if (!scm_is_null (proc))
 
116
        r = 1;
 
117
      break;
 
118
    case scm_tcs_struct:
 
119
      if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
 
120
        {
 
121
          r = 1;
 
122
          break;
 
123
        }
 
124
      else if (!SCM_I_OPERATORP (proc))
 
125
        return SCM_BOOL_F;
 
126
      proc = (SCM_I_ENTITYP (proc)
 
127
              ? SCM_ENTITY_PROCEDURE (proc)
 
128
              : SCM_OPERATOR_PROCEDURE (proc));
 
129
      a -= 1;
 
130
      goto loop;
 
131
    default:
 
132
      return SCM_BOOL_F;
 
133
    }
 
134
  return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
 
135
}
 
136
 
 
137
/* XXX - instead of using a stand-in value for everything except
 
138
   closures, we should find other ways to store the procedure
 
139
   properties for those other kinds of procedures.  For example, subrs
 
140
   have their own property slot, which is unused at present.
 
141
*/
 
142
 
 
143
static SCM
 
144
scm_stand_in_scm_proc(SCM proc)
 
145
{
 
146
  SCM handle, answer;
 
147
  handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
 
148
  if (scm_is_false (handle))
 
149
    {
 
150
      answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
 
151
      scm_hashq_set_x (scm_stand_in_procs, proc, answer);
 
152
    }
 
153
  else
 
154
    answer = SCM_CDR (handle);
 
155
  return answer;
 
156
}
 
157
 
 
158
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, 
 
159
           (SCM proc),
 
160
            "Return @var{obj}'s property list.")
 
161
#define FUNC_NAME s_scm_procedure_properties
 
162
{
 
163
  SCM_VALIDATE_PROC (1, proc);
 
164
  return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
 
165
                    SCM_PROCPROPS (SCM_CLOSUREP (proc)
 
166
                                   ? proc
 
167
                                   : scm_stand_in_scm_proc (proc)));
 
168
}
 
169
#undef FUNC_NAME
 
170
 
 
171
SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 
172
           (SCM proc, SCM new_val),
 
173
            "Set @var{obj}'s property list to @var{alist}.")
 
174
#define FUNC_NAME s_scm_set_procedure_properties_x
 
175
{
 
176
  if (!SCM_CLOSUREP (proc))
 
177
    proc = scm_stand_in_scm_proc(proc);
 
178
  SCM_VALIDATE_CLOSURE (1, proc);
 
179
  SCM_SETPROCPROPS (proc, new_val);
 
180
  return SCM_UNSPECIFIED;
 
181
}
 
182
#undef FUNC_NAME
 
183
 
 
184
SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 
185
           (SCM p, SCM k),
 
186
            "Return the property of @var{obj} with name @var{key}.")
 
187
#define FUNC_NAME s_scm_procedure_property
 
188
{
 
189
  SCM assoc;
 
190
  if (scm_is_eq (k, scm_sym_arity))
 
191
    {
 
192
      SCM arity;
 
193
      SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
 
194
                  p, SCM_ARG1, FUNC_NAME);
 
195
      return arity;
 
196
    }
 
197
  SCM_VALIDATE_PROC (1, p);
 
198
  assoc = scm_sloppy_assq (k,
 
199
                           SCM_PROCPROPS (SCM_CLOSUREP (p)
 
200
                                          ? p
 
201
                                          : scm_stand_in_scm_proc (p)));
 
202
  return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
 
203
}
 
204
#undef FUNC_NAME
 
205
 
 
206
SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 
207
           (SCM p, SCM k, SCM v),
 
208
            "In @var{obj}'s property list, set the property named @var{key} to\n"
 
209
            "@var{value}.")
 
210
#define FUNC_NAME s_scm_set_procedure_property_x
 
211
{
 
212
  SCM assoc;
 
213
  if (!SCM_CLOSUREP (p))
 
214
    p = scm_stand_in_scm_proc(p);
 
215
  SCM_VALIDATE_CLOSURE (1, p);
 
216
  if (scm_is_eq (k, scm_sym_arity))
 
217
    SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
 
218
  assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
 
219
  if (SCM_NIMP (assoc))
 
220
    SCM_SETCDR (assoc, v);
 
221
  else
 
222
    SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
 
223
  return SCM_UNSPECIFIED;
 
224
}
 
225
#undef FUNC_NAME
 
226
 
 
227
 
 
228
 
 
229
 
 
230
void
 
231
scm_init_procprop ()
 
232
{
 
233
#include "libguile/procprop.x"
 
234
}
 
235
 
 
236
 
 
237
/*
 
238
  Local Variables:
 
239
  c-file-style: "gnu"
 
240
  End:
 
241
*/