← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/assignment.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/assignment.d
 
1
/*
 
2
    assignment.c  -- Assignment.
 
3
*/
 
4
/*
 
5
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
6
    Copyright (c) 1990, Giuseppe Attardi.
 
7
    Copyright (c) 2001, Juan Jose Garcia Ripoll.
 
8
 
 
9
    ECL is free software; you can redistribute it and/or
 
10
    modify it under the terms of the GNU Library General Public
 
11
    License as published by the Free Software Foundation; either
 
12
    version 2 of the License, or (at your option) any later version.
 
13
 
 
14
    See file '../Copyright' for full details.
 
15
*/
 
16
 
 
17
#include <ecl/ecl.h>
 
18
#include <string.h>
 
19
 
 
20
cl_object
 
21
cl_set(cl_object var, cl_object val)
 
22
{
 
23
        if (!SYMBOLP(var))
 
24
                FEtype_error_symbol(var);
 
25
        if (var->symbol.stype == stp_constant)
 
26
                FEinvalid_variable("Cannot assign to the constant ~S.", var);
 
27
        return1(ECL_SETQ(var, val));
 
28
}
 
29
 
 
30
@(defun si::fset (fname def &optional macro pprint)
 
31
        cl_object sym = si_function_block_name(fname);
 
32
        bool mflag;
 
33
@
 
34
        if (Null(cl_functionp(def)))
 
35
                FEinvalid_function(def);
 
36
        if (sym->symbol.hpack != Cnil && sym->symbol.hpack->pack.locked) {
 
37
                CEpackage_error("Attempt to redefine function ~S in locked package.",
 
38
                                "Ignore lock and proceed", fname->symbol.hpack, 1, fname);
 
39
        }
 
40
        mflag = !Null(macro);
 
41
        if (sym->symbol.isform && !mflag)
 
42
                FEerror("Given that ~S is a special form, ~S cannot be defined as a function.",
 
43
                        2, sym, fname);
 
44
        if (SYMBOLP(fname)) {
 
45
                sym->symbol.mflag = mflag;
 
46
                SYM_FUN(sym) = def;
 
47
                clear_compiler_properties(sym);
 
48
#ifndef ECL_CMU_FORMAT
 
49
                if (pprint == Cnil)
 
50
                        si_rem_sysprop(sym, @'si::pretty-print-format');
 
51
                else
 
52
                        si_put_sysprop(sym, @'si::pretty-print-format', pprint);
 
53
#endif
 
54
        } else {
 
55
                if (mflag)
 
56
                        FEerror("~S is not a valid name for a macro.", 1, fname);
 
57
                si_put_sysprop(sym, @'si::setf-symbol', def);
 
58
                si_rem_sysprop(sym, @'si::setf-lambda');
 
59
                si_rem_sysprop(sym, @'si::setf-method');
 
60
                si_rem_sysprop(sym, @'si::setf-update');
 
61
        }
 
62
        @(return def)
 
63
@)
 
64
 
 
65
cl_object
 
66
cl_makunbound(cl_object sym)
 
67
{
 
68
        if (!SYMBOLP(sym))
 
69
                FEtype_error_symbol(sym);
 
70
        if ((enum ecl_stype)sym->symbol.stype == stp_constant)
 
71
                FEinvalid_variable("Cannot unbind the constant ~S.", sym);
 
72
        /* FIXME! The semantics of MAKUNBOUND is not very clear with local
 
73
           bindings ... */
 
74
        ECL_SET(sym, OBJNULL);
 
75
        @(return sym)
 
76
}
 
77
 
 
78
cl_object
 
79
cl_fmakunbound(cl_object fname)
 
80
{
 
81
        cl_object sym = si_function_block_name(fname);
 
82
 
 
83
        if (sym->symbol.hpack != Cnil && sym->symbol.hpack->pack.locked) {
 
84
                CEpackage_error("Attempt to remove definition of function ~S in locked package.",
 
85
                                "Ignore lock and proceed", fname->symbol.hpack, 1, fname);
 
86
        }
 
87
        if (SYMBOLP(fname)) {
 
88
                clear_compiler_properties(sym);
 
89
#ifdef PDE
 
90
                si_rem_sysprop(fname, @'defun');
 
91
#endif
 
92
                SYM_FUN(sym) = Cnil;
 
93
                sym->symbol.mflag = FALSE;
 
94
        } else {
 
95
                si_rem_sysprop(sym, @'si::setf-symbol');
 
96
                si_rem_sysprop(sym, @'si::setf-lambda');
 
97
                si_rem_sysprop(sym, @'si::setf-method');
 
98
                si_rem_sysprop(sym, @'si::setf-update');
 
99
        }
 
100
        @(return fname)
 
101
}
 
102
 
 
103
void
 
104
clear_compiler_properties(cl_object sym)
 
105
{
 
106
        if (ecl_booted) {
 
107
                si_unlink_symbol(sym);
 
108
                funcall(2, @'si::clear-compiler-properties', sym);
 
109
        }
 
110
}
 
111
 
 
112
#ifdef PDE
 
113
void
 
114
record_source_pathname(cl_object sym, cl_object def)
 
115
{
 
116
  if (symbol_value(@'si::*record-source-pathname-p*') != Cnil)
 
117
    (void)funcall(3, @'si::record-source-pathname', sym, def);
 
118
}
 
119
#endif /* PDE */
 
120
 
 
121
cl_object
 
122
si_get_sysprop(cl_object sym, cl_object prop)
 
123
{
 
124
        cl_object plist = gethash_safe(sym, cl_core.system_properties, Cnil);
 
125
        prop = ecl_getf(plist, prop, OBJNULL);
 
126
        if (prop == OBJNULL) {
 
127
                @(return Cnil Cnil);
 
128
        } else {
 
129
                @(return prop Ct);
 
130
        }
 
131
}
 
132
 
 
133
cl_object
 
134
si_put_sysprop(cl_object sym, cl_object prop, cl_object value)
 
135
{
 
136
        cl_object plist;
 
137
        plist = gethash_safe(sym, cl_core.system_properties, Cnil);
 
138
        sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop));
 
139
        @(return value);
 
140
}
 
141
 
 
142
cl_object
 
143
si_rem_sysprop(cl_object sym, cl_object prop)
 
144
{
 
145
        cl_object plist, found;
 
146
        plist = gethash_safe(sym, cl_core.system_properties, Cnil);
 
147
        plist = si_rem_f(plist, prop);
 
148
        found = VALUES(1);
 
149
        sethash(sym, cl_core.system_properties, plist);
 
150
        @(return found);
 
151
}