Commit | Line | Data |
---|---|---|
cc6dd1c5 MG |
1 | /* examples/box-dynamic/box.c |
2 | * | |
6e7d5622 | 3 | * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc. |
cc6dd1c5 | 4 | * |
53befeb7 NJ |
5 | * This program is free software; you can redistribute it and/or |
6 | * modify it under the terms of the GNU Lesser General Public License | |
7 | * as published by the Free Software Foundation; either version 3, or | |
8 | * (at your option) any later version. | |
cc6dd1c5 | 9 | * |
53befeb7 NJ |
10 | * This program is distributed in the hope that it will be useful, but |
11 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | * Lesser General Public License for more details. | |
cc6dd1c5 | 14 | * |
53befeb7 NJ |
15 | * You should have received a copy of the GNU Lesser General Public |
16 | * License along with this software; see the file COPYING.LESSER. If | |
17 | * not, write to the Free Software Foundation, Inc., 51 Franklin | |
18 | * Street, Fifth Floor, Boston, MA 02110-1301 USA | |
cc6dd1c5 MG |
19 | */ |
20 | ||
21 | /* Include all needed declarations. */ | |
22 | #include <libguile.h> | |
23 | ||
24 | ||
25 | /* The type code for the newly created smob type will be stored into | |
26 | this variable. It has the prefix `scm_tc16_' to make it usable | |
27 | with the SCM_VALIDATE_SMOB macro below. */ | |
9bf80644 | 28 | static scm_t_bits scm_tc16_box; |
cc6dd1c5 MG |
29 | |
30 | ||
31 | /* This function is responsible for marking all SCM objects included | |
32 | in the smob. */ | |
33 | static SCM | |
34 | mark_box (SCM b) | |
35 | { | |
36 | /* Since we have only one SCM object to protect, we simply return it | |
8779d595 | 37 | and the caller will mark it. */ |
cc6dd1c5 MG |
38 | return SCM_CELL_OBJECT_1 (b); |
39 | } | |
40 | ||
41 | ||
42 | /* Print a textual represenation of the smob to a given port. */ | |
43 | static int | |
44 | print_box (SCM b, SCM port, scm_print_state *pstate) | |
45 | { | |
46 | SCM value = SCM_CELL_OBJECT_1 (b); | |
47 | ||
48 | scm_puts ("#<box ", port); | |
49 | scm_write (value, port); | |
50 | scm_puts (">", port); | |
51 | ||
52 | /* Non-zero means success. */ | |
53 | return 1; | |
54 | } | |
55 | ||
56 | ||
57 | /* This defines the primitve `make-box', which returns a new smob of | |
58 | type `box', initialized to `#f'. */ | |
59 | static SCM | |
60 | #define FUNC_NAME "make-box" | |
61 | make_box (void) | |
62 | { | |
63 | /* This macro creates the new objects, stores the value `#f' into it | |
64 | and returns it to the caller. */ | |
65 | SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F); | |
66 | } | |
67 | #undef FUNC_NAME | |
68 | ||
69 | ||
70 | /* This is the primitive `box-ref' which returns the object stored in | |
71 | the box. */ | |
72 | static SCM | |
73 | box_ref (SCM b) | |
74 | #define FUNC_NAME "box-ref" | |
75 | { | |
76 | /* First, we have to ensure that the user really gave us a box | |
77 | objects. The macro SCM_VALIDATE_SMOB will do all what is needed. | |
78 | The parameters are interpreted as follows: | |
79 | ||
80 | 1: The position of the checked variable in the parameter list. | |
81 | b: The passed parameter. | |
82 | box: Concatenated with the fixed prefix scm_tc16_, names the type | |
83 | code for the expected smob type. */ | |
84 | SCM_VALIDATE_SMOB (1, b, box); | |
85 | ||
86 | /* Fetch the object from the box and return it. */ | |
87 | return SCM_CELL_OBJECT_1 (b); | |
88 | } | |
89 | #undef FUNC_NAME | |
90 | ||
91 | ||
92 | /* Primitive which stores an arbitrary value into a box. */ | |
93 | static SCM | |
94 | box_set_x (SCM b, SCM value) | |
95 | #define FUNC_NAME "box-set!" | |
96 | { | |
97 | SCM_VALIDATE_SMOB (1, b, box); | |
98 | ||
99 | /* Set the cell number 1 of the smob to the given value. */ | |
100 | SCM_SET_CELL_OBJECT_1 (b, value); | |
101 | ||
102 | /* When this constant is returned, the REPL will not print the | |
103 | returned value. All procedures in Guile which are documented as | |
104 | returning `and unspecified value' actually return this value. */ | |
105 | return SCM_UNSPECIFIED; | |
106 | } | |
107 | #undef FUNC_NAME | |
108 | ||
109 | ||
110 | /* Create and initialize the new smob type, and register the | |
111 | primitives with the interpreter library. | |
112 | ||
113 | To be called with (load-extension "libbox" "scm_init_box") | |
114 | from a script. | |
115 | */ | |
116 | void | |
117 | scm_init_box () | |
118 | { | |
119 | scm_tc16_box = scm_make_smob_type ("box", 0); | |
120 | scm_set_smob_mark (scm_tc16_box, mark_box); | |
121 | scm_set_smob_print (scm_tc16_box, print_box); | |
122 | ||
123 | scm_c_define_gsubr ("make-box", 0, 0, 0, make_box); | |
124 | scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x); | |
125 | scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref); | |
126 | } | |
127 | ||
128 | /* End of file. */ |