← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to src/Guile/Glue/glue.cpp

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/Guile/Glue/glue.cpp
 
1
 
 
2
/******************************************************************************
 
3
* MODULE     : glue.cpp
 
4
* DESCRIPTION: Glue for linking TeXmacs commands to guile
 
5
* COPYRIGHT  : (C) 1999  Joris van der Hoeven
 
6
*******************************************************************************
 
7
* This software falls under the GNU general public license and comes WITHOUT
 
8
* ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for more details.
 
9
* If you don't have this file, write to the Free Software Foundation, Inc.,
 
10
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
11
******************************************************************************/
 
12
 
 
13
#include "Glue/glue.hpp"
 
14
#include "server.hpp"
 
15
#include "connect.hpp"
 
16
#include "convert.hpp"
 
17
#include "file.hpp"
 
18
#include "sys_utils.hpp"
 
19
#include "tex_files.hpp"
 
20
#include "analyze.hpp"
 
21
#include "tm_layout.hpp"
 
22
#include "converter.hpp"
 
23
#include "timer.hpp"
 
24
#include "Freetype/free_type.hpp"
 
25
#include "Freetype/tt_file.hpp"
 
26
#include <string.h>
 
27
#include <libguile.h>
 
28
 
 
29
#define SCM_ARG8 8
 
30
#define SCM_ARG9 9
 
31
 
 
32
#ifdef DOTS_OK
 
33
typedef SCM (*FN)(...);
 
34
#else
 
35
typedef SCM (*FN)();
 
36
#endif
 
37
 
 
38
extern void initialize_glue_basic ();
 
39
extern void initialize_glue_editor ();
 
40
extern void initialize_glue_server ();
 
41
 
 
42
string
 
43
scheme_dialect () {
 
44
#ifdef GUILE_A
 
45
  return "guile-a";
 
46
#else
 
47
#ifdef GUILE_B
 
48
  return "guile-b";
 
49
#else
 
50
  return "unknown";
 
51
#endif
 
52
#endif
 
53
}
 
54
 
 
55
string
 
56
texmacs_version (string which) {
 
57
  if (which == "tgz") return TEXMACS_TGZ;
 
58
  if (which == "rpm") return TEXMACS_RPM;
 
59
  if (which == "stgz") return TEXMACS_STGZ;
 
60
  if (which == "srpm") return TEXMACS_SRPM;
 
61
  return TEXMACS_VERSION;
 
62
}
 
63
 
 
64
/******************************************************************************
 
65
* Direct access to scheme objects
 
66
******************************************************************************/
 
67
 
 
68
#define SCM_ASSERT_OBJECT(flag,arg,rout)
 
69
 
 
70
/*static*/ SCM
 
71
object_to_scm (object obj) {
 
72
  return obj->lookup();
 
73
}
 
74
 
 
75
static object
 
76
scm_to_object (SCM obj) {
 
77
  return object (obj);
 
78
}
 
79
 
 
80
/******************************************************************************
 
81
* Booleans
 
82
******************************************************************************/
 
83
 
 
84
#define SCM_ASSERT_BOOL(flag,arg,rout) \
 
85
  SCM_ASSERT (scm_is_bool (flag), flag, arg, rout)
 
86
 
 
87
SCM
 
88
bool_to_scm (bool flag) {
 
89
  return scm_bool2scm (flag);
 
90
}
 
91
 
 
92
bool
 
93
scm_to_bool (SCM flag) {
 
94
  return scm_scm2bool (flag);
 
95
}
 
96
 
 
97
/******************************************************************************
 
98
* Integers
 
99
******************************************************************************/
 
100
 
 
101
#define SCM_ASSERT_INT(i,arg,rout) \
 
102
  SCM_ASSERT (SCM_INUMP (i), i, arg, rout);
 
103
 
 
104
SCM
 
105
int_to_scm (int i) {
 
106
  return scm_long2scm ((long) i);
 
107
}
 
108
 
 
109
int
 
110
scm_to_int (SCM i) {
 
111
  return (int) scm_scm2long (i);
 
112
}
 
