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 | /* gh_test_repl -- a program that demonstrates starting Guile, adding | |
44 | some privmitive procedures and entering a REPL form C */ | |
45 | ||
46 | #include <stdio.h> | |
47 | #include <math.h> | |
48 | ||
49 | #include <gh.h> | |
50 | ||
51 | SCM c_factorial (SCM s_n); | |
52 | SCM c_sin (SCM s_x); | |
53 | SCM c_vector_test (SCM s_length); | |
54 | ||
55 | /* the gh_enter() routine, the standard entryp point for the gh_ | |
56 | interface, makes you use a separate main function */ | |
57 | void | |
58 | main_prog (int argc, char *argv[]) | |
59 | { | |
60 | SCM cf; | |
61 | ||
62 | gh_eval_str ("(display \"hello guile\n\")"); | |
63 | ||
64 | gh_eval_str ("(define (square x) (* x x))"); | |
65 | gh_eval_str ("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))"); | |
66 | ||
67 | gh_eval_str ("(display (square 9)) (newline)"); | |
68 | gh_eval_str ("(display (fact 100)) (newline)"); | |
69 | ||
70 | gh_eval_str ("(define s \"A string\")"); | |
71 | gh_eval_str ("(define p '(A . pair))"); | |
72 | gh_eval_str ("(display s)"); | |
73 | gh_eval_str ("(display p)"); | |
74 | gh_eval_str ("(display (string? s))"); | |
75 | gh_eval_str ("(display (pair? s))"); | |
76 | ||
77 | /* now define some new primitives in C */ | |
e5eece74 MG |
78 | cf = gh_new_procedure1_0 ("c-factorial", c_factorial); |
79 | gh_new_procedure1_0 ("c-sin", c_sin); | |
80 | gh_new_procedure1_0 ("c-vector-test", c_vector_test); | |
ee2a8b9b JB |
81 | |
82 | /* now try some (eval ...) action from C */ | |
83 | { | |
84 | SCM l = SCM_EOL; | |
85 | l = gh_cons (gh_str02scm ("hello world"), l); | |
86 | l = gh_cons (gh_symbol2scm ("'display"), l); | |
87 | gh_display (l); | |
88 | } | |
89 | ||
90 | { | |
91 | SCM a_string; | |
92 | a_string = gh_str02scm ("A string"); | |
93 | ||
94 | printf ("testing the predicates for pair? and string?\n"); | |
95 | printf ("gh_pair_p(a_string) is %d, gh_string_p(a_string) is %d\n", | |
96 | gh_pair_p (a_string), gh_string_p (a_string)); | |
97 | } | |
98 | ||
99 | printf ("testing the predicates for procedure? and vector?\n"); | |
100 | printf ("gh_procedure_p(c_factorial) is %d, gh_vector_p(c_factorial) is %d\n", | |
101 | gh_procedure_p (cf), gh_vector_p (cf)); | |
e5eece74 | 102 | gh_eval_str("(c-vector-test 200)"); |
ee2a8b9b | 103 | |
5aadf8c1 | 104 | gh_repl (argc, argv); |
ee2a8b9b JB |
105 | } |
106 | ||
107 | int | |
108 | main (int argc, char *argv[]) | |
109 | { | |
110 | gh_enter (argc, argv, main_prog); | |
111 | return 0; | |
112 | } | |
113 | ||
114 | SCM | |
115 | c_factorial (SCM s_n) | |
116 | { | |
117 | int i, n; | |
118 | unsigned long result = 1; | |
119 | ||
120 | n = gh_scm2ulong (s_n); | |
121 | ||
122 | for (i = 1; i <= n; ++i) | |
123 | { | |
124 | result = result * i; | |
125 | } | |
126 | return gh_ulong2scm (result); | |
127 | } | |
128 | ||
129 | /* a sin routine in C, callable from scheme. it is named c_sin() to | |
130 | distinguish it from the default scheme sin function */ | |
131 | SCM | |
132 | c_sin (SCM s_x) | |
133 | { | |
134 | double x = gh_scm2double (s_x); | |
135 | ||
136 | return gh_double2scm (sin (x)); | |
137 | } | |
138 | ||
139 | /* play around with vectors in guile: this routine creates a vector of | |
140 | the given length, initializes it all to zero except element 2 which | |
141 | is set to 1.9. */ | |
142 | SCM | |
143 | c_vector_test (SCM s_length) | |
144 | { | |
145 | SCM xvec; | |
146 | unsigned long c_length; | |
147 | ||
148 | c_length = gh_scm2ulong (s_length); | |
e5eece74 | 149 | printf ("VECTOR test -- requested length for vector: %ld", c_length); |
ee2a8b9b JB |
150 | |
151 | /* create a vector filled witth 0.0 entries */ | |
e5eece74 | 152 | xvec = gh_make_vector (s_length, gh_double2scm (0.0)); |
ee2a8b9b | 153 | /* set the second element in it to some floating point value */ |
5aadf8c1 | 154 | gh_vector_set_x (xvec, gh_int2scm(2), gh_double2scm (1.9)); |
e5eece74 MG |
155 | |
156 | /* I think I can use == because Scheme's doubles should be the same | |
157 | as C doubles, with no operations in between */ | |
158 | if (gh_scm2double(gh_vector_ref (xvec, gh_int2scm(2))) == 1.9) { | |
159 | printf("... PASS\n"); | |
160 | } else { | |
161 | printf("... FAIL\n"); | |
162 | } | |
ee2a8b9b JB |
163 | |
164 | return xvec; | |
165 | } | |
89e00824 ML |
166 | |
167 | /* | |
168 | Local Variables: | |
169 | c-file-style: "gnu" | |
170 | End: | |
171 | */ |