libguile/evalext.c

   1 /* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 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 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25 #include "libguile/eval.h"
  26 #include "libguile/fluids.h"
  27 #include "libguile/modules.h"
  28
  29 #include "libguile/validate.h"
  30 #include "libguile/evalext.h"
  31
  32 SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
  33             (SCM sym, SCM env),
  34             "Return @code{#t} if @var{sym} is defined in the lexical "
  35             "environment @var{env}.  When @var{env} is not specified, "
  36             "look in the top-level environment as defined by the "
  37             "current module.")
  38 #define FUNC_NAME s_scm_defined_p
  39 {
  40   SCM var;
  41
  42   SCM_VALIDATE_SYMBOL (1, sym);
  43
  44   if (SCM_UNBNDP (env))
  45     var = scm_sym2var (sym, scm_current_module_lookup_closure (),
  46                          SCM_BOOL_F);
  47   else
  48     {
  49       SCM frames = env;
  50       register SCM b;
  51       for (; SCM_NIMP (frames); frames = SCM_CDR (frames))
  52         {
  53           SCM_ASSERT (scm_is_pair (frames), env, SCM_ARG2, FUNC_NAME);
  54           b = SCM_CAR (frames);
  55           if (scm_is_true (scm_procedure_p (b)))
  56             break;
  57           SCM_ASSERT (scm_is_pair (b), env, SCM_ARG2, FUNC_NAME);
  58           for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b))
  59             {
  60               if (!scm_is_pair (b))
  61                 {
  62                   if (scm_is_eq (b, sym))
  63                     return SCM_BOOL_T;
  64                   else
  65                     break;
  66                 }
  67               if (scm_is_eq (SCM_CAR (b), sym))
  68                 return SCM_BOOL_T;
  69             }
  70         }
  71       var = scm_sym2var (sym,
  72                          SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F,
  73                          SCM_BOOL_F);
  74     }
  75
  76   return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var))
  77           ? SCM_BOOL_F
  78           : SCM_BOOL_T);
  79 }
  80 #undef FUNC_NAME
  81
  82
  83 SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
  84
  85
  86 SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
  87             (SCM obj),
  88             "Return #t for objects which Guile considers self-evaluating")
  89 #define FUNC_NAME s_scm_self_evaluating_p
  90 {
  91   switch (SCM_ITAG3 (obj))
  92     {
  93     case scm_tc3_int_1:
  94     case scm_tc3_int_2:
  95       /* inum */
  96       return SCM_BOOL_T;
  97     case scm_tc3_imm24:
  98         /* characters, booleans, other immediates */
  99       return scm_from_bool (!scm_is_null (obj));
 100     case scm_tc3_cons:
 101       switch (SCM_TYP7 (obj))
 102         {
 103         case scm_tcs_closures:
 104         case scm_tc7_vector:
 105         case scm_tc7_wvect:
 106         case scm_tc7_number:
 107         case scm_tc7_string:
 108         case scm_tc7_smob:
 109         case scm_tc7_cclo:
 110         case scm_tc7_pws:
 111         case scm_tcs_subrs:
 112         case scm_tcs_struct:
 113           return SCM_BOOL_T;
 114         default:
 115           return SCM_BOOL_F;
 116         }
 117     }
 118   SCM_MISC_ERROR ("Internal error: Object ~S has unknown type",
 119                   scm_list_1 (obj));
 120   return SCM_UNSPECIFIED; /* never reached */
 121 }
 122 #undef FUNC_NAME
 123
 124 void
 125 scm_init_evalext ()
 126 {
 127 #include "libguile/evalext.x"
 128 }
 129
 130 /*
 131   Local Variables:
 132   c-file-style: "gnu"
 133   End:
 134 */