113
 
 
114
/******************************************************************************
 
115
* Floating point numbers
 
116
******************************************************************************/
 
117
 
 
118
#define SCM_ASSERT_DOUBLE(i,arg,rout) \
 
119
  SCM_ASSERT (SCM_REALP (i), i, arg, rout);
 
120
 
 
121
static SCM
 
122
double_to_scm (double i) {
 
123
  return scm_double2scm (i);
 
124
}
 
125
 
 
126
static double
 
127
scm_to_double (SCM i) {
 
128
  return scm_scm2double (i);
 
129
}
 
130
 
 
131
/******************************************************************************
 
132
* Strings
 
133
******************************************************************************/
 
134
 
 
135
#define SCM_MYSTRINGP(s) (SCM_NIMP (s) && SCM_STRINGP (s))
 
136
 
 
137
#define SCM_ASSERT_STRING(s,arg,rout) \
 
138
  SCM_ASSERT (SCM_MYSTRINGP (s), s, arg, rout)
 
139
 
 
140
SCM
 
141
string_to_scm (string s) {
 
142
  char* _s= as_charp (s);
 
143
  SCM r= scm_str2scm (_s, N(s));
 
144
  delete[] _s;
 
145
  return r;
 
146
}
 
147
 
 
148
string
 
149
scm_to_string (SCM s) {
 
150
  guile_str_size_t len_r;
 
151
  char* _r= scm_scm2str (s, &len_r);
 
152
  string r (_r, len_r);
 
153
  free (_r);
 
154
  return r;
 
155
}
 
156
 
 
157
/******************************************************************************
 
158
* Symbols
 
159
******************************************************************************/
 
160
 
 
161
#define SCM_ASSERT_SYMBOL(s,arg,rout) \
 
162
  SCM_ASSERT (SCM_NFALSEP (scm_symbol_p (s)), s, arg, rout)
 
163
 
 
164
static SCM
 
165
symbol_to_scm (string s) {
 
166
  char* _s= as_charp (s);
 
167
  SCM r= scm_symbol2scm (_s);
 
168
  delete[] _s;
 
169
  return r;
 
170
}
 
171
 
 
172
static string
 
173
scm_to_symbol (SCM s) {
 
174
  guile_str_size_t len_r;
 
175
  char* _r= scm_scm2symbol (s, &len_r);
 
176
  string r (_r, len_r);
 
177
  free (_r);
 
178
  return r;
 
179
}
 
180
 
 
181
/******************************************************************************
 
182
* Tree labels
 
183
******************************************************************************/
 
184
 
 
185
#define SCM_ASSERT_TREE_LABEL(p,arg,rout) SCM_ASSERT_SYMBOL(p,arg,rout)
 
186
 
 
187
SCM
 
188
tree_label_to_scm (tree_label l) {
 
189
  string s= as_string (l);
 
190
  return symbol_to_scm (s);
 
191
}
 
192
 
 
193
tree_label
 
194
scm_to_tree_label (SCM p) {
 
195
  string s= scm_to_symbol (p);
 
196
  return make_tree_label (s);
 
197
}
 
198
 
 
199
/******************************************************************************
 
200
* Trees
 
201
******************************************************************************/
 
202
 
 
203
static long tree_tag;
 
204
 
 
205
#define SCM_TREEP(t) \
 
206
  (SCM_NIMP (t) && (((long) SCM_CAR (t)) == tree_tag))
 
207
#define SCM_ASSERT_TREE(t,arg,rout) \
 
208
  SCM_ASSERT (SCM_TREEP (t), t, arg, rout)
 
209
 
 
210
bool
 
211
scm_is_tree (SCM t) {
 
212
  return SCM_TREEP (t);
 
213
}
 
214
 
 
215
SCM
 
216
tree_to_scm (tree t) {
 
217
  SCM tree_smob;
 
218
  SCM_NEWCELL (tree_smob);
 
219
  SCM_SETCDR (tree_smob, (SCM) ((void*) (new tree (t))));
 
220
  SCM_SETCAR (tree_smob, tree_tag);
 
221
  return tree_smob;
 
222
}
 
