1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
/* classes: h_files */
#ifndef GSCMH
#define GSCMH
/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*/
#include "libguile.h"
/* {Locking Out Async Execution (including async GC) and Non-Local Exits}
*/
#define GSCM_DEFER_INTS SCM_DEFER_INTS
#define GSCM_ALLOW_INTS SCM_ALLOW_INTS
/* {Common Constants}
*/
#define GSCM_EOL SCM_EOL
#define GSCM_FALSE SCM_BOOL_F
#define GSCM_TRUE SCM_BOOL_T
#define GSCM_EOL_MARKER SCM_UNDEFINED
#define GSCM_NOT_PASSED SCM_UNDEFINED
#define GSCM_UNSPECIFIED SCM_UNSPECIFIED
/* {Booleans}
*/
#define gscm_bool(CBOOL) ((CBOOL) ? SCM_BOOL_T : SCM_BOOL_F)
#define gscm_2_bool(BOOL) (((BOOL) == SCM_BOOL_F) ? 0 : 1)
/* {Numbers}
*/
#define gscm_ulong scm_ulong2num
#define gscm_long scm_long2num
#define gscm_double(X) scm_makdbl ((X), 0.0)
#define gscm_2_ulong(OBJ) scm_num2ulong((OBJ), (char *)SCM_ARG1, "gscm_2_ulong")
#define gscm_2_long(OBJ) scm_num2long((OBJ), (char *)SCM_ARG1, "gscm_2_long")
#define gscm_2_double(OBJ) scm_num2dbl((OBJ), "gscm_2_double")
/* {Characters}
*/
#define gscm_char(C) SCM_MAKICHR(C)
/* extern int gscm_2_char P((SCM)); */
/* {Strings}
*/
#define gscm_str(SRC, LEN) scm_makfromstr (SRC, LEN, 0)
#define gscm_str0 scm_makfrom0str
/* {Pairs and Lists}
*/
#define gscm_cons scm_cons
#define gscm_list scm_listify
#define gscm_ilength scm_ilength
#define gscm_set_car(OBJ, VAL) \
((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \
? (SCM_CAR(OBJ) = VAL) \
: scm_wta ((OBJ), (char *)SCM_ARG1, "set-car!"))
#define gscm_set_cdr(OBJ, VAL) \
((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \
? (SCM_CDR(OBJ) = VAL) \
: scm_wta ((OBJ), (char *)SCM_ARG1, "set-cdr!"))
#define GSCM_SAFE_CAR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \
? SCM_CAR(X) \
: scm_wta ((X), (char *)SCM_ARG1, "car"))
#define GSCM_SAFE_CDR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \
? SCM_CDR(X) \
: scm_wta ((X), (char *)SCM_ARG1, "cdr"))
#define gscm_car(OBJ) GSCM_SAFE_CAR (OBJ)
#define gscm_cdr(OBJ) GSCM_SAFE_CDR (OBJ)
#define gscm_caar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))
#define gscm_cdar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))
#define gscm_cadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))
#define gscm_cddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))
#define gscm_caaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))
#define gscm_cdaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))
#define gscm_cadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))
#define gscm_cddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))
#define gscm_caadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))
#define gscm_cdadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))
#define gscm_caddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))
#define gscm_cdddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))
#define gscm_caaaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
#define gscm_cdaaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
#define gscm_cadaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
#define gscm_cddaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
#define gscm_caadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
#define gscm_cdadar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
#define gscm_caddar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
#define gscm_cdddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
#define gscm_caaadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
#define gscm_cdaadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
#define gscm_cadadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
#define gscm_cddadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
#define gscm_caaddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
#define gscm_cdaddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
#define gscm_cadddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
#define gscm_cddddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
/* {Symbols}
*/
#define gscm_symbol(STR, LEN) SCM_CAR(scm_intern (STR, LEN))
#define gscm_tmp_symbol(STR, LEN) SCM_CAR(scm_intern_obarray (STR, LEN, SCM_BOOL_F))
/* {Vectors}
*/
#define gscm_vector(N, FILL) scm_make_vector (SCM_MAKINUM(N), (FILL), SCM_UNDEFINED)
#define gscm_vref(V, I) scm_vector_ref ((V), SCM_MAKINUM(I))
#define gscm_vset(V, I, VAL) scm_vector_set_x ((V), SCM_MAKINUM(I), (VAL))
/* {Procedures}
*/
/* extern SCM gscm_make_subr P((SCM (*fn)(), int req, int opt, int varp, char * doc)); */
/* extern SCM gscm_curry P((SCM procedure, SCM first_arg)); */
#define gscm_apply(PROC, ARGS) scm_apply ((PROC), (ARGS), SCM_EOL)
/* {Non-local Exits}
*/
#define gscm_catch(T, TH, H) scm_catch ((T), (TH), (H))
#define gscm_throw(T, V) scm_throw ((T), (V))
#define gscm_dynamic_wind(E, T, L) scm_dynwind ((E), (T), (L))
/* extern void gscm_error P((char * message, SCM args)); */
/* {I/O}
*/
#define gscm_print_obj scm_prin1
#define gscm_putc scm_putc
#define gscm_puts scm_puts
#define gscm_fwrite scm_fwrite
#define gscm_flush scm_flush
extern char * gscm_last_attempted_init_file;
/* {Equivalence}
*/
#define gscm_is_eq(OBJ) (SCM_BOOL_F != scm_eq (OBJ))
#define gscm_is_eqv(OBJ) (SCM_BOOL_F != scm_eqv (OBJ))
#define gscm_is_equal(OBJ) (SCM_BOOL_F != scm_equal_p (OBJ))
/* {Procedure Properties}
*/
#define gscm_procedure_properties scm_procedure_properties
#define gscm_set_procedure_properties_x scm_set_procedure_properties_x
#define gscm_procedure_property scm_procedure_property
#define gscm_set_procedure_property_x scm_set_procedure_property_x
/* {Generic Length Procedure}
*/
#define gscm_obj_length scm_obj_length
/* {Proc Declaration Macro}
*/
#ifndef GSCM_MAGIC_SNARFER
#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \
static char RANAME[]=STR;
#else
#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \
%%% gscm_define_procedure (RANAME, CFN, REQ, OPT, VAR, "")
#endif
#define gscm_define_procedure(NAME, FN, REQ, OPT, VARP, DOC) scm_make_gsubr(name, req, opt, varp, fn)
#define gscm_curry scm_curry
#define gscm_define scm_sysintern
typedef int GSCM_top_level;
/* {Error Returns}
*/
typedef int GSCM_status;
#define GSCM_OK 0
#define GSCM_ERROR 1
#define GSCM_ILLEGALLY_REENTERED 2
#define GSCM_OUT_OF_MEM 3
#define GSCM_ERROR_OPENING_FILE 4
#define GSCM_ERROR_OPENING_INIT_FILE 5
extern GSCM_status gscm_seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str));
extern GSCM_status gscm_seval_file SCM_P ((SCM *answer, GSCM_top_level toplvl, char * file_name));
extern GSCM_status gscm_eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str));
extern GSCM_status gscm_eval_file SCM_P ((char ** answer, GSCM_top_level toplvl, char * file_name));
extern GSCM_status gscm_run_scm SCM_P ((int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(void), char * initfile, char * initcmd));
extern char * gscm_error_msg SCM_P ((int n));
extern SCM gscm_make_subr SCM_P ((SCM (*fn)(), int req, int opt, int varp, char * doc));
extern int gscm_2_char SCM_P ((SCM c));
extern void gscm_2_str SCM_P ((char ** out, int * len_out, SCM * objp));
extern void gscm_error SCM_P ((char * message, SCM args));
extern void scm_init_guile SCM_P ((void));
#endif /* GSCMH */
|