mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
3eeba8d4f5
eval.c (s_expression, s_test, s_body, s_bindings, s_variable, s_clauses, s_formals): Variables now const. * eval.c (promsmob): Now const. * macros.c (macrosmob): Now const. * smob.c (scm_newsmob): Smobfuns argument now points to const. (freecell, flob, bigob): Now const. * dynl.c (scm_make_argv_from_stringlist, scm_coerce_rostring), error.c (scm_error, scm_syserror, scm_syserror_msg, scm_num_overflow, scm_out_of_range, scm_wrong_type_arg, scm_memory_error, scm_misc_error, scm_wta), macros.c (scm_make_synt), feature.c (scm_add_feature), filesys.c (scm_input_waiting_p), gc.c (scm_gc_start, scm_igc, scm_must_malloc, scm_must_realloc), gsubr.c (scm_make_gsubr), numbers.c (scm_num2dbl, scm_two_doubles, scm_num2long, scm_num2long_long, scm_num2ulong), options.c (scm_options), posix.c (scm_convert_exec_args, environ_list_to_c), procs.c (scm_make_subr_opt, scm_make_subr), ramap.c (scm_ramapc), read.c (scm_flush_ws), socket.c (scm_sock_fd_to_port, scm_fill_sockaddr, scm_addr_vector), stime.c (setzone, restorezone, bdtime2c), strop.c (scm_i_index), strports.c (scm_mkstrport), symbols.c (scm_intern_obarray_soft, scm_intern_obarray, scm_intern, scm_intern0, scm_sysintern0_no_module_lookup, scm_sysintern, scm_sysintern0, scm_symbol_value0), unif.c (scm_aind, scm_shap2ra): Argument indicating calling subr, error message text, reason for error, symbol name or feature name are now pointer to const. * snarf.h (SCM_PROC, SCM_PROC1): String variables are now const. * procs.c (scm_init_iprocs): iproc argument now points to const. * pairs.c (cxrs): Now const. * chars.h, error.h, feature.h, filesys.h, gc.h, gsubr.h, macros.h, numbers.h, options.h, procs.h, ramap.h, read.h, smob.h, strports.h, symbols.h, unif.h: Update variable declarations and function prototypes for above changes. * dynl.c, dynl-dld.c, dynl-dl.c, dynl-shl.c (sysdep_dynl_link, sysdep_dynl_unlink, sysdep_dynl_func): Arguments FNAME, SUBR, and SYMB now point to const.
233 lines
6.8 KiB
C
233 lines
6.8 KiB
C
/* Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
|
||
*
|
||
* This program is free software; you can redistribute it and/or modify
|
||
* it under the terms of the GNU General Public License as published by
|
||
* the Free Software Foundation; either version 2, or (at your option)
|
||
* any later version.
|
||
*
|
||
* This program is distributed in the hope that it will be useful,
|
||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
* GNU General Public License for more details.
|
||
*
|
||
* You should have received a copy of the GNU General Public License
|
||
* along with this software; see the file COPYING. If not, write to
|
||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||
* Boston, MA 02111-1307 USA
|
||
*
|
||
* As a special exception, the Free Software Foundation gives permission
|
||
* for additional uses of the text contained in its release of GUILE.
|
||
*
|
||
* The exception is that, if you link the GUILE library with other files
|
||
* to produce an executable, this does not by itself cause the
|
||
* resulting executable to be covered by the GNU General Public License.
|
||
* Your use of that executable is in no way restricted on account of
|
||
* linking the GUILE library code into it.
|
||
*
|
||
* This exception does not however invalidate any other reasons why
|
||
* the executable file might be covered by the GNU General Public License.
|
||
*
|
||
* This exception applies only to the code released by the
|
||
* Free Software Foundation under the name GUILE. If you copy
|
||
* code from other Free Software Foundation releases into a copy of
|
||
* GUILE, as the General Public License permits, the exception does
|
||
* not apply to the code that you add in this way. To avoid misleading
|
||
* anyone as to the status of such modified files, you must delete
|
||
* this exception notice from them.
|
||
*
|
||
* If you write modifications of your own for GUILE, it is your choice
|
||
* whether to permit this exception to apply to your modifications.
|
||
* If you do not wish that, delete this exception notice. */
|
||
|
||
|
||
#include <stdio.h>
|
||
#include "_scm.h"
|
||
|
||
#include "eval.h"
|
||
#include "procprop.h"
|
||
|
||
#include "feature.h"
|
||
|
||
#ifdef HAVE_STRING_H
|
||
#include <string.h>
|
||
#endif
|
||
|
||
|
||
static SCM *scm_loc_features;
|
||
|
||
void
|
||
scm_add_feature (str)
|
||
const char* str;
|
||
{
|
||
*scm_loc_features = scm_cons (SCM_CAR (scm_intern (str, strlen (str))),
|
||
*scm_loc_features);
|
||
}
|
||
|
||
|
||
|
||
SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
|
||
|
||
SCM
|
||
scm_program_arguments ()
|
||
{
|
||
return scm_progargs;
|
||
}
|
||
|
||
/* Set the value returned by program-arguments, given ARGC and ARGV.
|
||
|
||
If FIRST is non-zero, make it the first element; we do this in
|
||
situations where other code (like getopt) has parsed out a few
|
||
arguments, but we still want the script name to be the first
|
||
element. */
|
||
void
|
||
scm_set_program_arguments (argc, argv, first)
|
||
int argc;
|
||
char **argv;
|
||
char *first;
|
||
{
|
||
scm_progargs = scm_makfromstrs (argc, argv);
|
||
if (first)
|
||
scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs);
|
||
}
|
||
|
||
|
||
|
||
/* Hooks */
|
||
|
||
SCM_SYMBOL (scm_sym_hook, "hook");
|
||
|
||
SCM_PROC (s_make_hook, "make-hook", 0, 1, 0, scm_make_hook);
|
||
|
||
SCM
|
||
scm_make_hook (SCM n_args)
|
||
{
|
||
if (SCM_UNBNDP (n_args))
|
||
n_args = SCM_INUM0;
|
||
else
|
||
SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARG1, s_make_hook);
|
||
return scm_cons2 (scm_sym_hook, n_args, SCM_EOL);
|
||
}
|
||
|
||
SCM
|
||
scm_make_named_hook (char* name, int n_args)
|
||
{
|
||
SCM hook = scm_make_hook (SCM_MAKINUM (n_args));
|
||
scm_permanent_object (scm_sysintern (name, hook));
|
||
return hook;
|
||
}
|
||
|
||
SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x);
|
||
|
||
SCM
|
||
scm_add_hook_x (SCM hook, SCM proc, SCM append_p)
|
||
{
|
||
SCM arity, rest;
|
||
int n_args;
|
||
SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
|
||
&& SCM_CAR (hook) == scm_sym_hook
|
||
&& SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
|
||
&& SCM_INUMP (SCM_CADR (hook))
|
||
&& scm_ilength (SCM_CDDR (hook)) >= 0,
|
||
hook, SCM_ARG1, s_add_hook_x);
|
||
SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)),
|
||
proc, SCM_ARG2, s_add_hook_x);
|
||
n_args = SCM_INUM (SCM_CADR (hook));
|
||
if (SCM_INUM (SCM_CAR (arity)) > n_args
|
||
|| (SCM_FALSEP (SCM_CADDR (arity))
|
||
&& (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity))
|
||
< n_args)))
|
||
scm_misc_error (s_add_hook_x,
|
||
"This hook requires %s arguments",
|
||
SCM_LIST1 (SCM_CADR (hook)));
|
||
rest = scm_delq_x (proc, SCM_CDDR (hook));
|
||
SCM_SETCDR (SCM_CDR (hook),
|
||
(!SCM_UNBNDP (append_p) && SCM_NFALSEP (append_p)
|
||
? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc)))
|
||
: scm_cons (proc, rest)));
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
SCM_PROC (s_remove_hook_x, "remove-hook!", 2, 0, 0, scm_remove_hook_x);
|
||
|
||
SCM
|
||
scm_remove_hook_x (SCM hook, SCM thunk)
|
||
{
|
||
SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
|
||
&& SCM_CAR (hook) == scm_sym_hook
|
||
&& SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
|
||
&& SCM_INUMP (SCM_CADR (hook))
|
||
&& scm_ilength (SCM_CDDR (hook)) >= 0,
|
||
hook, SCM_ARG1, s_remove_hook_x);
|
||
SCM_SETCDR (SCM_CDR (hook), scm_delq_x (thunk, SCM_CDDR (hook)));
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
SCM_PROC (s_reset_hook_x, "reset-hook!", 1, 0, 0, scm_reset_hook_x);
|
||
|
||
SCM
|
||
scm_reset_hook_x (SCM hook)
|
||
{
|
||
SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
|
||
&& SCM_CAR (hook) == scm_sym_hook
|
||
&& SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
|
||
&& SCM_INUMP (SCM_CADR (hook))
|
||
&& scm_ilength (SCM_CDDR (hook)) >= 0,
|
||
hook, SCM_ARG1, s_reset_hook_x);
|
||
SCM_SETCDR (SCM_CDR (hook), SCM_EOL);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
SCM_PROC (s_run_hook, "run-hook", 1, 0, 1, scm_run_hook);
|
||
|
||
SCM
|
||
scm_run_hook (SCM hook, SCM args)
|
||
{
|
||
SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
|
||
&& SCM_CAR (hook) == scm_sym_hook
|
||
&& SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
|
||
&& SCM_INUMP (SCM_CADR (hook))
|
||
&& scm_ilength (SCM_CDDR (hook)) >= 0,
|
||
hook, SCM_ARG1, s_run_hook);
|
||
if (SCM_UNBNDP (args))
|
||
args = SCM_EOL;
|
||
if (scm_ilength (args) != SCM_INUM (SCM_CADR (hook)))
|
||
scm_misc_error (s_add_hook_x,
|
||
"This hook requires %s arguments",
|
||
SCM_LIST1 (SCM_CADR (hook)));
|
||
hook = SCM_CDR (hook);
|
||
while (SCM_NIMP (hook = SCM_CDR (hook)))
|
||
scm_apply (SCM_CAR (hook), args, SCM_EOL);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
|
||
|
||
void
|
||
scm_init_feature()
|
||
{
|
||
scm_loc_features = SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL));
|
||
#ifdef SCM_RECKLESS
|
||
scm_add_feature("reckless");
|
||
#endif
|
||
#ifndef _Windows
|
||
scm_add_feature("system");
|
||
#endif
|
||
#ifdef vms
|
||
scm_add_feature(s_ed);
|
||
#endif
|
||
#ifdef SICP
|
||
scm_add_feature("sicp");
|
||
#endif
|
||
#ifndef GO32
|
||
scm_add_feature("char-ready?");
|
||
#endif
|
||
#ifndef CHEAP_CONTINUATIONS
|
||
scm_add_feature ("full-continuation");
|
||
#endif
|
||
#ifdef USE_THREADS
|
||
scm_add_feature ("threads");
|
||
#endif
|
||
|
||
scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT));
|
||
#include "feature.x"
|
||
}
|