223
 
 
224
tree
 
225
scm_to_tree (SCM tree_smob) {
 
226
  return *((tree*) SCM_CDR (tree_smob));
 
227
}
 
228
 
 
229
static SCM
 
230
mark_tree (SCM tree_smob) {
 
231
  (void) tree_smob;
 
232
  return SCM_BOOL_F;
 
233
}
 
234
 
 
235
static scm_sizet
 
236
free_tree (SCM tree_smob) {
 
237
  tree *ptr = (tree *) SCM_CDR (tree_smob);
 
238
  delete ptr;
 
239
  return sizeof (tree); // should be replaced by total size of the tree
 
240
}
 
241
 
 
242
static int
 
243
print_tree (SCM tree_smob, SCM port, scm_print_state *pstate) {
 
244
  (void) pstate;
 
245
  tree   t= scm_to_tree (tree_smob);
 
246
  string s= "<tree " * tree_to_texmacs (t) * ">";
 
247
  scm_display (string_to_scm (s), port);
 
248
  return 1;
 
249
}
 
250
 
 
251
static SCM
 
252
cmp_tree (SCM t1, SCM t2) {
 
253
  return scm_bool2scm (scm_to_tree (t1) == scm_to_tree (t2));
 
254
}
 
255
 
 
256
tree
 
257
coerce_string_tree (string s) {
 
258
  return s;
 
259
}
 
260
 
 
261
string
 
262
coerce_tree_string (tree t) {
 
263
  return as_string (t);
 
264
}
 
265
 
 
266
tree
 
267
tree_ref (tree t, int i) {
 
268
  return t[i];
 
269
}
 
270
 
 
271
void
 
272
tree_set (tree t, int i, tree u) {
 
273
  t[i]= u;
 
274
}
 
275
 
 
276
/******************************************************************************
 
277
* Scheme trees
 
278
******************************************************************************/
 
279
 
 
280
#define SCM_ASSERT_SCHEME_TREE(p,arg,rout)
 
281
 
 
282
SCM
 
283
scheme_tree_to_scm (scheme_tree t) {
 
284
  if (is_atomic (t)) {
 
285
    string s= t->label;
 
286
    if (s == "#t") return SCM_BOOL_T;
 
287
    if (s == "#f") return SCM_BOOL_F;
 
288
    if (is_int (s)) return int_to_scm (as_int (s));
 
289
    if ((N(s)>=2) && (s[0]=='\42') && (s[N(s)-1]=='\42'))
 
290
      return string_to_scm (s (1, N(s)-1));
 
291
    return symbol_to_scm (s);
 
292
  }
 
293
  else {
 
294
    int i;
 
295
    SCM p= SCM_NULL;
 
296
    for (i=N(t)-1; i>=0; i--)
 
297
      p= scm_cons (scheme_tree_to_scm (t[i]), p);
 
298
    return p;
 
299
  }
 
300
}
 
301
 
 
302
scheme_tree
 
303
scm_to_scheme_tree (SCM p) {
 
304
  if (scm_is_list (p)) {
 
305
    tree t (TUPLE);
 
306
    while (!scm_is_null (p)) {
 
307
      t << scm_to_scheme_tree (SCM_CAR (p));
 
308
      p= SCM_CDR (p);
 
309
    }
 
310
    return t;
 
311
  }
 
312
  if (gh_symbol_p (p)) return scm_to_symbol (p);
 
313
  if (scm_is_string (p)) return "\"" * scm_to_string (p) * "\"";
 
314
  if (SCM_INUMP (p)) return as_string (scm_to_int (p));
 
315
  if (scm_is_bool (p)) return (scm_to_bool (p)? string ("#t"): string ("#f"));
 
316
  if (scm_is_tree (p)) return tree_to_scheme_tree (scm_to_tree (p));
 
317
  return "?";
 
318
}
 
319
 
 
320
/******************************************************************************
 
321
* TeXmacs trees
 
322
******************************************************************************/
 
323
 
 
324
#define texmacs_tree tree
 
