Mercurial > hg > xemacs-beta

comparison src/print.c @ 207:e45d5e7c476e r20-4b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b2
author cvs
date Mon, 13 Aug 2007 10:03:52 +0200
parents b405438285a2
children 78478c60bfcd
comparison
equal deleted inserted replaced
206:d3e9274cbc4e 207:e45d5e7c476e
852 if (last != len) 852 if (last != len)
853 write_c_string (" ...", printcharfun); 853 write_c_string (" ...", printcharfun);
854 write_c_string (end, printcharfun); 854 write_c_string (end, printcharfun);
855 } 855 }
856 856
857 void
858 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
859 {
860 /* This function can GC */
861 struct gcpro gcpro1, gcpro2;
862
863 /* If print_readably is on, print (quote -foo-) as '-foo-
864 (Yeah, this should really be what print-pretty does, but we
865 don't have the rest of a pretty printer, and this actually
866 has non-negligible impact on size/speed of .elc files.)
867 */
868 if (print_readably &&
869 EQ (XCAR (obj), Qquote) &&
870 CONSP (XCDR (obj)) &&
871 NILP (XCDR (XCDR (obj))))
872 {
873 obj = XCAR (XCDR (obj));
874 GCPRO2 (obj, printcharfun);
875 write_char_internal ("'", printcharfun);
876 UNGCPRO;
877 print_internal (obj, printcharfun, escapeflag);
878 return;
879 }
880
881 GCPRO2 (obj, printcharfun);
882 write_char_internal ("(", printcharfun);
883 {
884 int i = 0;
885 int max = 0;
886
887 if (INTP (Vprint_length))
888 max = XINT (Vprint_length);
889 while (CONSP (obj))
890 {
891 if (i++)
892 write_char_internal (" ", printcharfun);
893 if (max && i > max)
894 {
895 write_c_string ("...", printcharfun);
896 break;
897 }
898 print_internal (Fcar (obj), printcharfun,
899 escapeflag);
900 obj = Fcdr (obj);
901 }
902 }
903 if (!NILP (obj) && !CONSP (obj))
904 {
905 write_c_string (" . ", printcharfun);
906 print_internal (obj, printcharfun, escapeflag);
907 }
908 UNGCPRO;
909 write_char_internal (")", printcharfun);
910 return;
911 }
912
913 void
914 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
915 {
916 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
917 }
918
919 void
920 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
921 {
922 Bytecount size = XSTRING_LENGTH (obj);
923 struct gcpro gcpro1, gcpro2;
924 int max = size;
925 GCPRO2 (obj, printcharfun);
926
927 if (INTP (Vprint_string_length) &&
928 XINT (Vprint_string_length) < max)
929 max = XINT (Vprint_string_length);
930 if (max < 0)
931 max = 0;
932
933 /* !!#### This handles MAX incorrectly for Mule. */
934 if (!escapeflag)
935 {
936 /* This deals with GC-relocation */
937 output_string (printcharfun, 0, obj, 0, max);
938 if (max < size)
939 write_c_string (" ...", printcharfun);
940 }
941 else
942 {
943 Bytecount i;
944 struct Lisp_String *s = XSTRING (obj);
945 Bytecount last = 0;
946
947 write_char_internal ("\"", printcharfun);
948 for (i = 0; i < max; i++)
949 {
950 Bufbyte ch = string_byte (s, i);
951 if (ch == '\"' || ch == '\\'
952 || (ch == '\n' && print_escape_newlines))
953 {
954 if (i > last)
955 {
956 output_string (printcharfun, 0, obj, last,
957 i - last);
958 }
959 if (ch == '\n')
960 {
961 write_c_string ("\\n", printcharfun);
962 }
963 else
964 {
965 write_char_internal ("\\", printcharfun);
966 /* This is correct for Mule because the
967 character is either \ or " */
968 write_char_internal ((char *) (string_data (s) + i),
969 printcharfun);
970 }
971 last = i + 1;
972 }
973 }
974 if (max > last)
975 {
976 output_string (printcharfun, 0, obj, last,
977 max - last);
978 }
979 if (max < size)
980 write_c_string (" ...", printcharfun);
981 write_char_internal ("\"", printcharfun);
982 }
983 UNGCPRO;
984 return;
985 }
986
987
857 static void 988 static void
858 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 989 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
859 int escapeflag) 990 int escapeflag)
860 { 991 {
861 struct lcrecord_header *header = 992 struct lcrecord_header *header =
926 if (print_depth > PRINT_CIRCLE) 1057 if (print_depth > PRINT_CIRCLE)
927 error ("Apparently circular structure being printed"); 1058 error ("Apparently circular structure being printed");
928 1059
929 switch (XTYPE (obj)) 1060 switch (XTYPE (obj))
930 { 1061 {
1062 #ifdef USE_MINIMAL_TAGBITS
1063 case Lisp_Type_Int_Even:
1064 case Lisp_Type_Int_Odd:
1065 #else
931 case Lisp_Type_Int: 1066 case Lisp_Type_Int:
1067 #endif
932 { 1068 {
933 sprintf (buf, "%ld", (long) XINT (obj)); 1069 sprintf (buf, "%ld", (long) XINT (obj));
934 write_c_string (buf, printcharfun); 1070 write_c_string (buf, printcharfun);
935 break; 1071 break;
936 } 1072 }
975 } 1111 }
976 write_c_string (buf, printcharfun); 1112 write_c_string (buf, printcharfun);
977 break; 1113 break;
978 } 1114 }
979 1115
1116 #ifndef LRECORD_STRING
980 case Lisp_Type_String: 1117 case Lisp_Type_String:
981 { 1118 {
982 Bytecount size = XSTRING_LENGTH (obj); 1119 print_string(obj, printcharfun, escapeflag);
983 struct gcpro gcpro1, gcpro2;
984 int max = size;
985 GCPRO2 (obj, printcharfun);
986
987 if (INTP (Vprint_string_length) &&
988 XINT (Vprint_string_length) < max)
989 max = XINT (Vprint_string_length);
990 if (max < 0)
991 max = 0;
992
993 /* !!#### This handles MAX incorrectly for Mule. */
994 if (!escapeflag)
995 {
996 /* This deals with GC-relocation */
997 output_string (printcharfun, 0, obj, 0, max);
998 if (max < size)
999 write_c_string (" ...", printcharfun);
1000 }
1001 else
1002 {
1003 Bytecount i;
1004 struct Lisp_String *s = XSTRING (obj);
1005 Bytecount last = 0;
1006
1007 write_char_internal ("\"", printcharfun);
1008 for (i = 0; i < max; i++)
1009 {
1010 Bufbyte ch = string_byte (s, i);
1011 if (ch == '\"' || ch == '\\'
1012 || (ch == '\n' && print_escape_newlines))
1013 {
1014 if (i > last)
1015 {
1016 output_string (printcharfun, 0, obj, last,
1017 i - last);
1018 }
1019 if (ch == '\n')
1020 {
1021 write_c_string ("\\n", printcharfun);
1022 }
1023 else
1024 {
1025 write_char_internal ("\\", printcharfun);
1026 /* This is correct for Mule because the
1027 character is either \ or " */
1028 write_char_internal ((char *) (string_data (s) + i),
1029 printcharfun);
1030 }
1031 last = i + 1;
1032 }
1033 }
1034 if (max > last)
1035 {
1036 output_string (printcharfun, 0, obj, last,
1037 max - last);
1038 }
1039 if (max < size)
1040 write_c_string (" ...", printcharfun);
1041 write_char_internal ("\"", printcharfun);
1042 }
1043 UNGCPRO;
1044 break; 1120 break;
1045 } 1121 }
1046 1122 #endif /* ! LRECORD_STRING */
1123
1124 #ifndef LRECORD_CONS
1047 case Lisp_Type_Cons: 1125 case Lisp_Type_Cons:
1048 { 1126 {
1049 struct gcpro gcpro1, gcpro2; 1127 struct gcpro gcpro1, gcpro2;
1050 1128
1051 /* If deeper than spec'd depth, print placeholder. */ 1129 /* If deeper than spec'd depth, print placeholder. */
1052 if (INTP (Vprint_level) 1130 if (INTP (Vprint_level)
1053 && print_depth > XINT (Vprint_level)) 1131 && print_depth > XINT (Vprint_level))
1054 { 1132 {
1133 GCPRO2 (obj, printcharfun);
1055 write_c_string ("...", printcharfun); 1134 write_c_string ("...", printcharfun);
1135 UNGCPRO;
1056 break; 1136 break;
1057 } 1137 }
1058 1138
1059 /* If print_readably is on, print (quote -foo-) as '-foo- 1139 print_cons (obj, printcharfun, escapeflag);
1060 (Yeah, this should really be what print-pretty does, but we
1061 don't have the rest of a pretty printer, and this actually
1062 has non-negligible impact on size/speed of .elc files.)
1063 */
1064 if (print_readably &&
1065 EQ (XCAR (obj), Qquote) &&
1066 CONSP (XCDR (obj)) &&
1067 NILP (XCDR (XCDR (obj))))
1068 {
1069 obj = XCAR (XCDR (obj));
1070 GCPRO2 (obj, printcharfun);
1071 write_char_internal ("'", printcharfun);
1072 UNGCPRO;
1073 print_internal (obj, printcharfun, escapeflag);
1074 break;
1075 }
1076
1077 GCPRO2 (obj, printcharfun);
1078 write_char_internal ("(", printcharfun);
1079 {
1080 int i = 0;
1081 int max = 0;
1082
1083 if (INTP (Vprint_length))
1084 max = XINT (Vprint_length);
1085 while (CONSP (obj))
1086 {
1087 if (i++)
1088 write_char_internal (" ", printcharfun);
1089 if (max && i > max)
1090 {
1091 write_c_string ("...", printcharfun);
1092 break;
1093 }
1094 print_internal (Fcar (obj), printcharfun,
1095 escapeflag);
1096 obj = Fcdr (obj);
1097 }
1098 }
1099 if (!NILP (obj) && !CONSP (obj))
1100 {
1101 write_c_string (" . ", printcharfun);
1102 print_internal (obj, printcharfun, escapeflag);
1103 }
1104 UNGCPRO;
1105 write_char_internal (")", printcharfun);
1106 break; 1140 break;
1107 } 1141 }
1142 #endif /* ! LRECORD_CONS */
1108 1143
1109 #ifndef LRECORD_VECTOR 1144 #ifndef LRECORD_VECTOR
1110 case Lisp_Type_Vector: 1145 case Lisp_Type_Vector:
1111 { 1146 {
1147 struct gcpro gcpro1, gcpro2;
1148
1112 /* If deeper than spec'd depth, print placeholder. */ 1149 /* If deeper than spec'd depth, print placeholder. */
1113 if (INTP (Vprint_level) 1150 if (INTP (Vprint_level)
1114 && print_depth > XINT (Vprint_level)) 1151 && print_depth > XINT (Vprint_level))
1115 { 1152 {
1153 GCPRO2 (obj, printcharfun);
1116 write_c_string ("...", printcharfun); 1154 write_c_string ("...", printcharfun);
1155 UNGCPRO;
1117 break; 1156 break;
1118 } 1157 }
1119 1158
1120 /* God intended that this be #(...), you know. */ 1159 /* God intended that this be #(...), you know. */
1121 print_vector_internal ("[", "]", obj, printcharfun, escapeflag); 1160 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
1133 1172
1134 case Lisp_Type_Record: 1173 case Lisp_Type_Record:
1135 { 1174 {
1136 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 1175 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1137 struct gcpro gcpro1, gcpro2; 1176 struct gcpro gcpro1, gcpro2;
1177
1178 #if defined(LRECORD_CONS) || defined(LRECORD_VECTOR)
1179 if (CONSP (obj) || VECTORP(obj))
1180 {
1181 /* If deeper than spec'd depth, print placeholder. */
1182 if (INTP (Vprint_level)
1183 && print_depth > XINT (Vprint_level))
1184 {
1185 GCPRO2 (obj, printcharfun);
1186 write_c_string ("...", printcharfun);
1187 UNGCPRO;
1188 break;
1189 }
1190 }
1191 #endif
1138 1192
1139 GCPRO2 (obj, printcharfun); 1193 GCPRO2 (obj, printcharfun);
1140 if (lheader->implementation->printer) 1194 if (lheader->implementation->printer)
1141 ((lheader->implementation->printer) 1195 ((lheader->implementation->printer)
1142 (obj, printcharfun, escapeflag)); 1196 (obj, printcharfun, escapeflag));
1344 } 1398 }
1345 output_string (printcharfun, 0, nameobj, last, size - last); 1399 output_string (printcharfun, 0, nameobj, last, size - last);
1346 } 1400 }
1347 UNGCPRO; 1401 UNGCPRO;
1348 } 1402 }
1349
1350 1403
1351 int alternate_do_pointer; 1404 int alternate_do_pointer;
1352 char alternate_do_string[5000]; 1405 char alternate_do_string[5000];
1353 1406
1354 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* 1407 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*