1 /* Copyright (C) 1997, 1998, 1999 Marius Vollmer
2 * Copyright (C) 1999-2000 John Harper <john@dcs.warwick.ac.uk>
3 *
4 * $Id$
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, or (at your option)
9 * 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 software; see the file COPYING. If not, write to
18 * Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston,
19 * MA 02110-1301, USA.
20 */
21
22 #include <config.h>
23 #include <assert.h>
24 #include <glib.h>
25 #include "rep-gtk.h"
26 #include <string.h>
27 #include <limits.h>
28
29
30 /* Hacking the basic types --jsh */
31
32 static inline int
valid_int_type(repv obj)33 valid_int_type (repv obj)
34 {
35 return rep_INTEGERP (obj) || rep_LONG_INTP (obj);
36 }
37
38 int
sgtk_valid_int(repv obj)39 sgtk_valid_int (repv obj)
40 {
41 return valid_int_type (obj);
42 }
43
44 int
sgtk_valid_uint(repv obj)45 sgtk_valid_uint (repv obj)
46 {
47 return valid_int_type (obj);
48 }
49
50 int
sgtk_valid_long(repv obj)51 sgtk_valid_long (repv obj)
52 {
53 return valid_int_type (obj);
54 }
55
56 int
sgtk_valid_ulong(repv obj)57 sgtk_valid_ulong (repv obj)
58 {
59 return valid_int_type (obj);
60 }
61
62 int
sgtk_valid_char(repv obj)63 sgtk_valid_char (repv obj)
64 {
65 return rep_INTP (obj);
66 }
67
68 repv
sgtk_uint_to_rep(unsigned long x)69 sgtk_uint_to_rep (unsigned long x)
70 {
71 return rep_make_long_uint (x);
72 }
73
74 repv
sgtk_int_to_rep(long x)75 sgtk_int_to_rep (long x)
76 {
77 return rep_make_long_int (x);
78 }
79
80 repv
sgtk_long_to_rep(long x)81 sgtk_long_to_rep (long x)
82 {
83 return rep_make_long_int (x);
84 }
85
86 repv
sgtk_ulong_to_rep(unsigned long x)87 sgtk_ulong_to_rep (unsigned long x)
88 {
89 return rep_make_long_uint (x);
90 }
91
92 guint
sgtk_rep_to_uint(repv obj)93 sgtk_rep_to_uint (repv obj)
94 {
95 return rep_get_long_uint (obj);
96 }
97
98 gint
sgtk_rep_to_int(repv obj)99 sgtk_rep_to_int (repv obj)
100 {
101 return rep_get_long_int (obj);
102 }
103
104 gulong
sgtk_rep_to_ulong(repv obj)105 sgtk_rep_to_ulong (repv obj)
106 {
107 return rep_get_long_uint (obj);
108 }
109
110 glong
sgtk_rep_to_long(repv obj)111 sgtk_rep_to_long (repv obj)
112 {
113 return rep_get_long_int (obj);
114 }
115
116 gchar
sgtk_rep_to_char(repv obj)117 sgtk_rep_to_char (repv obj)
118 {
119 return rep_INT (obj);
120 }
121
122 repv
sgtk_char_to_rep(gchar c)123 sgtk_char_to_rep (gchar c)
124 {
125 return rep_MAKE_INT (c);
126 }
127
128 char *
sgtk_rep_to_string(repv obj)129 sgtk_rep_to_string (repv obj)
130 {
131 return rep_STRINGP (obj) ? rep_STR (obj) : (gpointer) (char *)"";
132 }
133
134 repv
sgtk_string_to_rep(char * x)135 sgtk_string_to_rep (char *x)
136 {
137 repv obj;
138 if (x == 0)
139 return Qnil;
140 obj = rep_string_dup (x);
141 g_free (x);
142 return obj;
143 }
144
145 repv
sgtk_static_string_to_rep(const char * x)146 sgtk_static_string_to_rep (const char *x)
147 {
148 repv obj;
149 if (x == 0)
150 return Qnil;
151 obj = rep_string_dup (x);
152 return obj;
153 }
154
155 int
sgtk_valid_string(repv obj)156 sgtk_valid_string (repv obj)
157 {
158 return rep_STRINGP (obj);
159 }
160
161 repv
sgtk_bool_to_rep(int x)162 sgtk_bool_to_rep (int x)
163 {
164 return x ? Qt : Qnil;
165 }
166
167 int
sgtk_rep_to_bool(repv obj)168 sgtk_rep_to_bool (repv obj)
169 {
170 return obj != Qnil;
171 }
172
173 int
sgtk_valid_function(repv obj)174 sgtk_valid_function (repv obj)
175 {
176 return Ffunctionp (obj) != Qnil;
177 }
178
179 int
sgtk_valid_fd(repv obj)180 sgtk_valid_fd (repv obj)
181 {
182 return rep_FILEP (obj) && rep_LOCAL_FILE_P (obj);
183 }
184
185 int
sgtk_rep_to_fd(repv obj)186 sgtk_rep_to_fd (repv obj)
187 {
188 return fileno (rep_FILE(obj)->file.fh);
189 }
190
191 repv
sgtk_fd_to_rep(int fd)192 sgtk_fd_to_rep (int fd)
193 {
194 if (fd < 0)
195 return Qnil;
196 else
197 return rep_file_fdopen (fd, "w+");
198 }
199
200 int
sgtk_valid_pointer(repv obj)201 sgtk_valid_pointer (repv obj)
202 {
203 return obj == Qnil || rep_INTEGERP (obj) || rep_LONG_INTP (obj);
204 }
205
206 void *
sgtk_rep_to_pointer(repv obj)207 sgtk_rep_to_pointer (repv obj)
208 {
209 if (obj == Qnil)
210 return NULL;
211 else
212 return (void *) rep_get_long_uint (obj);
213 }
214
215 repv
sgtk_pointer_to_rep(void * ptr)216 sgtk_pointer_to_rep (void *ptr)
217 {
218 repv data = rep_VAL (ptr);
219 if (data == 0)
220 return Qnil;
221 else if (data > rep_LISP_MAX_INT)
222 /* could use a bignum, but cons is more efficient */
223 return rep_MAKE_LONG_INT (data);
224 else
225 return rep_MAKE_INT (data);
226 }
227
228 static int
list_length(repv list)229 list_length (repv list)
230 {
231 repv len = Flength (list);
232 return (len && rep_INTP (len)) ? rep_INT (len) : 0;
233 }
234
235 /* namespace fuckage. needed so we can represent GObject base class */
236 GType
gobject_get_type(void)237 gobject_get_type (void)
238 {
239 return G_TYPE_OBJECT;
240 }
241
242 /* Floats. */
243
244 int
sgtk_valid_float(repv obj)245 sgtk_valid_float (repv obj)
246 {
247 return rep_NUMERICP (obj);
248 }
249
250 gfloat
sgtk_rep_to_float(repv obj)251 sgtk_rep_to_float (repv obj)
252 {
253 return rep_get_float (obj);
254 }
255
256 repv
sgtk_float_to_rep(gfloat f)257 sgtk_float_to_rep (gfloat f)
258 {
259 return rep_make_float (f, rep_FALSE);
260 }
261
262 int
sgtk_valid_double(repv obj)263 sgtk_valid_double (repv obj)
264 {
265 return rep_NUMERICP (obj);
266 }
267
268 double
sgtk_rep_to_double(repv obj)269 sgtk_rep_to_double (repv obj)
270 {
271 return rep_get_float (obj);
272 }
273
274 repv
sgtk_double_to_rep(double f)275 sgtk_double_to_rep (double f)
276 {
277 return rep_make_float (f, rep_FALSE);
278 }
279
280
281 /* Composites. */
282
283 int
sgtk_valid_composite(repv obj,int (* predicate)(repv))284 sgtk_valid_composite (repv obj, int (*predicate)(repv))
285 {
286 return sgtk_valid_complen (obj, predicate, -1);
287 }
288
289 int
sgtk_valid_complen(repv obj,int (* predicate)(repv),int len)290 sgtk_valid_complen (repv obj, int (*predicate)(repv), int len)
291 {
292 int actual_len;
293
294 if (rep_LISTP(obj))
295 {
296 actual_len = list_length (obj);
297
298 if (len >= 0 && len != actual_len)
299 return 0;
300
301 if (predicate)
302 {
303 while (rep_CONSP(obj))
304 {
305 if (!predicate (rep_CAR(obj)))
306 return 0;
307 obj = rep_CDR(obj);
308 }
309 }
310 return 1;
311 }
312 else if (rep_VECTORP(obj))
313 {
314 int i;
315 repv *elts;
316
317 actual_len = rep_VECT_LEN (obj);
318 if (len >= 0 && len != actual_len)
319 return 0;
320
321 if (predicate)
322 {
323 elts = rep_VECT(obj)->array;
324 for (i = 0; i < len; i++)
325 if (!predicate(elts[i]))
326 return 0;
327 }
328 return 1;
329 }
330 else
331 return 0;
332 }
333
334 repv
sgtk_slist_to_rep(GSList * list,repv (* toscm)(void *))335 sgtk_slist_to_rep (GSList *list, repv (*toscm)(void*))
336 {
337 repv res, *tail = &res;
338 while (list)
339 {
340 *tail = Fcons (toscm (&list->data), *tail);
341 tail = rep_CDRLOC (*tail);
342 list = list->next;
343 }
344 *tail = Qnil;
345 return res;
346 }
347
348 GSList*
sgtk_rep_to_slist(repv obj,void (* fromscm)(repv,void *))349 sgtk_rep_to_slist (repv obj, void (*fromscm)(repv, void*))
350 {
351 GSList *res, **tail = &res;
352
353 if (obj == Qnil || (rep_CONSP(obj)))
354 {
355 while (rep_CONSP(obj))
356 {
357 *tail = g_slist_alloc ();
358 if (fromscm)
359 fromscm (rep_CAR (obj), &(*tail)->data);
360 else
361 (*tail)->data = NULL;
362 obj = rep_CDR(obj);
363 tail = &(*tail)->next;
364 }
365 }
366 else if (rep_VECTORP(obj))
367 {
368 int len = rep_VECT_LEN (obj), i;
369 repv *elts = rep_VECT(obj)->array;
370 for (i = 0; i < len; i++)
371 {
372 *tail = g_slist_alloc ();
373 if (fromscm)
374 fromscm (elts[i], &(*tail)->data);
375 else
376 (*tail)->data = NULL;
377 tail = &(*tail)->next;
378 }
379 }
380 *tail = NULL;
381 return res;
382 }
383
384 void
sgtk_slist_finish(GSList * list,repv obj,repv (* toscm)(void *))385 sgtk_slist_finish (GSList *list, repv obj, repv (*toscm)(void*))
386 {
387 if (toscm)
388 {
389 if (obj == Qnil || (rep_CONSP(obj)))
390 {
391 while (rep_CONSP(obj) && list)
392 {
393 rep_CAR(obj) = toscm (list->data);
394 obj = rep_CDR(obj);
395 list = list->next;
396 }
397 }
398 else if (rep_VECTORP(obj))
399 {
400 int len = rep_VECT_LEN (obj), i;
401 repv *elts = rep_VECT(obj)->array;
402 for (i = 0; i < len && list; i++)
403 {
404 elts[i] = toscm (list->data);
405 list = list->next;
406 }
407 }
408 }
409
410 g_slist_free (list);
411 }
412
413 repv
sgtk_list_to_rep(GList * list,repv (* toscm)(void *))414 sgtk_list_to_rep (GList *list, repv (*toscm)(void*))
415 {
416 repv res, *tail = &res;
417 while (list)
418 {
419 *tail = Fcons (toscm (&list->data), *tail);
420 tail = rep_CDRLOC (*tail);
421 list = list->next;
422 }
423 *tail = Qnil;
424 return res;
425 }
426
427 GList*
sgtk_rep_to_list(repv obj,void (* fromscm)(repv,void *))428 sgtk_rep_to_list (repv obj, void (*fromscm)(repv, void*))
429 {
430 GList *res = NULL, *tail;
431
432 if (obj == Qnil || (rep_CONSP(obj)))
433 {
434 while (rep_CONSP(obj))
435 {
436 GList *n = g_list_alloc ();
437 if (res == NULL)
438 res = tail = n;
439 else
440 {
441 g_list_concat (tail, n);
442 tail = n;
443 }
444 if (fromscm)
445 fromscm (rep_CAR (obj), &(n->data));
446 else
447 n->data = NULL;
448 obj = rep_CDR(obj);
449 }
450 }
451 else if (rep_VECTORP(obj))
452 {
453 int len = rep_VECT_LEN (obj), i;
454 repv *elts = rep_VECT(obj)->array;
455 for (i = 0; i < len; i++)
456 {
457 GList *n = g_list_alloc ();
458 if (res == NULL)
459 res = tail = n;
460 else
461 {
462 g_list_concat (tail, n);
463 tail = n;
464 }
465 if (fromscm)
466 fromscm (elts[i], &(n->data));
467 else
468 n->data = NULL;
469 }
470 }
471 return res;
472 }
473
474 void
sgtk_list_finish(GList * list,repv obj,repv (* toscm)(void *))475 sgtk_list_finish (GList *list, repv obj, repv (*toscm)(void*))
476 {
477 if (toscm)
478 {
479 if (obj == Qnil || (rep_CONSP(obj)))
480 {
481 while (rep_CONSP(obj) && list)
482 {
483 rep_CAR (obj) = toscm (list->data);
484 obj = rep_CDR(obj);
485 list = list->next;
486 }
487 }
488 else if (rep_VECTORP(obj))
489 {
490 int len = rep_VECT_LEN (obj), i;
491 repv *elts = rep_VECT(obj)->array;
492 for (i = 0; i < len && list; i++)
493 {
494 elts[i] = toscm (list->data);
495 list = list->next;
496 }
497 }
498 }
499
500 g_list_free (list);
501 }
502
503 sgtk_cvec
sgtk_rep_to_cvec(repv obj,void (* fromscm)(repv,void *),size_t sz)504 sgtk_rep_to_cvec (repv obj, void (*fromscm)(repv, void*), size_t sz)
505 {
506 sgtk_cvec res;
507 int i;
508 char *ptr;
509
510 if (rep_LISTP(obj))
511 {
512 res.count = list_length (obj);
513 res.vec = rep_alloc ((res.count + 1) * sz);
514 if (fromscm)
515 {
516 for (i = 0, ptr = res.vec; i < res.count; i++, ptr += sz)
517 {
518 fromscm (rep_CAR (obj), ptr);
519 obj = rep_CDR(obj);
520 }
521 }
522 else
523 memset (res.vec, 0, res.count * sz);
524 }
525 else if (rep_VECTORP(obj))
526 {
527 repv *elts = rep_VECT(obj)->array;
528 res.count = rep_VECT_LEN (obj);
529 res.vec = rep_alloc ((res.count + 1) * sz);
530 if (fromscm)
531 {
532 for (i = 0, ptr = res.vec; i < res.count; i++, ptr += sz)
533 fromscm (elts[i], ptr);
534 }
535 else
536 memset (res.vec, 0, res.count * sz);
537 }
538 /* make all vectors zero terminated, makes `tvec' easier to implement */
539 memset (((char *)res.vec) + res.count * sz, 0, sz);
540 return res;
541 }
542
543 void
sgtk_cvec_finish(sgtk_cvec * cvec,repv obj,repv (* toscm)(void *),size_t sz)544 sgtk_cvec_finish (sgtk_cvec *cvec, repv obj, repv (*toscm)(void *), size_t sz)
545 {
546 if (toscm)
547 {
548 if (obj == Qnil || (rep_CONSP(obj)))
549 {
550 int i, len = cvec->count;
551 char *ptr;
552
553 for (i = 0, ptr = cvec->vec;
554 i < len && rep_CONSP(obj);
555 i++, ptr += sz, obj = rep_CDR (obj))
556 {
557 rep_CAR (obj) = toscm (ptr);
558 }
559 }
560 else if (rep_VECTORP(obj))
561 {
562 repv *elts = rep_VECT(obj)->array;
563 int len1 = rep_VECT_LEN (obj), len2 = cvec->count, i;
564 char *ptr;
565
566 for (i = 0, ptr = cvec->vec; i < len1 && i < len2; i++, ptr += sz)
567 elts[i] = toscm (ptr);
568 }
569 }
570
571 rep_free (cvec->vec);
572 }
573
574 repv
sgtk_cvec_to_rep(sgtk_cvec * cvec,repv (* toscm)(void *),size_t sz)575 sgtk_cvec_to_rep (sgtk_cvec *cvec, repv (*toscm)(void *), size_t sz)
576 {
577 int len = cvec->count, i;
578 repv obj = Fmake_vector (rep_MAKE_INT(len), Qnil);
579 repv *elts = rep_VECT (obj)->array;
580 char *ptr;
581
582 for (i = 0, ptr = cvec->vec; i < len; i++, ptr += sz)
583 elts[i] = toscm (ptr);
584
585 g_free (cvec->vec);
586 return obj;
587 }
588
589