325
#define SCM_ASSERT_TEXMACS_TREE SCM_ASSERT_TREE
 
326
#define texmacs_tree_to_scm tree_to_scm
 
327
#define scm_to_texmacs_tree scm_to_tree
 
328
 
 
329
/******************************************************************************
 
330
* Paths
 
331
******************************************************************************/
 
332
 
 
333
bool
 
334
scm_is_path (SCM p) {
 
335
  if (scm_is_null (p)) return true;
 
336
  else return SCM_INUMP (SCM_CAR (p)) && scm_is_path (SCM_CDR (p));
 
337
}
 
338
 
 
339
#define SCM_ASSERT_PATH(p,arg,rout) \
 
340
  SCM_ASSERT (scm_is_path (p), p, arg, rout)
 
341
 
 
342
SCM
 
343
path_to_scm (path p) {
 
344
  if (nil (p)) return SCM_NULL;
 
345
  else return scm_cons (int_to_scm (p->item), path_to_scm (p->next));
 
346
}
 
347
 
 
348
path
 
349
scm_to_path (SCM p) {
 
350
  if (scm_is_null (p)) return path ();
 
351
  else return path (scm_to_int (SCM_CAR (p)), scm_to_path (SCM_CDR (p)));
 
352
}
 
353
 
 
354
/******************************************************************************
 
355
* Displays
 
356
******************************************************************************/
 
357
 
 
358
static long display_tag;
 
359
 
 
360
#define scm_is_display(t) \
 
361
  (SCM_NIMP (t) && (((long) SCM_CAR (t)) == display_tag))
 
362
#define SCM_ASSERT_DISPLAY(t,arg,rout) \
 
363
  SCM_ASSERT (scm_is_display (t), t, arg, rout)
 
364
 
 
365
/*static*/ SCM
 
366
display_to_scm (display t) {
 
367
  SCM display_smob;
 
368
  SCM_NEWCELL (display_smob);
 
369
  SCM_SETCDR (display_smob, (SCM) ((void*) (new display (t))));
 
370
  SCM_SETCAR (display_smob, display_tag);
 
371
  return display_smob;
 
372
}
 
373
 
 
374
static display
 
375
scm_to_display (SCM display_smob) {
 
376
  return *((display*) SCM_CDR (display_smob));
 
377
}
 
378
 
 
379
static SCM
 
380
mark_display (SCM display_smob) {
 
381
  (void) display_smob;
 
382
  return SCM_BOOL_F;
 
383
}
 
384
 
 
385
static scm_sizet
 
386
free_display (SCM display_smob) {
 
387
  display *ptr = (display *) SCM_CDR (display_smob);
 
388
  delete ptr;
 
389
  return sizeof (display); // should be replaced by total size of the display
 
390
}
 
391
 
 
392
static int
 
393
print_display (SCM display_smob, SCM port, scm_print_state *pstate) {
 
394
  (void) display_smob; (void) pstate;
 
395
  string s= "<display>";
 
396
  scm_display (string_to_scm (s), port);
 
397
  return 1;
 
398
}
 
399
 
 
400
static SCM
 
401
cmp_display (SCM t1, SCM t2) {
 
402
  return scm_bool2scm (scm_to_display (t1) == scm_to_display (t2));
 
403
}
 
404
 
 
405
/******************************************************************************
 
406
* Widgets
 
407
******************************************************************************/
 
408
 
 
409
static long widget_tag;
 
410
 
 
411
#define SCM_WIDGETP(t) \
 
412
  (SCM_NIMP (t) && (((long) SCM_CAR (t)) == widget_tag))
 
413
#define SCM_ASSERT_WIDGET(t,arg,rout) \
 
414
  SCM_ASSERT (scm_is_widget (t), t, arg, rout)
 
415
 
 
416
bool
 
417
scm_is_widget (SCM t) {
 
418
  return SCM_WIDGETP (t);
 
419
}
 
420
 
 
421
static SCM
 
