40 |
#include "libguile/read.h" |
#include "libguile/read.h" |
41 |
#include "libguile/strports.h" |
#include "libguile/strports.h" |
42 |
#include "libguile/smob.h" |
#include "libguile/smob.h" |
43 |
|
#include "libguile/alist.h" |
44 |
|
|
45 |
#include <stdio.h> |
#include <stdio.h> |
46 |
#include <string.h> |
#include <string.h> |
668 |
abort (); |
abort (); |
669 |
} |
} |
670 |
|
|
671 |
|
SCM |
672 |
|
scm_sym2ovcell_soft (SCM sym, SCM obarray) |
673 |
|
{ |
674 |
|
SCM lsym, z; |
675 |
|
size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); |
676 |
|
|
677 |
|
scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " |
678 |
|
"Use hashtables instead."); |
679 |
|
|
680 |
|
SCM_REDEFER_INTS; |
681 |
|
for (lsym = SCM_VECTOR_REF (obarray, hash); |
682 |
|
SCM_NIMP (lsym); |
683 |
|
lsym = SCM_CDR (lsym)) |
684 |
|
{ |
685 |
|
z = SCM_CAR (lsym); |
686 |
|
if (SCM_EQ_P (SCM_CAR (z), sym)) |
687 |
|
{ |
688 |
|
SCM_REALLOW_INTS; |
689 |
|
return z; |
690 |
|
} |
691 |
|
} |
692 |
|
SCM_REALLOW_INTS; |
693 |
|
return SCM_BOOL_F; |
694 |
|
} |
695 |
|
|
696 |
|
|
697 |
|
SCM |
698 |
|
scm_sym2ovcell (SCM sym, SCM obarray) |
699 |
|
#define FUNC_NAME "scm_sym2ovcell" |
700 |
|
{ |
701 |
|
SCM answer; |
702 |
|
|
703 |
|
scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " |
704 |
|
"Use hashtables instead."); |
705 |
|
|
706 |
|
answer = scm_sym2ovcell_soft (sym, obarray); |
707 |
|
if (!SCM_FALSEP (answer)) |
708 |
|
return answer; |
709 |
|
SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); |
710 |
|
return SCM_UNSPECIFIED; /* not reached */ |
711 |
|
} |
712 |
|
#undef FUNC_NAME |
713 |
|
|
714 |
|
|
715 |
|
/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. |
716 |
|
|
717 |
|
OBARRAY should be a vector of lists, indexed by the name's hash |
718 |
|
value, modulo OBARRAY's length. Each list has the form |
719 |
|
((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the |
720 |
|
value associated with that symbol (in the current module? in the |
721 |
|
system module?) |
722 |
|
|
723 |
|
To "intern" a symbol means: if OBARRAY already contains a symbol by |
724 |
|
that name, return its (SYMBOL . VALUE) pair; otherwise, create a |
725 |
|
new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the |
726 |
|
appropriate list of the OBARRAY, and return the pair. |
727 |
|
|
728 |
|
If softness is non-zero, don't create a symbol if it isn't already |
729 |
|
in OBARRAY; instead, just return #f. |
730 |
|
|
731 |
|
If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and |
732 |
|
return (SYMBOL . SCM_UNDEFINED). */ |
733 |
|
|
734 |
|
|
735 |
|
SCM |
736 |
|
scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness) |
737 |
|
{ |
738 |
|
SCM symbol = scm_mem2symbol (name, len); |
739 |
|
size_t raw_hash = SCM_SYMBOL_HASH (symbol); |
740 |
|
size_t hash; |
741 |
|
SCM lsym; |
742 |
|
|
743 |
|
scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " |
744 |
|
"Use hashtables instead."); |
745 |
|
|
746 |
|
if (SCM_FALSEP (obarray)) |
747 |
|
{ |
748 |
|
if (softness) |
749 |
|
return SCM_BOOL_F; |
750 |
|
else |
751 |
|
return scm_cons (symbol, SCM_UNDEFINED); |
752 |
|
} |
753 |
|
|
754 |
|
hash = raw_hash % SCM_VECTOR_LENGTH (obarray); |
755 |
|
|
756 |
|
for (lsym = SCM_VECTOR_REF(obarray, hash); |
757 |
|
SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) |
758 |
|
{ |
759 |
|
SCM a = SCM_CAR (lsym); |
760 |
|
SCM z = SCM_CAR (a); |
761 |
|
if (SCM_EQ_P (z, symbol)) |
762 |
|
return a; |
763 |
|
} |
764 |
|
|
765 |
|
if (softness) |
766 |
|
{ |
767 |
|
return SCM_BOOL_F; |
768 |
|
} |
769 |
|
else |
770 |
|
{ |
771 |
|
SCM cell = scm_cons (symbol, SCM_UNDEFINED); |
772 |
|
SCM slot = SCM_VECTOR_REF (obarray, hash); |
773 |
|
|
774 |
|
SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot)); |
775 |
|
|
776 |
|
return cell; |
777 |
|
} |
778 |
|
} |
779 |
|
|
780 |
|
|
781 |
|
SCM |
782 |
|
scm_intern_obarray (const char *name,size_t len,SCM obarray) |
783 |
|
{ |
784 |
|
scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " |
785 |
|
"Use hashtables instead."); |
786 |
|
|
787 |
|
return scm_intern_obarray_soft (name, len, obarray, 0); |
788 |
|
} |
789 |
|
|
790 |
|
/* Lookup the value of the symbol named by the nul-terminated string |
791 |
|
NAME in the current module. */ |
792 |
|
SCM |
793 |
|
scm_symbol_value0 (const char *name) |
794 |
|
{ |
795 |
|
scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " |
796 |
|
"Use `scm_lookup' instead."); |
797 |
|
|
798 |
|
return scm_variable_ref (scm_c_lookup (name)); |
799 |
|
} |
800 |
|
|
801 |
|
SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, |
802 |
|
(SCM o, SCM s, SCM softp), |
803 |
|
"Intern a new symbol in @var{obarray}, a symbol table, with name\n" |
804 |
|
"@var{string}.\n\n" |
805 |
|
"If @var{obarray} is @code{#f}, use the default system symbol table. If\n" |
806 |
|
"@var{obarray} is @code{#t}, the symbol should not be interned in any\n" |
807 |
|
"symbol table; merely return the pair (@var{symbol}\n" |
808 |
|
". @var{#<undefined>}).\n\n" |
809 |
|
"The @var{soft?} argument determines whether new symbol table entries\n" |
810 |
|
"should be created when the specified symbol is not already present in\n" |
811 |
|
"@var{obarray}. If @var{soft?} is specified and is a true value, then\n" |
812 |
|
"new entries should not be added for symbols not already present in the\n" |
813 |
|
"table; instead, simply return @code{#f}.") |
814 |
|
#define FUNC_NAME s_scm_string_to_obarray_symbol |
815 |
|
{ |
816 |
|
SCM vcell; |
817 |
|
SCM answer; |
818 |
|
int softness; |
819 |
|
|
820 |
|
SCM_VALIDATE_STRING (2, s); |
821 |
|
SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); |
822 |
|
|
823 |
|
scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " |
824 |
|
"Use hashtables instead."); |
825 |
|
|
826 |
|
softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); |
827 |
|
/* iron out some screwy calling conventions */ |
828 |
|
if (SCM_FALSEP (o)) |
829 |
|
{ |
830 |
|
/* nothing interesting to do here. */ |
831 |
|
return scm_string_to_symbol (s); |
832 |
|
} |
833 |
|
else if (SCM_EQ_P (o, SCM_BOOL_T)) |
834 |
|
o = SCM_BOOL_F; |
835 |
|
|
836 |
|
vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), |
837 |
|
SCM_STRING_LENGTH (s), |
838 |
|
o, |
839 |
|
softness); |
840 |
|
if (SCM_FALSEP (vcell)) |
841 |
|
return vcell; |
842 |
|
answer = SCM_CAR (vcell); |
843 |
|
return answer; |
844 |
|
} |
845 |
|
#undef FUNC_NAME |
846 |
|
|
847 |
|
SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, |
848 |
|
(SCM o, SCM s), |
849 |
|
"Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" |
850 |
|
"unspecified initial value. The symbol table is not modified if a symbol\n" |
851 |
|
"with this name is already present.") |
852 |
|
#define FUNC_NAME s_scm_intern_symbol |
853 |
|
{ |
854 |
|
size_t hval; |
855 |
|
SCM_VALIDATE_SYMBOL (2,s); |
856 |
|
if (SCM_FALSEP (o)) |
857 |
|
return SCM_UNSPECIFIED; |
858 |
|
|
859 |
|
scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " |
860 |
|
"Use hashtables instead."); |
861 |
|
|
862 |
|
SCM_VALIDATE_VECTOR (1,o); |
863 |
|
hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); |
864 |
|
/* If the symbol is already interned, simply return. */ |
865 |
|
SCM_REDEFER_INTS; |
866 |
|
{ |
867 |
|
SCM lsym; |
868 |
|
SCM sym; |
869 |
|
for (lsym = SCM_VECTOR_REF (o, hval); |
870 |
|
SCM_NIMP (lsym); |
871 |
|
lsym = SCM_CDR (lsym)) |
872 |
|
{ |
873 |
|
sym = SCM_CAR (lsym); |
874 |
|
if (SCM_EQ_P (SCM_CAR (sym), s)) |
875 |
|
{ |
876 |
|
SCM_REALLOW_INTS; |
877 |
|
return SCM_UNSPECIFIED; |
878 |
|
} |
879 |
|
} |
880 |
|
SCM_VECTOR_SET (o, hval, |
881 |
|
scm_acons (s, SCM_UNDEFINED, |
882 |
|
SCM_VECTOR_REF (o, hval))); |
883 |
|
} |
884 |
|
SCM_REALLOW_INTS; |
885 |
|
return SCM_UNSPECIFIED; |
886 |
|
} |
887 |
|
#undef FUNC_NAME |
888 |
|
|
889 |
|
SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, |
890 |
|
(SCM o, SCM s), |
891 |
|
"Remove the symbol with name @var{string} from @var{obarray}. This\n" |
892 |
|
"function returns @code{#t} if the symbol was present and @code{#f}\n" |
893 |
|
"otherwise.") |
894 |
|
#define FUNC_NAME s_scm_unintern_symbol |
895 |
|
{ |
896 |
|
size_t hval; |
897 |
|
|
898 |
|
scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " |
899 |
|
"Use hashtables instead."); |
900 |
|
|
901 |
|
SCM_VALIDATE_SYMBOL (2,s); |
902 |
|
if (SCM_FALSEP (o)) |
903 |
|
return SCM_BOOL_F; |
904 |
|
SCM_VALIDATE_VECTOR (1,o); |
905 |
|
hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); |
906 |
|
SCM_DEFER_INTS; |
907 |
|
{ |
908 |
|
SCM lsym_follow; |
909 |
|
SCM lsym; |
910 |
|
SCM sym; |
911 |
|
for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F; |
912 |
|
SCM_NIMP (lsym); |
913 |
|
lsym_follow = lsym, lsym = SCM_CDR (lsym)) |
914 |
|
{ |
915 |
|
sym = SCM_CAR (lsym); |
916 |
|
if (SCM_EQ_P (SCM_CAR (sym), s)) |
917 |
|
{ |
918 |
|
/* Found the symbol to unintern. */ |
919 |
|
if (SCM_FALSEP (lsym_follow)) |
920 |
|
SCM_VECTOR_SET (o, hval, lsym); |
921 |
|
else |
922 |
|
SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); |
923 |
|
SCM_ALLOW_INTS; |
924 |
|
return SCM_BOOL_T; |
925 |
|
} |
926 |
|
} |
927 |
|
} |
928 |
|
SCM_ALLOW_INTS; |
929 |
|
return SCM_BOOL_F; |
930 |
|
} |
931 |
|
#undef FUNC_NAME |
932 |
|
|
933 |
|
SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, |
934 |
|
(SCM o, SCM s), |
935 |
|
"Look up in @var{obarray} the symbol whose name is @var{string}, and\n" |
936 |
|
"return the value to which it is bound. If @var{obarray} is @code{#f},\n" |
937 |
|
"use the global symbol table. If @var{string} is not interned in\n" |
938 |
|
"@var{obarray}, an error is signalled.") |
939 |
|
#define FUNC_NAME s_scm_symbol_binding |
940 |
|
{ |
941 |
|
SCM vcell; |
942 |
|
|
943 |
|
scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " |
944 |
|
"Use hashtables instead."); |
945 |
|
|
946 |
|
SCM_VALIDATE_SYMBOL (2,s); |
947 |
|
if (SCM_FALSEP (o)) |
948 |
|
return scm_variable_ref (scm_lookup (s)); |
949 |
|
SCM_VALIDATE_VECTOR (1,o); |
950 |
|
vcell = scm_sym2ovcell (s, o); |
951 |
|
return SCM_CDR(vcell); |
952 |
|
} |
953 |
|
#undef FUNC_NAME |
954 |
|
|
955 |
|
#if 0 |
956 |
|
SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, |
957 |
|
(SCM o, SCM s), |
958 |
|
"Return @code{#t} if @var{obarray} contains a symbol with name\n" |
959 |
|
"@var{string}, and @code{#f} otherwise.") |
960 |
|
#define FUNC_NAME s_scm_symbol_interned_p |
961 |
|
{ |
962 |
|
SCM vcell; |
963 |
|
|
964 |
|
scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " |
965 |
|
"Use hashtables instead."); |
966 |
|
|
967 |
|
SCM_VALIDATE_SYMBOL (2,s); |
968 |
|
if (SCM_FALSEP (o)) |
969 |
|
{ |
970 |
|
SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); |
971 |
|
if (var != SCM_BOOL_F) |
972 |
|
return SCM_BOOL_T; |
973 |
|
return SCM_BOOL_F; |
974 |
|
} |
975 |
|
SCM_VALIDATE_VECTOR (1,o); |
976 |
|
vcell = scm_sym2ovcell_soft (s, o); |
977 |
|
return (SCM_NIMP(vcell) |
978 |
|
? SCM_BOOL_T |
979 |
|
: SCM_BOOL_F); |
980 |
|
} |
981 |
|
#undef FUNC_NAME |
982 |
|
#endif |
983 |
|
|
984 |
|
SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, |
985 |
|
(SCM o, SCM s), |
986 |
|
"Return @code{#t} if @var{obarray} contains a symbol with name\n" |
987 |
|
"@var{string} bound to a defined value. This differs from\n" |
988 |
|
"@var{symbol-interned?} in that the mere mention of a symbol\n" |
989 |
|
"usually causes it to be interned; @code{symbol-bound?}\n" |
990 |
|
"determines whether a symbol has been given any meaningful\n" |
991 |
|
"value.") |
992 |
|
#define FUNC_NAME s_scm_symbol_bound_p |
993 |
|
{ |
994 |
|
SCM vcell; |
995 |
|
|
996 |
|
scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " |
997 |
|
"Use hashtables instead."); |
998 |
|
|
999 |
|
SCM_VALIDATE_SYMBOL (2,s); |
1000 |
|
if (SCM_FALSEP (o)) |
1001 |
|
{ |
1002 |
|
SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); |
1003 |
|
if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var))) |
1004 |
|
return SCM_BOOL_T; |
1005 |
|
return SCM_BOOL_F; |
1006 |
|
} |
1007 |
|
SCM_VALIDATE_VECTOR (1,o); |
1008 |
|
vcell = scm_sym2ovcell_soft (s, o); |
1009 |
|
return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); |
1010 |
|
} |
1011 |
|
#undef FUNC_NAME |
1012 |
|
|
1013 |
|
|
1014 |
|
SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, |
1015 |
|
(SCM o, SCM s, SCM v), |
1016 |
|
"Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" |
1017 |
|
"it to @var{value}. An error is signalled if @var{string} is not present\n" |
1018 |
|
"in @var{obarray}.") |
1019 |
|
#define FUNC_NAME s_scm_symbol_set_x |
1020 |
|
{ |
1021 |
|
SCM vcell; |
1022 |
|
|
1023 |
|
scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " |
1024 |
|
"Use the module system instead."); |
1025 |
|
|
1026 |
|
SCM_VALIDATE_SYMBOL (2,s); |
1027 |
|
if (SCM_FALSEP (o)) |
1028 |
|
{ |
1029 |
|
scm_define (s, v); |
1030 |
|
return SCM_UNSPECIFIED; |
1031 |
|
} |
1032 |
|
SCM_VALIDATE_VECTOR (1,o); |
1033 |
|
vcell = scm_sym2ovcell (s, o); |
1034 |
|
SCM_SETCDR (vcell, v); |
1035 |
|
return SCM_UNSPECIFIED; |
1036 |
|
} |
1037 |
|
#undef FUNC_NAME |
1038 |
|
|
1039 |
|
#define MAX_PREFIX_LENGTH 30 |
1040 |
|
|
1041 |
|
static int gentemp_counter; |
1042 |
|
|
1043 |
|
SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, |
1044 |
|
(SCM prefix, SCM obarray), |
1045 |
|
"Create a new symbol with a name unique in an obarray.\n" |
1046 |
|
"The name is constructed from an optional string @var{prefix}\n" |
1047 |
|
"and a counter value. The default prefix is @code{t}. The\n" |
1048 |
|
"@var{obarray} is specified as a second optional argument.\n" |
1049 |
|
"Default is the system obarray where all normal symbols are\n" |
1050 |
|
"interned. The counter is increased by 1 at each\n" |
1051 |
|
"call. There is no provision for resetting the counter.") |
1052 |
|
#define FUNC_NAME s_scm_gentemp |
1053 |
|
{ |
1054 |
|
char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; |
1055 |
|
char *name = buf; |
1056 |
|
int len, n_digits; |
1057 |
|
|
1058 |
|
scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " |
1059 |
|
"Use `gensym' instead."); |
1060 |
|
|
1061 |
|
if (SCM_UNBNDP (prefix)) |
1062 |
|
{ |
1063 |
|
name[0] = 't'; |
1064 |
|
len = 1; |
1065 |
|
} |
1066 |
|
else |
1067 |
|
{ |
1068 |
|
SCM_VALIDATE_STRING (1, prefix); |
1069 |
|
len = SCM_STRING_LENGTH (prefix); |
1070 |
|
if (len > MAX_PREFIX_LENGTH) |
1071 |
|
name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); |
1072 |
|
strncpy (name, SCM_STRING_CHARS (prefix), len); |
1073 |
|
} |
1074 |
|
|
1075 |
|
if (SCM_UNBNDP (obarray)) |
1076 |
|
return scm_gensym (prefix); |
1077 |
|
else |
1078 |
|
SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), |
1079 |
|
obarray, |
1080 |
|
SCM_ARG2, |
1081 |
|
FUNC_NAME); |
1082 |
|
do |
1083 |
|
n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); |
1084 |
|
while (!SCM_FALSEP (scm_intern_obarray_soft (name, |
1085 |
|
len + n_digits, |
1086 |
|
obarray, |
1087 |
|
1))); |
1088 |
|
{ |
1089 |
|
SCM vcell = scm_intern_obarray_soft (name, |
1090 |
|
len + n_digits, |
1091 |
|
obarray, |
1092 |
|
0); |
1093 |
|
if (name != buf) |
1094 |
|
scm_must_free (name); |
1095 |
|
return SCM_CAR (vcell); |
1096 |
|
} |
1097 |
|
} |
1098 |
|
#undef FUNC_NAME |
1099 |
|
|
1100 |
void |
void |
1101 |
scm_i_init_deprecated () |
scm_i_init_deprecated () |
1102 |
{ |
{ |