libguile/procprop.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "alist.h"
  46 #include "eval.h"
  47
  48 #include "procprop.h"
  49 \f
  50
  51 static SCM
  52 scm_stand_in_scm_proc(proc)
  53      SCM proc;
  54 {
  55   SCM answer;
  56   answer = scm_assoc (proc, scm_stand_in_procs);
  57   if (answer == SCM_BOOL_F)
  58     {
  59       answer = scm_closure (scm_listify (SCM_EOL, SCM_BOOL_F, SCM_UNDEFINED),
  60                             SCM_EOL);
  61       scm_stand_in_procs = scm_cons (scm_cons (proc, answer),
  62                                      scm_stand_in_procs);
  63     }
  64   else
  65     answer = SCM_CDR (answer);
  66   return answer;
  67 }
  68
  69 SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties);
  70
  71 SCM
  72 scm_procedure_properties (proc)
  73      SCM proc;
  74 {
  75   SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
  76               proc, SCM_ARG1, s_procedure_properties);
  77   if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
  78     proc = scm_stand_in_scm_proc(proc);
  79   return SCM_PROCPROPS (proc);
  80 }
  81
  82 SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x);
  83
  84 SCM
  85 scm_set_procedure_properties_x (proc, new_val)
  86      SCM proc;
  87      SCM new_val;
  88 {
  89   if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
  90     proc = scm_stand_in_scm_proc(proc);
  91   SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x);
  92   SCM_SETPROCPROPS (proc, new_val);
  93   return SCM_UNSPECIFIED;
  94 }
  95
  96 SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property);
  97
  98 SCM
  99 scm_procedure_property (p, k)
 100      SCM p;
 101      SCM k;
 102 {
 103   SCM assoc;
 104   if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
 105     p = scm_stand_in_scm_proc(p);
 106   SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)),
 107               p, SCM_ARG1, s_procedure_property);
 108   assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
 109   return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
 110 }
 111
 112 SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x);
 113
 114 SCM
 115 scm_set_procedure_property_x (p, k, v)
 116      SCM p;
 117      SCM k;
 118      SCM v;
 119 {
 120   SCM assoc;
 121   if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
 122     p = scm_stand_in_scm_proc(p);
 123   SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x);
 124   assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
 125   if (SCM_NIMP (assoc))
 126     SCM_SETCDR (assoc, v);
 127   else
 128     SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
 129   return SCM_UNSPECIFIED;
 130 }
 131
 132 \f
 133
 134
 135 void
 136 scm_init_procprop ()
 137 {
 138 #include "procprop.x"
 139 }
 140