422
widget_to_scm (widget t) {
 
423
  SCM widget_smob;
 
424
  SCM_NEWCELL (widget_smob);
 
425
  SCM_SETCDR (widget_smob, (SCM) ((void*) (new widget (t))));
 
426
  SCM_SETCAR (widget_smob, widget_tag);
 
427
  return widget_smob;
 
428
}
 
429
 
 
430
/*static*/ widget
 
431
scm_to_widget (SCM widget_smob) {
 
432
  return *((widget*) SCM_CDR (widget_smob));
 
433
}
 
434
 
 
435
static SCM
 
436
mark_widget (SCM widget_smob) {
 
437
  (void) widget_smob;
 
438
  return SCM_BOOL_F;
 
439
}
 
440
 
 
441
static scm_sizet
 
442
free_widget (SCM widget_smob) {
 
443
  widget *ptr = (widget *) SCM_CDR (widget_smob);
 
444
  delete ptr;
 
445
  return sizeof (widget); // should be replaced by total size of the widget
 
446
}
 
447
 
 
448
static int
 
449
print_widget (SCM widget_smob, SCM port, scm_print_state *pstate) {
 
450
  (void) widget_smob; (void) pstate;
 
451
  string s= "<widget>";
 
452
  scm_display (string_to_scm (s), port);
 
453
  return 1;
 
454
}
 
455
 
 
456
static SCM
 
457
cmp_widget (SCM t1, SCM t2) {
 
458
  return scm_bool2scm (scm_to_widget (t1) == scm_to_widget (t2));
 
459
}
 
460
 
 
461
/******************************************************************************
 
462
* Widget factory
 
463
******************************************************************************/
 
464
 
 
465
static long make_widget_tag;
 
466
 
 
467
#define SCM_ASSERT_MAKE_WIDGET(t,arg,rout) \
 
468
  SCM_ASSERT (scm_is_make_widget (t), t, arg, rout)
 
469
 
 
470
#define scm_is_make_widget(t) \
 
471
  (SCM_NIMP (t) && (((long) SCM_CAR (t)) == make_widget_tag))
 
472
 
 
473
static SCM
 
474
make_widget_to_scm (make_widget t) {
 
475
  SCM make_widget_smob;
 
476
  SCM_NEWCELL (make_widget_smob);
 
477
  SCM_SETCDR (make_widget_smob, (SCM) ((void*) (new make_widget (t))));
 
478
  SCM_SETCAR (make_widget_smob, make_widget_tag);
 
479
  return make_widget_smob;
 
480
}
 
481
 
 
482
static make_widget
 
483
scm_to_make_widget (SCM make_widget_smob) {
 
484
  return *((make_widget*) SCM_CDR (make_widget_smob));
 
485
}
 
486
 
 
487
static SCM
 
488
mark_make_widget (SCM make_widget_smob) {
 
489
  (void) make_widget_smob;
 
490
  return SCM_BOOL_F;
 
491
}
 
492
 
 
493
static scm_sizet
 
494
free_make_widget (SCM make_widget_smob) {
 
495
  make_widget *ptr = (make_widget *) SCM_CDR (make_widget_smob);
 
496
  delete ptr;
 
497
  // should be replaced by total size of the widget factory
 
498
  return sizeof (make_widget);
 
499
}
 
500
 
 
501
static int
 
502
print_make_widget (SCM make_widget_smob, SCM port, scm_print_state *pstate) {
 
503
  (void) make_widget_smob; (void) pstate;
 
504
  string s= "<make-widget>";
 
505
  scm_display (string_to_scm (s), port);
 
506
  return 1;
 
507
}
 
508
 
 
509
static SCM
 
510
cmp_make_widget (SCM t1, SCM t2) {
 
511
  return scm_bool2scm (scm_to_make_widget (t1) == scm_to_make_widget (t2));
 
512
}
 
513
 
 
514
/******************************************************************************
 
515
* Commands objects
 
516
******************************************************************************/
 
517
 
 
518
static long command_tag;
 
519
 
 
520
#define scm_is_command(t) \
 
521
  (SCM_NIMP (t) && (((long) SCM_CAR (t)) == command_tag))
 
522
#define SCM_ASSERT_COMMAND(t,arg,rout) \
 
