| 1 | /* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. |
| 2 | * |
| 3 | * This library is free software; you can redistribute it and/or |
| 4 | * modify it under the terms of the GNU Lesser General Public License |
| 5 | * as published by the Free Software Foundation; either version 3 of |
| 6 | * the License, or (at your option) any later version. |
| 7 | * |
| 8 | * This library is distributed in the hope that it will be useful, but |
| 9 | * WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 11 | * Lesser General Public License for more details. |
| 12 | * |
| 13 | * You should have received a copy of the GNU Lesser General Public |
| 14 | * License along with this library; if not, write to the Free Software |
| 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
| 16 | * 02110-1301 USA |
| 17 | */ |
| 18 | |
| 19 | #if HAVE_CONFIG_H |
| 20 | # include <config.h> |
| 21 | #endif |
| 22 | |
| 23 | #include <string.h> |
| 24 | #include "_scm.h" |
| 25 | #include "instructions.h" |
| 26 | #include "modules.h" |
| 27 | #include "programs.h" |
| 28 | #include "procprop.h" /* scm_sym_name */ |
| 29 | #include "srcprop.h" /* scm_sym_filename */ |
| 30 | #include "vm.h" |
| 31 | |
| 32 | \f |
| 33 | static SCM write_program = SCM_BOOL_F; |
| 34 | |
| 35 | SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, |
| 36 | (SCM objcode, SCM objtable, SCM free_variables), |
| 37 | "") |
| 38 | #define FUNC_NAME s_scm_make_program |
| 39 | { |
| 40 | SCM_VALIDATE_OBJCODE (1, objcode); |
| 41 | if (SCM_UNLIKELY (SCM_UNBNDP (objtable))) |
| 42 | objtable = SCM_BOOL_F; |
| 43 | else if (scm_is_true (objtable)) |
| 44 | SCM_VALIDATE_VECTOR (2, objtable); |
| 45 | |
| 46 | if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables)) |
| 47 | { |
| 48 | SCM ret = scm_words (scm_tc7_program, 3); |
| 49 | SCM_SET_CELL_OBJECT_1 (ret, objcode); |
| 50 | SCM_SET_CELL_OBJECT_2 (ret, objtable); |
| 51 | return ret; |
| 52 | } |
| 53 | else |
| 54 | { |
| 55 | size_t i, len; |
| 56 | SCM ret; |
| 57 | SCM_VALIDATE_VECTOR (3, free_variables); |
| 58 | len = scm_c_vector_length (free_variables); |
| 59 | if (SCM_UNLIKELY (len >> 16)) |
| 60 | SCM_OUT_OF_RANGE (3, free_variables); |
| 61 | ret = scm_words (scm_tc7_program | (len<<16), 3 + len); |
| 62 | SCM_SET_CELL_OBJECT_1 (ret, objcode); |
| 63 | SCM_SET_CELL_OBJECT_2 (ret, objtable); |
| 64 | for (i = 0; i < len; i++) |
| 65 | SCM_SET_CELL_OBJECT (ret, 3+i, |
| 66 | SCM_SIMPLE_VECTOR_REF (free_variables, i)); |
| 67 | return ret; |
| 68 | } |
| 69 | } |
| 70 | #undef FUNC_NAME |
| 71 | |
| 72 | void |
| 73 | scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) |
| 74 | { |
| 75 | static int print_error = 0; |
| 76 | |
| 77 | if (scm_is_false (write_program) && scm_module_system_booted_p) |
| 78 | write_program = scm_module_local_variable |
| 79 | (scm_c_resolve_module ("system vm program"), |
| 80 | scm_from_latin1_symbol ("write-program")); |
| 81 | |
| 82 | if (SCM_PROGRAM_IS_CONTINUATION (program)) |
| 83 | { |
| 84 | /* twingliness */ |
| 85 | scm_puts ("#<continuation ", port); |
| 86 | scm_uintprint (SCM_UNPACK (program), 16, port); |
| 87 | scm_putc ('>', port); |
| 88 | } |
| 89 | else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) |
| 90 | { |
| 91 | /* twingliness */ |
| 92 | scm_puts ("#<partial-continuation ", port); |
| 93 | scm_uintprint (SCM_UNPACK (program), 16, port); |
| 94 | scm_putc ('>', port); |
| 95 | } |
| 96 | else if (scm_is_false (write_program) || print_error) |
| 97 | { |
| 98 | scm_puts ("#<program ", port); |
| 99 | scm_uintprint (SCM_UNPACK (program), 16, port); |
| 100 | scm_putc ('>', port); |
| 101 | } |
| 102 | else |
| 103 | { |
| 104 | print_error = 1; |
| 105 | scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); |
| 106 | print_error = 0; |
| 107 | } |
| 108 | } |
| 109 | |
| 110 | \f |
| 111 | /* |
| 112 | * Scheme interface |
| 113 | */ |
| 114 | |
| 115 | SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, |
| 116 | (SCM obj), |
| 117 | "") |
| 118 | #define FUNC_NAME s_scm_program_p |
| 119 | { |
| 120 | return scm_from_bool (SCM_PROGRAM_P (obj)); |
| 121 | } |
| 122 | #undef FUNC_NAME |
| 123 | |
| 124 | SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, |
| 125 | (SCM program), |
| 126 | "") |
| 127 | #define FUNC_NAME s_scm_program_base |
| 128 | { |
| 129 | const struct scm_objcode *c_objcode; |
| 130 | |
| 131 | SCM_VALIDATE_PROGRAM (1, program); |
| 132 | |
| 133 | c_objcode = SCM_PROGRAM_DATA (program); |
| 134 | return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode)); |
| 135 | } |
| 136 | #undef FUNC_NAME |
| 137 | |
| 138 | SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0, |
| 139 | (SCM program), |
| 140 | "") |
| 141 | #define FUNC_NAME s_scm_program_objects |
| 142 | { |
| 143 | SCM_VALIDATE_PROGRAM (1, program); |
| 144 | return SCM_PROGRAM_OBJTABLE (program); |
| 145 | } |
| 146 | #undef FUNC_NAME |
| 147 | |
| 148 | SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0, |
| 149 | (SCM program), |
| 150 | "") |
| 151 | #define FUNC_NAME s_scm_program_module |
| 152 | { |
| 153 | SCM objs, mod; |
| 154 | SCM_VALIDATE_PROGRAM (1, program); |
| 155 | objs = SCM_PROGRAM_OBJTABLE (program); |
| 156 | /* If a program is the result of compiling GLIL to assembly, then if |
| 157 | it has an objtable, the first entry will be a module. But some |
| 158 | programs are hand-coded trampolines, like boot programs and |
| 159 | primitives and the like. So if a program happens to have a |
| 160 | non-module in the first slot of the objtable, assume that it is |
| 161 | such a trampoline, and just return #f for the module. */ |
| 162 | mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F; |
| 163 | return SCM_MODULEP (mod) ? mod : SCM_BOOL_F; |
| 164 | } |
| 165 | #undef FUNC_NAME |
| 166 | |
| 167 | SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, |
| 168 | (SCM program), |
| 169 | "") |
| 170 | #define FUNC_NAME s_scm_program_meta |
| 171 | { |
| 172 | SCM metaobj; |
| 173 | |
| 174 | SCM_VALIDATE_PROGRAM (1, program); |
| 175 | |
| 176 | metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); |
| 177 | if (scm_is_true (metaobj)) |
| 178 | return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program), |
| 179 | SCM_BOOL_F); |
| 180 | else |
| 181 | return SCM_BOOL_F; |
| 182 | } |
| 183 | #undef FUNC_NAME |
| 184 | |
| 185 | SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0, |
| 186 | (SCM program), |
| 187 | "") |
| 188 | #define FUNC_NAME s_scm_program_bindings |
| 189 | { |
| 190 | SCM meta; |
| 191 | |
| 192 | SCM_VALIDATE_PROGRAM (1, program); |
| 193 | |
| 194 | meta = scm_program_meta (program); |
| 195 | if (scm_is_false (meta)) |
| 196 | return SCM_BOOL_F; |
| 197 | |
| 198 | return scm_car (scm_call_0 (meta)); |
| 199 | } |
| 200 | #undef FUNC_NAME |
| 201 | |
| 202 | SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0, |
| 203 | (SCM program), |
| 204 | "") |
| 205 | #define FUNC_NAME s_scm_program_sources |
| 206 | { |
| 207 | SCM meta, sources, ret, filename; |
| 208 | |
| 209 | SCM_VALIDATE_PROGRAM (1, program); |
| 210 | |
| 211 | meta = scm_program_meta (program); |
| 212 | if (scm_is_false (meta)) |
| 213 | return SCM_EOL; |
| 214 | |
| 215 | filename = SCM_BOOL_F; |
| 216 | ret = SCM_EOL; |
| 217 | for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources); |
| 218 | sources = scm_cdr (sources)) |
| 219 | { |
| 220 | SCM x = scm_car (sources); |
| 221 | if (scm_is_pair (x)) |
| 222 | { |
| 223 | if (scm_is_number (scm_car (x))) |
| 224 | { |
| 225 | SCM addr = scm_car (x); |
| 226 | ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)), |
| 227 | ret); |
| 228 | } |
| 229 | else if (scm_is_eq (scm_car (x), scm_sym_filename)) |
| 230 | filename = scm_cdr (x); |
| 231 | } |
| 232 | } |
| 233 | return scm_reverse_x (ret, SCM_UNDEFINED); |
| 234 | } |
| 235 | #undef FUNC_NAME |
| 236 | |
| 237 | SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0, |
| 238 | (SCM program), |
| 239 | "") |
| 240 | #define FUNC_NAME s_scm_program_arities |
| 241 | { |
| 242 | SCM meta; |
| 243 | |
| 244 | SCM_VALIDATE_PROGRAM (1, program); |
| 245 | |
| 246 | meta = scm_program_meta (program); |
| 247 | if (scm_is_false (meta)) |
| 248 | return SCM_BOOL_F; |
| 249 | |
| 250 | return scm_caddr (scm_call_0 (meta)); |
| 251 | } |
| 252 | #undef FUNC_NAME |
| 253 | |
| 254 | SCM |
| 255 | scm_i_program_properties (SCM program) |
| 256 | #define FUNC_NAME "%program-properties" |
| 257 | { |
| 258 | SCM meta; |
| 259 | |
| 260 | SCM_VALIDATE_PROGRAM (1, program); |
| 261 | |
| 262 | meta = scm_program_meta (program); |
| 263 | if (scm_is_false (meta)) |
| 264 | return SCM_EOL; |
| 265 | |
| 266 | return scm_cdddr (scm_call_0 (meta)); |
| 267 | } |
| 268 | #undef FUNC_NAME |
| 269 | |
| 270 | static SCM |
| 271 | program_source (SCM program, size_t ip, SCM sources) |
| 272 | { |
| 273 | SCM source = SCM_BOOL_F; |
| 274 | |
| 275 | while (!scm_is_null (sources) |
| 276 | && scm_to_size_t (scm_caar (sources)) <= ip) |
| 277 | { |
| 278 | source = scm_car (sources); |
| 279 | sources = scm_cdr (sources); |
| 280 | } |
| 281 | |
| 282 | return source; /* (addr . (filename . (line . column))) */ |
| 283 | } |
| 284 | |
| 285 | SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0, |
| 286 | (SCM program, SCM ip, SCM sources), |
| 287 | "") |
| 288 | #define FUNC_NAME s_scm_program_source |
| 289 | { |
| 290 | SCM_VALIDATE_PROGRAM (1, program); |
| 291 | if (SCM_UNBNDP (sources)) |
| 292 | sources = scm_program_sources (program); |
| 293 | return program_source (program, scm_to_size_t (ip), sources); |
| 294 | } |
| 295 | #undef FUNC_NAME |
| 296 | |
| 297 | extern SCM |
| 298 | scm_c_program_source (SCM program, size_t ip) |
| 299 | { |
| 300 | return program_source (program, ip, scm_program_sources (program)); |
| 301 | } |
| 302 | |
| 303 | SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0, |
| 304 | (SCM program), |
| 305 | "") |
| 306 | #define FUNC_NAME s_scm_program_num_free_variables |
| 307 | { |
| 308 | SCM_VALIDATE_PROGRAM (1, program); |
| 309 | return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program)); |
| 310 | } |
| 311 | #undef FUNC_NAME |
| 312 | |
| 313 | SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0, |
| 314 | (SCM program, SCM i), |
| 315 | "") |
| 316 | #define FUNC_NAME s_scm_program_free_variable_ref |
| 317 | { |
| 318 | unsigned long idx; |
| 319 | SCM_VALIDATE_PROGRAM (1, program); |
| 320 | SCM_VALIDATE_ULONG_COPY (2, i, idx); |
| 321 | if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) |
| 322 | SCM_OUT_OF_RANGE (2, i); |
| 323 | return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx); |
| 324 | } |
| 325 | #undef FUNC_NAME |
| 326 | |
| 327 | SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0, |
| 328 | (SCM program, SCM i, SCM x), |
| 329 | "") |
| 330 | #define FUNC_NAME s_scm_program_free_variable_set_x |
| 331 | { |
| 332 | unsigned long idx; |
| 333 | SCM_VALIDATE_PROGRAM (1, program); |
| 334 | SCM_VALIDATE_ULONG_COPY (2, i, idx); |
| 335 | if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) |
| 336 | SCM_OUT_OF_RANGE (2, i); |
| 337 | SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x); |
| 338 | return SCM_UNSPECIFIED; |
| 339 | } |
| 340 | #undef FUNC_NAME |
| 341 | |
| 342 | SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0, |
| 343 | (SCM program), |
| 344 | "Return a @var{program}'s object code.") |
| 345 | #define FUNC_NAME s_scm_program_objcode |
| 346 | { |
| 347 | SCM_VALIDATE_PROGRAM (1, program); |
| 348 | |
| 349 | return SCM_PROGRAM_OBJCODE (program); |
| 350 | } |
| 351 | #undef FUNC_NAME |
| 352 | |
| 353 | /* procedure-minimum-arity support. */ |
| 354 | static void |
| 355 | parse_arity (SCM arity, int *req, int *opt, int *rest) |
| 356 | { |
| 357 | SCM x = scm_cddr (arity); |
| 358 | |
| 359 | if (scm_is_pair (x)) |
| 360 | { |
| 361 | *req = scm_to_int (scm_car (x)); |
| 362 | x = scm_cdr (x); |
| 363 | if (scm_is_pair (x)) |
| 364 | { |
| 365 | *opt = scm_to_int (scm_car (x)); |
| 366 | x = scm_cdr (x); |
| 367 | if (scm_is_pair (x)) |
| 368 | *rest = scm_is_true (scm_car (x)); |
| 369 | else |
| 370 | *rest = 0; |
| 371 | } |
| 372 | else |
| 373 | *opt = *rest = 0; |
| 374 | } |
| 375 | else |
| 376 | *req = *opt = *rest = 0; |
| 377 | } |
| 378 | |
| 379 | int |
| 380 | scm_i_program_arity (SCM program, int *req, int *opt, int *rest) |
| 381 | { |
| 382 | SCM arities; |
| 383 | |
| 384 | arities = scm_program_arities (program); |
| 385 | if (!scm_is_pair (arities)) |
| 386 | return 0; |
| 387 | |
| 388 | parse_arity (scm_car (arities), req, opt, rest); |
| 389 | arities = scm_cdr (arities); |
| 390 | |
| 391 | for (; scm_is_pair (arities); arities = scm_cdr (arities)) |
| 392 | { |
| 393 | int thisreq, thisopt, thisrest; |
| 394 | |
| 395 | parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest); |
| 396 | |
| 397 | if (thisreq < *req |
| 398 | || (thisreq == *req |
| 399 | && ((thisrest && (!*rest || thisopt > *opt)) |
| 400 | || (!thisrest && !*rest && thisopt > *opt)))) |
| 401 | { |
| 402 | *req = thisreq; |
| 403 | *opt = thisopt; |
| 404 | *rest = thisrest; |
| 405 | } |
| 406 | } |
| 407 | |
| 408 | return 1; |
| 409 | } |
| 410 | |
| 411 | \f |
| 412 | |
| 413 | void |
| 414 | scm_bootstrap_programs (void) |
| 415 | { |
| 416 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
| 417 | "scm_init_programs", |
| 418 | (scm_t_extension_init_func)scm_init_programs, NULL); |
| 419 | } |
| 420 | |
| 421 | void |
| 422 | scm_init_programs (void) |
| 423 | { |
| 424 | #ifndef SCM_MAGIC_SNARFER |
| 425 | #include "libguile/programs.x" |
| 426 | #endif |
| 427 | } |
| 428 | |
| 429 | /* |
| 430 | Local Variables: |
| 431 | c-file-style: "gnu" |
| 432 | End: |
| 433 | */ |