Commit | Line | Data |
---|---|---|
1e598865 | 1 | /* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. |
ee2a8b9b JB |
2 | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
ee2a8b9b JB |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
ee2a8b9b JB |
41 | \f |
42 | ||
43 | #include <stdio.h> | |
44 | #include <math.h> | |
45 | #include <assert.h> | |
46 | ||
47 | #include <gh.h> | |
48 | ||
49 | SCM c_factorial (SCM s_n); | |
50 | SCM c_sin (SCM s_x); | |
51 | SCM c_vector_test (SCM s_length); | |
52 | ||
17bf105d | 53 | /* the gh_enter() routine, the standard entry point for the gh_ |
ee2a8b9b JB |
54 | interface, makes you use a separate main function */ |
55 | void | |
56 | main_prog (int argc, char *argv[]) | |
57 | { | |
58 | int done; | |
59 | char input_str[1000]; | |
60 | SCM cf; | |
61 | SCM result_dummy; | |
62 | ||
63 | result_dummy = gh_eval_str ("(display \"hello guile\n\")"); | |
64 | gh_display (result_dummy); | |
65 | ||
66 | printf ("\ntesting gh_define\n"); | |
67 | gh_define ("test_symbol", gh_double2scm (2.5)); | |
68 | gh_eval_str ("(display test_symbol) (newline)"); | |
69 | ||
70 | /* test playing with symbols */ | |
71 | { | |
72 | SCM sym; | |
73 | char *sym_string; | |
74 | sym = gh_symbol2scm ("a-test-symbol"); | |
75 | sym_string = gh_symbol2newstr (sym, NULL); | |
76 | printf ("the symbol was <%s>; after converting to Scheme and back to\n", | |
77 | "a-test-symbol"); | |
7fee59bd MG |
78 | printf (" a C string it is now <%s>", sym_string); |
79 | if (strcmp("a-test-symbol", sym_string) == 0) { | |
80 | printf("...PASS\n"); | |
81 | } else { | |
82 | printf("...FAIL\n"); | |
83 | } | |
ee2a8b9b JB |
84 | free (sym_string); |
85 | } | |
86 | ||
87 | /* here result dummy should be a string object */ | |
88 | result_dummy = gh_eval_str ("\"test_string\""); | |
89 | assert (gh_string_p (result_dummy)); | |
90 | { | |
91 | char *s; | |
92 | s = gh_scm2newstr (result_dummy, NULL); | |
93 | printf ("result of converting \"test_string\" from SCM to C is <%s>\n", s); | |
94 | free (s); /* remember to free s!! */ | |
95 | } | |
96 | ||
97 | gh_eval_str ("(define (square x) (* x x))"); | |
98 | gh_eval_str ("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); | |
99 | ||
100 | gh_eval_str ("(display (square 9)) (newline)"); | |
101 | gh_eval_str ("(display (fact 100)) (newline)"); | |
102 | ||
103 | gh_eval_str_with_standard_handler ("(display \"dude!\n\")"); | |
104 | ||
7fee59bd | 105 | /* in this next test I have a wilful typo: dosplay is not a defined |
ee2a8b9b | 106 | procedure, so it should throw an error */ |
7fee59bd | 107 | printf("We should now get an error which should be trapped by a handler\n"); |
ee2a8b9b | 108 | gh_eval_str_with_standard_handler ("(dosplay \"dude!\n\")"); |
7fee59bd MG |
109 | printf("now we will display a backtrace of that error; this should not\n"); |
110 | printf(" work because the handler did not save the stack\n"); | |
111 | gh_eval_str("(backtrace)"); | |
112 | ||
113 | /* now do that test with a stack saving handler */ | |
114 | printf("Redo last test with stack-saving handler\n"); | |
115 | gh_eval_str_with_stack_saving_handler ("(dosplay \"dude!\n\")"); | |
116 | printf("now we will display a backtrace of that error; this should work:\n"); | |
117 | gh_eval_str("(backtrace)"); | |
ee2a8b9b JB |
118 | |
119 | /* now define some new primitives in C */ | |
e5eece74 | 120 | cf = gh_new_procedure1_0 ("c-factorial", c_factorial); |
7fee59bd MG |
121 | gh_display (cf); |
122 | gh_newline (); | |
e5eece74 MG |
123 | gh_new_procedure1_0 ("c-sin", c_sin); |
124 | gh_new_procedure1_0 ("c-vector-test", c_vector_test); | |
ee2a8b9b JB |
125 | |
126 | /* now try some (eval ...) action from C */ | |
127 | { | |
128 | SCM l = SCM_EOL; | |
129 | l = gh_cons (gh_str02scm ("hello world"), l); | |
130 | l = gh_cons (gh_symbol2scm ("display"), l); | |
131 | printf ("expression is: "); | |
132 | gh_display (l); | |
133 | gh_newline (); | |
134 | /* Don't have a function for evaluating sexps yet. */ | |
135 | } | |
136 | ||
137 | printf ("testing the predicates for procedure? and vector?\n"); | |
e5eece74 | 138 | printf ("gh_procedure_p(c_factorial)->%d, gh_vector_p(c_factorial)->%d\n", |
ee2a8b9b | 139 | gh_procedure_p (cf), gh_vector_p (cf)); |
e5eece74 | 140 | gh_eval_str("(c-vector-test 200)"); |
ee2a8b9b JB |
141 | |
142 | /* Test calling procedures. */ | |
143 | { | |
144 | SCM list = gh_eval_str ("list"); | |
145 | ||
146 | printf ("testing gh_apply\n"); | |
147 | printf ("gh_apply (list, '(1 2)) => "); | |
148 | gh_display (gh_apply (list, gh_cons (gh_int2scm (1), | |
149 | gh_cons (gh_int2scm (2), | |
150 | SCM_EOL)))); | |
151 | gh_newline (); | |
152 | ||
153 | printf ("gh_call0 (list) => "); | |
154 | gh_display (gh_call0 (list)); | |
155 | gh_newline (); | |
156 | ||
157 | printf ("gh_call1 (list, 1) => "); | |
158 | gh_display (gh_call1 (list, gh_int2scm (1))); | |
159 | gh_newline (); | |
160 | ||
161 | printf ("gh_call2 (list, 1, 2) => "); | |
162 | gh_display (gh_call2 (list, gh_int2scm (1), gh_int2scm (2))); | |
163 | gh_newline (); | |
164 | ||
165 | printf ("gh_call3 (list, 1, 2, 3) => "); | |
166 | gh_display (gh_call3 (list, | |
167 | gh_int2scm (1), gh_int2scm (2), gh_int2scm (3))); | |
168 | gh_newline (); | |
169 | } | |
170 | ||
171 | /* now sit in a scheme eval loop: I input the expressions, have | |
172 | guile evaluate them, and then get another expression. */ | |
173 | done = 0; | |
174 | while (!done) | |
175 | { | |
176 | printf ("\n%s> ", argv[0]); | |
177 | if (gets (input_str) == NULL) | |
178 | { | |
179 | done = 1; | |
180 | } | |
181 | else | |
182 | { | |
183 | /* gh_display(gh_eval_str_with_standard_handler(input_str)); */ | |
184 | gh_display (gh_eval_str_with_stack_saving_handler (input_str)); | |
185 | } | |
186 | } | |
187 | } | |
188 | ||
189 | int | |
190 | main (int argc, char *argv[]) | |
191 | { | |
192 | gh_enter (argc, argv, main_prog); | |
193 | return 0; | |
194 | } | |
195 | ||
196 | SCM | |
197 | c_factorial (SCM s_n) | |
198 | { | |
199 | int i, n; | |
200 | unsigned long result = 1; | |
201 | ||
202 | n = gh_scm2ulong (s_n); | |
203 | ||
204 | for (i = 1; i <= n; ++i) | |
205 | { | |
206 | result = result * i; | |
207 | } | |
208 | return gh_ulong2scm (result); | |
209 | } | |
210 | ||
211 | /* a sin routine in C, callable from scheme. it is named c_sin() to | |
212 | distinguish it from the default scheme sin function */ | |
213 | SCM | |
214 | c_sin (SCM s_x) | |
215 | { | |
216 | double x = gh_scm2double (s_x); | |
217 | ||
218 | return gh_double2scm (sin (x)); | |
219 | } | |
220 | ||
221 | /* play around with vectors in guile: this routine creates a vector of | |
222 | the given length, initializes it all to zero except element 2 which | |
223 | is set to 1.9. */ | |
224 | SCM | |
225 | c_vector_test (SCM s_length) | |
226 | { | |
227 | SCM xvec; | |
228 | unsigned long c_length; | |
229 | ||
230 | c_length = gh_scm2ulong (s_length); | |
7fee59bd | 231 | printf ("VECTOR test (length for vector %ld)", c_length); |
ee2a8b9b JB |
232 | |
233 | /* create a vector filled witth 0.0 entries */ | |
e5eece74 | 234 | xvec = gh_make_vector (s_length, gh_double2scm (0.0)); |
ee2a8b9b | 235 | /* set the second element in it to some floating point value */ |
5aadf8c1 | 236 | gh_vector_set_x (xvec, gh_int2scm(2), gh_double2scm (1.9)); |
e5eece74 MG |
237 | |
238 | /* I think I can use == because Scheme's doubles should be the same | |
239 | as C doubles, with no operations in between */ | |
240 | if (gh_scm2double(gh_vector_ref (xvec, gh_int2scm(2))) == 1.9) { | |
241 | printf("... PASS\n"); | |
242 | } else { | |
243 | printf("... FAIL\n"); | |
244 | } | |
ee2a8b9b JB |
245 | |
246 | return xvec; | |
247 | } | |
89e00824 ML |
248 | |
249 | /* | |
250 | Local Variables: | |
251 | c-file-style: "gnu" | |
252 | End: | |
253 | */ |