523
  SCM_ASSERT (scm_is_command (t), t, arg, rout)
 
524
 
 
525
static SCM
 
526
command_to_scm (command t) {
 
527
  SCM command_smob;
 
528
  SCM_NEWCELL (command_smob);
 
529
  SCM_SETCDR (command_smob, (SCM) ((void*) (new command (t))));
 
530
  SCM_SETCAR (command_smob, command_tag);
 
531
  return command_smob;
 
532
}
 
533
 
 
534
static command
 
535
scm_to_command (SCM command_smob) {
 
536
  return *((command*) SCM_CDR (command_smob));
 
537
}
 
538
 
 
539
static SCM
 
540
mark_command (SCM command_smob) {
 
541
  (void) command_smob;
 
542
  return SCM_BOOL_F;
 
543
}
 
544
 
 
545
static scm_sizet
 
546
free_command (SCM command_smob) {
 
547
  command *ptr = (command *) SCM_CDR (command_smob);
 
548
  delete ptr;
 
549
  return sizeof (command); // should be replaced by total size of the command
 
550
}
 
551
 
 
552
static int
 
553
print_command (SCM command_smob, SCM port, scm_print_state *pstate) {
 
554
  (void) command_smob; (void) pstate;
 
555
  string s= "<command>";
 
556
  scm_display (string_to_scm (s), port);
 
557
  return 1;
 
558
}
 
559
 
 
560
static SCM
 
561
cmp_command (SCM t1, SCM t2) {
 
562
  return scm_bool2scm (scm_to_command (t1) == scm_to_command (t2));
 
563
}
 
564
 
 
565
/******************************************************************************
 
566
* Urls
 
567
******************************************************************************/
 
568
 
 
569
static long url_tag;
 
570
 
 
571
#define SCM_URLP(u) \
 
572
  (SCM_NIMP (u) && (((long) SCM_CAR (u)) == url_tag))
 
573
#define SCM_ASSERT_URL(u,arg,rout) \
 
574
  SCM_ASSERT (scm_is_url (u) || SCM_MYSTRINGP (u), u, arg, rout)
 
575
 
 
576
bool
 
577
scm_is_url (SCM u) {
 
578
  return SCM_URLP (u);
 
579
}
 
580
 
 
581
SCM
 
582
url_to_scm (url u) {
 
583
  SCM url_smob;
 
584
  SCM_NEWCELL (url_smob);
 
585
  SCM_SETCDR (url_smob, (SCM) ((void*) (new url (u))));
 
586
  SCM_SETCAR (url_smob, url_tag);
 
587
  return url_smob;
 
588
}
 
589
 
 
590
url
 
591
scm_to_url (SCM url_smob) {
 
592
  if (scm_is_string (url_smob))
 
593
    return scm_to_string (url_smob);
 
594
  return *((url*) SCM_CDR (url_smob));
 
595
}
 
596
 
 
597
static SCM
 
598
mark_url (SCM url_smob) {
 
599
  (void) url_smob;
 
600
  return SCM_BOOL_F;
 
601
}
 
602
 
 
603
static scm_sizet
 
604
free_url (SCM url_smob) {
 
605
  url *ptr = (url *) SCM_CDR (url_smob);
 
606
  delete ptr;
 
607
  return sizeof (url); // should be replaced by total size of the url
 
608
}
 
609
 
 
610
static int
 
611
print_url (SCM url_smob, SCM port, scm_print_state *pstate) {
 
612
  (void) pstate;
 
613
  url    u= scm_to_url (url_smob);
 
614
  string s= "<url " * as_string (u) * ">";
 
615
  scm_display (string_to_scm (s), port);
 
616
  return 1;
 
617
}
 
618
 
 
619
static SCM
 
620
cmp_url (SCM u1, SCM u2) {
 
621
  return scm_bool2scm (scm_to_url (u1) == scm_to_url (u2));
 
622
}
 
623
 
 
624
url url_concat (url u1, url u2) { return u1 * u2; }
 
625
url url_or (url u1, url u2) { return u1 | u2; }
 
