libguile/evalext.c

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