← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/c/cmpaux.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2007-04-09 11:51:51 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070409115151-ql8cr0kalzx1jmla
Tags: 0.9i-20070324-2
Upload to unstable. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/cmpaux.d
26
26
}
27
27
 
28
28
cl_fixnum
29
 
ifloor(cl_fixnum x, cl_fixnum y)
 
29
ecl_ifloor(cl_fixnum x, cl_fixnum y)
30
30
{
31
31
        if (y == 0)
32
32
                FEerror("Zero divizor", 0);
43
43
}
44
44
 
45
45
cl_fixnum
46
 
imod(cl_fixnum x, cl_fixnum y)
 
46
ecl_imod(cl_fixnum x, cl_fixnum y)
47
47
{
48
 
        return(x - ifloor(x, y)*y);
 
48
        return(x - ecl_ifloor(x, y)*y);
49
49
}
50
50
 
51
51
/*
55
55
 */
56
56
 
57
57
char
58
 
object_to_char(cl_object x)
 
58
ecl_to_char(cl_object x)
59
59
{
60
60
        switch (type_of(x)) {
61
61
        case t_fixnum:
68
68
}
69
69
 
70
70
cl_fixnum
71
 
object_to_fixnum(cl_object x)
 
71
ecl_to_fixnum(cl_object x)
72
72
{
73
73
        switch (type_of(x)) {
74
74
        case t_fixnum:
76
76
                return fixint(x);
77
77
/*      case t_character: return (cl_fixnum)CHAR_CODE(x); */
78
78
        case t_ratio:
79
 
                return (cl_fixnum)number_to_double(x);
 
79
                return (cl_fixnum)ecl_to_double(x);
 
80
#ifdef ECL_SHORT_FLOAT
80
81
        case t_shortfloat:
 
82
                return (cl_fixnum)ecl_short_float(x);
 
83
#endif
 
84
        case t_singlefloat:
81
85
                return (cl_fixnum)sf(x);
 
86
        case t_doublefloat:
 
87
                return (cl_fixnum)df(x);
 
88
#ifdef ECL_LONG_FLOAT
82
89
        case t_longfloat:
83
 
                return (cl_fixnum)lf(x);
 
90
                return (cl_fixnum)ecl_long_float(x);
 
91
#endif
84
92
        default:
85
93
                FEerror("~S cannot be coerced to a C int.", 1, x);
86
94
        }
87
95
}
88
96
 
89
97
cl_index
90
 
object_to_unsigned_integer(cl_object x)
 
98
ecl_to_unsigned_integer(cl_object x)
91
99
{
92
100
        switch (type_of(x)) {
93
101
        case t_fixnum:
94
102
        case t_bignum:
95
103
                return fixnnint(x);
96
104
        case t_ratio:
97
 
                return (cl_index)number_to_double(x);
 
105
                return (cl_index)ecl_to_double(x);
 
106
#ifdef ECL_SHORT_FLOAT
98
107
        case t_shortfloat:
 
108
                return (cl_index)ecl_short_float(x);
 
109
#endif
 
110
        case t_singlefloat:
99
111
                return (cl_index)sf(x);
 
112
        case t_doublefloat:
 
113
                return (cl_index)df(x);
 
114
#ifdef ECL_LONG_FLOAT
100
115
        case t_longfloat:
101
 
                return (cl_index)lf(x);
 
116
                return (cl_index)ecl_long_float(x);
 
117
#endif
102
118
        default:
103
119
                FEerror("~S cannot be coerced to a C unsigned int.", 1, x);
104
120
        }
105
121
}
106
122
 
107
123
float
108
 
object_to_float(cl_object x)
109
 
{
110
 
        if (FIXNUMP(x)) return(fix(x)); /* Immediate fixnum */
111
 
 
112
 
        switch (type_of(x)) {
113
 
/*      case t_fixnum: return fix(x);   */
114
 
/*      case t_character: return CHAR_CODE(x); */
115
 
        case t_bignum:
116
 
        case t_ratio:
117
 
                return number_to_double(x);
118
 
        case t_shortfloat:
119
 
                return sf(x);
120
 
        case t_longfloat:
121
 
                return lf(x);
122
 
        default:
123
 
                FEtype_error_real(x);
124
 
        }
125
 
}
126
 
 
127
 
double
128
 
object_to_double(cl_object x)
129
 
{
130
 
 
131
 
        if (FIXNUMP(x)) return(fix(x)); /* Immediate fixnum */
132
 
 
133
 
        switch (type_of(x)) {
134
 
/*      case t_fixnum: return fix(x);   */
135
 
/*      case t_character: return CHAR_CODE(x); */
136
 
        case t_bignum:
137
 
        case t_ratio:
138
 
                return number_to_double(x);
139
 
        case t_shortfloat:
140
 
                return sf(x);
141
 
        case t_longfloat:
142
 
                return lf(x);
 
124
ecl_to_float(cl_object x)
 
125
{
 
126
        if (FIXNUMP(x)) return(fix(x)); /* Immediate fixnum */
 
127
 
 
128
        switch (type_of(x)) {
 
129
/*      case t_fixnum: return fix(x);   */
 
130
/*      case t_character: return CHAR_CODE(x); */
 
131
        case t_bignum:
 
132
        case t_ratio:
 
133
                return ecl_to_double(x);
 
134
#ifdef ECL_SHORT_FLOAT
 
135
        case t_shortfloat:
 
136
                return ecl_short_float(x);
 
137
#endif
 
138
        case t_singlefloat:
 
139
                return sf(x);
 
140
        case t_doublefloat:
 
141
                return df(x);
 
142
#ifdef ECL_LONG_FLOAT
 
143
        case t_longfloat:
 
144
                return ecl_long_float(x);
 
145
#endif
143
146
        default:
144
147
                FEtype_error_real(x);
145
148
        }
146
149
}
147
150
 
148
151
int
149
 
aref_bv(cl_object x, cl_index index)
 
152
ecl_aref_bv(cl_object x, cl_index index)
150
153
{
151
154
  index += x->vector.offset;
152
155
  return ((x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT)) != 0);
153
156
}
154
157
 
155
158
int
156
 
aset_bv(cl_object x, cl_index index, int value)
 
159
ecl_aset_bv(cl_object x, cl_index index, int value)
157
160
{
158
161
  index += x->vector.offset;
159
162
  if (value == 0)
169
172
  ecl_frame_ptr fr = frs_sch(tag);
170
173
  if (fr == NULL)
171
174
    FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag);
172
 
  unwind(fr);
 
175
  ecl_unwind(fr);
173
176
}
174
177
 
175
178
void
179
182
  if (fr == NULL)
180
183
    FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.",
181
184
                    2, block_name, block_id);
182
 
  unwind(fr);
 
185
  ecl_unwind(fr);
183
186
}
184
187
 
185
188
void
190
193
    FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id);
191
194
  VALUES(0)=label;
192
195
  NVALUES=1;
193
 
  unwind(fr);
 
196
  ecl_unwind(fr);
194
197
}
195
198
 
196
199
cl_object