626
void string_save (string s, url u) { (void) save_string (u, s); }
 
627
string string_load (url u) { string s; (void) load_string (u, s); return s; }
 
628
url url_ref (url u, int i) { return u[i]; }
 
629
 
 
630
/******************************************************************************
 
631
* Several array types
 
632
******************************************************************************/
 
633
 
 
634
typedef array<string> array_string;
 
635
typedef array<tree> array_tree;
 
636
typedef array<widget> array_widget;
 
637
 
 
638
static bool
 
639
scm_is_array_string (SCM p) {
 
640
  if (scm_is_null (p)) return true;
 
641
  else return SCM_MYSTRINGP (SCM_CAR (p)) && scm_is_array_string (SCM_CDR (p));
 
642
}
 
643
 
 
644
#define SCM_ASSERT_ARRAY_STRING(p,arg,rout) \
 
645
  SCM_ASSERT (scm_is_array_string (p), p, arg, rout)
 
646
 
 
647
/* static */ SCM
 
648
array_string_to_scm (array<string> a) {
 
649
  int i, n= N(a);
 
650
  SCM p= SCM_NULL;
 
651
  for (i=n-1; i>=0; i--) p= scm_cons (string_to_scm (a[i]), p);
 
652
  return p;
 
653
}
 
654
 
 
655
/* static */ array<string>
 
656
scm_to_array_string (SCM p) {
 
657
  array<string> a;
 
658
  while (!scm_is_null (p)) {
 
659
    a << scm_to_string (SCM_CAR (p));
 
660
    p= SCM_CDR (p);
 
661
  }
 
662
  return a;
 
663
}
 
664
 
 
665
static bool
 
666
scm_is_array_tree (SCM p) {
 
667
  if (scm_is_null (p)) return true;
 
668
  else return SCM_TREEP (SCM_CAR (p)) && scm_is_array_tree (SCM_CDR (p));
 
669
}
 
670
 
 
671
#define SCM_ASSERT_ARRAY_TREE(p,arg,rout) \
 
672
  SCM_ASSERT (scm_is_array_tree (p), p, arg, rout)
 
673
 
 
674
/* static */ SCM
 
675
array_tree_to_scm (array<tree> a) {
 
676
  int i, n= N(a);
 
677
  SCM p= SCM_NULL;
 
678
  for (i=n-1; i>=0; i--) p= scm_cons (tree_to_scm (a[i]), p);
 
679
  return p;
 
680
}
 
681
 
 
682
/* static */ array<tree>
 
683
scm_to_array_tree (SCM p) {
 
684
  array<tree> a;
 
685
  while (!scm_is_null (p)) {
 
686
    a << scm_to_tree (SCM_CAR (p));
 
687
    p= SCM_CDR (p);
 
688
  }
 
689
  return a;
 
690
}
 
691
 
 
692
static bool
 
693
scm_is_array_widget (SCM p) {
 
694
  if (scm_is_null (p)) return true;
 
695
  else return scm_is_widget (SCM_CAR (p)) && scm_is_array_widget (SCM_CDR (p));
 
696
}
 
697
 
 
698
#define SCM_ASSERT_ARRAY_WIDGET(p,arg,rout) \
 
699
  SCM_ASSERT (scm_is_array_widget (p), p, arg, rout)
 
700
 
 
701
/* static */ SCM
 
702
array_widget_to_scm (array<widget> a) {
 
703
  int i, n= N(a);
 
704
  SCM p= SCM_NULL;
 
705
  for (i=n-1; i>=0; i--) p= scm_cons (widget_to_scm (a[i]), p);
 
706
  return p;
 
707
}
 
708
 
 
709
/* static */ array<widget>
 
710
scm_to_array_widget (SCM p) {
 
711
  array<widget> a;
 
712
  while (!scm_is_null (p)) {
 
713
    a << scm_to_widget (SCM_CAR (p));
 
714
    p= SCM_CDR (p);
 
715
  }
 
716
  return a;
 
717
}
 
718
 
 
719
/******************************************************************************
 
720
* Initialization
 
721
******************************************************************************/
 
