Commit | Line | Data |
---|---|---|
ee2a8b9b JB |
1 | /* Copyright (C) 1995,1996,1987 Free Software Foundation, Inc. |
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 | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | */ | |
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 | ||
53 | /* the gh_enter() routine, the standard entryp point for the gh_ | |
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"); | |
78 | printf ("a C string it is now <%s>\n", sym_string); | |
79 | free (sym_string); | |
80 | } | |
81 | ||
82 | /* here result dummy should be a string object */ | |
83 | result_dummy = gh_eval_str ("\"test_string\""); | |
84 | assert (gh_string_p (result_dummy)); | |
85 | { | |
86 | char *s; | |
87 | s = gh_scm2newstr (result_dummy, NULL); | |
88 | printf ("result of converting \"test_string\" from SCM to C is <%s>\n", s); | |
89 | free (s); /* remember to free s!! */ | |
90 | } | |
91 | ||
92 | gh_eval_str ("(define (square x) (* x x))"); | |
93 | gh_eval_str ("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); | |
94 | ||
95 | gh_eval_str ("(display (square 9)) (newline)"); | |
96 | gh_eval_str ("(display (fact 100)) (newline)"); | |
97 | ||
98 | gh_eval_str_with_standard_handler ("(display \"dude!\n\")"); | |
99 | ||
100 | /* in this next line I have a wilful typo: dosplay is not a defined | |
101 | procedure, so it should throw an error */ | |
102 | gh_eval_str_with_standard_handler ("(dosplay \"dude!\n\")"); | |
103 | ||
104 | /* now define some new primitives in C */ | |
105 | cf = gh_new_procedure1_0 ("c_factorial", c_factorial); | |
106 | gh_new_procedure1_0 ("c_sin", c_sin); | |
107 | gh_new_procedure1_0 ("c_vector_test", c_vector_test); | |
108 | ||
109 | /* now try some (eval ...) action from C */ | |
110 | { | |
111 | SCM l = SCM_EOL; | |
112 | l = gh_cons (gh_str02scm ("hello world"), l); | |
113 | l = gh_cons (gh_symbol2scm ("display"), l); | |
114 | printf ("expression is: "); | |
115 | gh_display (l); | |
116 | gh_newline (); | |
117 | /* Don't have a function for evaluating sexps yet. */ | |
118 | } | |
119 | ||
120 | printf ("testing the predicates for procedure? and vector?\n"); | |
121 | printf ("gh_procedure_p(c_factorial) is %d, gh_vector_p(c_factorial) is %d\n", | |
122 | gh_procedure_p (cf), gh_vector_p (cf)); | |
123 | ||
124 | /* Test calling procedures. */ | |
125 | { | |
126 | SCM list = gh_eval_str ("list"); | |
127 | ||
128 | printf ("testing gh_apply\n"); | |
129 | printf ("gh_apply (list, '(1 2)) => "); | |
130 | gh_display (gh_apply (list, gh_cons (gh_int2scm (1), | |
131 | gh_cons (gh_int2scm (2), | |
132 | SCM_EOL)))); | |
133 | gh_newline (); | |
134 | ||
135 | printf ("gh_call0 (list) => "); | |
136 | gh_display (gh_call0 (list)); | |
137 | gh_newline (); | |
138 | ||
139 | printf ("gh_call1 (list, 1) => "); | |
140 | gh_display (gh_call1 (list, gh_int2scm (1))); | |
141 | gh_newline (); | |
142 | ||
143 | printf ("gh_call2 (list, 1, 2) => "); | |
144 | gh_display (gh_call2 (list, gh_int2scm (1), gh_int2scm (2))); | |
145 | gh_newline (); | |
146 | ||
147 | printf ("gh_call3 (list, 1, 2, 3) => "); | |
148 | gh_display (gh_call3 (list, | |
149 | gh_int2scm (1), gh_int2scm (2), gh_int2scm (3))); | |
150 | gh_newline (); | |
151 | } | |
152 | ||
153 | /* now sit in a scheme eval loop: I input the expressions, have | |
154 | guile evaluate them, and then get another expression. */ | |
155 | done = 0; | |
156 | while (!done) | |
157 | { | |
158 | printf ("\n%s> ", argv[0]); | |
159 | if (gets (input_str) == NULL) | |
160 | { | |
161 | done = 1; | |
162 | } | |
163 | else | |
164 | { | |
165 | /* gh_display(gh_eval_str_with_standard_handler(input_str)); */ | |
166 | gh_display (gh_eval_str_with_stack_saving_handler (input_str)); | |
167 | } | |
168 | } | |
169 | } | |
170 | ||
171 | int | |
172 | main (int argc, char *argv[]) | |
173 | { | |
174 | gh_enter (argc, argv, main_prog); | |
175 | return 0; | |
176 | } | |
177 | ||
178 | SCM | |
179 | c_factorial (SCM s_n) | |
180 | { | |
181 | int i, n; | |
182 | unsigned long result = 1; | |
183 | ||
184 | n = gh_scm2ulong (s_n); | |
185 | ||
186 | for (i = 1; i <= n; ++i) | |
187 | { | |
188 | result = result * i; | |
189 | } | |
190 | return gh_ulong2scm (result); | |
191 | } | |
192 | ||
193 | /* a sin routine in C, callable from scheme. it is named c_sin() to | |
194 | distinguish it from the default scheme sin function */ | |
195 | SCM | |
196 | c_sin (SCM s_x) | |
197 | { | |
198 | double x = gh_scm2double (s_x); | |
199 | ||
200 | return gh_double2scm (sin (x)); | |
201 | } | |
202 | ||
203 | /* play around with vectors in guile: this routine creates a vector of | |
204 | the given length, initializes it all to zero except element 2 which | |
205 | is set to 1.9. */ | |
206 | SCM | |
207 | c_vector_test (SCM s_length) | |
208 | { | |
209 | SCM xvec; | |
210 | unsigned long c_length; | |
211 | ||
212 | c_length = gh_scm2ulong (s_length); | |
213 | printf ("requested length for vector: %ld\n", c_length); | |
214 | ||
215 | /* create a vector filled witth 0.0 entries */ | |
216 | xvec = gh_vector (c_length, gh_double2scm (0.0)); | |
217 | /* set the second element in it to some floating point value */ | |
218 | gh_vset (xvec, 2, gh_double2scm (1.9)); | |
219 | ||
220 | return xvec; | |
221 | } |