722
 
 
723
#ifdef SCM_NEWSMOB
 
724
 
 
725
void
 
726
initialize_glue () {
 
727
  tree_tag= scm_make_smob_type ("tree", 0);
 
728
  scm_set_smob_mark (tree_tag, mark_tree);
 
729
  scm_set_smob_free (tree_tag, free_tree);
 
730
  scm_set_smob_print (tree_tag, print_tree);
 
731
  scm_set_smob_equalp (tree_tag, cmp_tree);
 
732
  display_tag= scm_make_smob_type ("display", 0);
 
733
  scm_set_smob_mark (display_tag, mark_display);
 
734
  scm_set_smob_free (display_tag, free_display);
 
735
  scm_set_smob_print (display_tag, print_display);
 
736
  scm_set_smob_equalp (display_tag, cmp_display);
 
737
  widget_tag= scm_make_smob_type ("widget", 0);
 
738
  scm_set_smob_mark (widget_tag, mark_widget);
 
739
  scm_set_smob_free (widget_tag, free_widget);
 
740
  scm_set_smob_print (widget_tag, print_widget);
 
741
  scm_set_smob_equalp (widget_tag, cmp_widget);
 
742
  make_widget_tag= scm_make_smob_type ("make-widget", 0);
 
743
  scm_set_smob_mark (make_widget_tag, mark_make_widget);
 
744
  scm_set_smob_free (make_widget_tag, free_make_widget);
 
745
  scm_set_smob_print (make_widget_tag, print_make_widget);
 
746
  scm_set_smob_equalp (make_widget_tag, cmp_make_widget);
 
747
  command_tag= scm_make_smob_type ("command", 0);
 
748
  scm_set_smob_mark (command_tag, mark_command);
 
749
  scm_set_smob_free (command_tag, free_command);
 
750
  scm_set_smob_print (command_tag, print_command);
 
751
  scm_set_smob_equalp (command_tag, cmp_command);
 
752
  url_tag= scm_make_smob_type ("url", 0);
 
753
  scm_set_smob_mark (url_tag, mark_url);
 
754
  scm_set_smob_free (url_tag, free_url);
 
755
  scm_set_smob_print (url_tag, print_url);
 
756
  scm_set_smob_equalp (url_tag, cmp_url);
 
757
  initialize_glue_basic ();
 
758
  initialize_glue_editor ();
 
759
  initialize_glue_server ();
 
760
}
 
761
 
 
762
#else
 
763
 
 
764
scm_smobfuns tree_smob_funcs = {
 
765
  mark_tree, free_tree, print_tree, cmp_tree
 
766
};
 
767
 
 
768
scm_smobfuns display_smob_funcs = {
 
769
  mark_display, free_display, print_display, cmp_display
 
770
};
 
771
 
 
772
scm_smobfuns widget_smob_funcs = {
 
773
  mark_widget, free_widget, print_widget, cmp_widget
 
774
};
 
775
 
 
776
scm_smobfuns make_widget_smob_funcs = {
 
777
  mark_make_widget, free_make_widget, print_make_widget, cmp_make_widget
 
778
};
 
779
 
 
780
scm_smobfuns command_smob_funcs = {
 
781
  mark_command, free_command, print_command, cmp_command
 
782
};
 
783
 
 
784
scm_smobfuns url_smob_funcs = {
 
785
  mark_url, free_url, print_url, cmp_url
 
786
};
 
787
 
 
788
void
 
789
initialize_glue () {
 
790
  tree_tag= scm_newsmob (&tree_smob_funcs);
 
791
  display_tag= scm_newsmob (&display_smob_funcs);
 
792
  widget_tag= scm_newsmob (&widget_smob_funcs);
 
793
  make_widget_tag= scm_newsmob (&make_widget_smob_funcs);
 
794
  command_tag= scm_newsmob (&command_smob_funcs);
 
795
  url_tag= scm_newsmob (&url_smob_funcs);
 
796
  initialize_glue_basic ();
 
797
  initialize_glue_editor ();
 
798
  initialize_glue_server ();
 
799
}
 
800
 
 
801
#endif