60 |
#define WRITEC_NEWLINE(strm) (writec_stream('\n',strm),per_line_prefix(strm)) |
#define WRITEC_NEWLINE(strm) (writec_stream('\n',strm),per_line_prefix(strm)) |
61 |
#endif |
#endif |
62 |
|
|
63 |
#define to_be_escaped(c) \ |
#define READ_TABLE_CASE (Vreadtable->s.s_dbind->rt.rt_case) |
|
(standard_readtable->rt.rt_self[(c)&0377].rte_chattrib \ |
|
|
!= cat_constituent || \ |
|
|
isLower((c)&0377) || (c) == ':') |
|
|
|
|
64 |
|
|
65 |
#define mod(x) ((x)%Q_SIZE) |
#define mod(x) ((x)%Q_SIZE) |
66 |
|
|
683 |
@(return `pprint_dispatch(obj,table)`) |
@(return `pprint_dispatch(obj,table)`) |
684 |
@) |
@) |
685 |
|
|
686 |
|
|
687 |
|
static int |
688 |
|
constant_case(object x) { |
689 |
|
|
690 |
|
fixnum i,j=0,jj; |
691 |
|
for (i=0;i<x->s.s_fillp;i++,j=jj ? jj : j) { |
692 |
|
jj=isUpper(x->s.s_self[i]) ? 1 : (isLower(x->s.s_self[i]) ? -1 : 0); |
693 |
|
if (j*jj==-1) |
694 |
|
return 0; |
695 |
|
} |
696 |
|
return j; |
697 |
|
|
698 |
|
} |
699 |
|
|
700 |
|
static int |
701 |
|
needs_escape (object x) { |
702 |
|
|
703 |
|
fixnum i; |
704 |
|
|
705 |
|
if (x->s.s_fillp && *x->s.s_self==' ') |
706 |
|
return 1; |
707 |
|
|
708 |
|
for (i=0;i<x->s.s_fillp;i++) |
709 |
|
switch(x->s.s_self[i]) { |
710 |
|
case '(': |
711 |
|
case ')': |
712 |
|
case ':': |
713 |
|
case '`': |
714 |
|
case '\'': |
715 |
|
case '"': |
716 |
|
case ';': |
717 |
|
case ',': |
718 |
|
case '\n': |
719 |
|
return 1; |
720 |
|
default: |
721 |
|
break; |
722 |
|
} |
723 |
|
|
724 |
|
if (!PRINTescape) |
725 |
|
return 0; |
726 |
|
if (READ_TABLE_CASE==sKupcase) { |
727 |
|
for (i=0;i<x->s.s_fillp;i++) |
728 |
|
if (isLower(x->s.s_self[i])) |
729 |
|
return 1; |
730 |
|
} else if (READ_TABLE_CASE==sKdowncase) { |
731 |
|
for (i=0;i<x->s.s_fillp;i++) |
732 |
|
if (isUpper(x->s.s_self[i])) |
733 |
|
return 1; |
734 |
|
} |
735 |
|
|
736 |
|
return !x->s.s_fillp; |
737 |
|
|
738 |
|
} |
739 |
|
|
740 |
|
static int |
741 |
|
all_dots(object x) { |
742 |
|
|
743 |
|
fixnum i; |
744 |
|
|
745 |
|
for (i=0;i<x->s.s_fillp && x->s.s_self[i]=='.';i++); |
746 |
|
|
747 |
|
return i==x->s.s_fillp; |
748 |
|
|
749 |
|
} |
750 |
|
|
751 |
|
#define convertible_upper(c) ((READ_TABLE_CASE==sKupcase||READ_TABLE_CASE==sKinvert)&& isUpper(c)) |
752 |
|
#define convertible_lower(c) ((READ_TABLE_CASE==sKdowncase||READ_TABLE_CASE==sKinvert)&& isLower(c)) |
753 |
|
|
754 |
|
static void |
755 |
|
print_symbol_name_body(object x,int pp) { |
756 |
|
|
757 |
|
int i,j,fc,tc,lw,k,cc; |
758 |
|
|
759 |
|
cc=constant_case(x); |
760 |
|
k=needs_escape(x); |
761 |
|
pp=pp && (potential_number_p(x, PRINTbase)||all_dots(x)) ? 0 : 1; |
762 |
|
|
763 |
|
if (k) |
764 |
|
write_ch('|'); |
765 |
|
|
766 |
|
for (lw=i=0;i<x->s.s_fillp;i++) { |
767 |
|
j = x->s.s_self[i]; |
768 |
|
if (PRINTescape && (j == '|' || j == '\\')) |
769 |
|
write_ch('\\'); |
770 |
|
fc=convertible_upper(j) ? 1 : |
771 |
|
(convertible_lower(j) ? -1 : 0); |
772 |
|
tc=(READ_TABLE_CASE==sKinvert ? -cc : |
773 |
|
(PRINTcase == sKupcase ? 1 : |
774 |
|
(PRINTcase == sKdowncase ? -1 : |
775 |
|
(PRINTcase == sKcapitalize ? (i==lw ? 1 : -1) : 0)))); |
776 |
|
if (ispunct(j)||isspace(j)) lw=i+1; |
777 |
|
tc*=pp*fc*fc; |
778 |
|
fc=tc*tc*(tc-fc)>>1; |
779 |
|
j+=fc*('A'-'a'); |
780 |
|
write_ch(j); |
781 |
|
|
782 |
|
} |
783 |
|
|
784 |
|
if (k) |
785 |
|
write_ch('|'); |
786 |
|
|
787 |
|
} |
788 |
|
|
789 |
void |
void |
790 |
write_object(x, level) |
write_object(x, level) |
791 |
object x; |
object x; |
792 |
int level; |
int level; |
793 |
{ |
{ |
794 |
object r, y; |
object r, y; |
795 |
int i, j, k,lw; |
int i, j, k; |
796 |
object *vp; |
object *vp; |
797 |
object ppfun; |
object ppfun; |
798 |
|
|
993 |
break; |
break; |
994 |
|
|
995 |
case t_symbol: |
case t_symbol: |
996 |
if (!PRINTescape) { |
{ |
|
for (lw = 0,i = 0; i < x->s.s_fillp; i++) { |
|
|
j = x->s.s_self[i]; |
|
|
if (isUpper(j)) { |
|
|
if (PRINTcase == sKdowncase || |
|
|
(PRINTcase == sKcapitalize && i!=lw)) |
|
|
j += 'a' - 'A'; |
|
|
} else if (!isLower(j)) |
|
|
lw = i + 1; |
|
|
write_ch(j); |
|
997 |
|
|
998 |
} |
if (PRINTescape) { |
999 |
break; |
if (x->s.s_hpack == Cnil) { |
1000 |
} |
if (PRINTcircle) { |
1001 |
if (x->s.s_hpack == Cnil) { |
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) |
1002 |
if (PRINTcircle) { |
if (x == *vp) { |
1003 |
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) |
if (vp[1] != Cnil) { |
1004 |
if (x == *vp) { |
write_ch('#'); |
1005 |
if (vp[1] != Cnil) { |
write_decimal((vp-PRINTvs_top)/2+1); |
1006 |
write_ch('#'); |
write_ch('#'); |
1007 |
write_decimal((vp-PRINTvs_top)/2+1); |
return; |
1008 |
write_ch('#'); |
} else { |
1009 |
return; |
write_ch('#'); |
1010 |
} else { |
write_decimal((vp-PRINTvs_top)/2+1); |
1011 |
write_ch('#'); |
write_ch('='); |
1012 |
write_decimal((vp-PRINTvs_top)/2+1); |
vp[1] = Ct; |
1013 |
write_ch('='); |
} |
|
vp[1] = Ct; |
|
|
} |
|
|
} |
|
1014 |
} |
} |
|
if (PRINTgensym) |
|
|
write_str("#:"); |
|
|
} else if (x->s.s_hpack == keyword_package) |
|
|
write_ch(':'); |
|
|
else if (PRINTpackage||find_symbol(x,current_package())!=x |
|
|
|| intern_flag == 0) |
|
|
{ |
|
|
k = 0; |
|
|
for (i = 0; |
|
|
i < x->s.s_hpack->p.p_name->st.st_fillp; |
|
|
i++) { |
|
|
j = x->s.s_hpack->p.p_name |
|
|
->st.st_self[i]; |
|
|
if (to_be_escaped(j)) |
|
|
k++; |
|
|
} |
|
|
if (k > 0) |
|
|
write_ch('|'); |
|
|
for (lw = 0, i = 0; |
|
|
i < x->s.s_hpack->p.p_name->st.st_fillp; |
|
|
i++) { |
|
|
j = x->s.s_hpack->p.p_name |
|
|
->st.st_self[i]; |
|
|
if (j == '|' || j == '\\') |
|
|
write_ch('\\'); |
|
|
if (k == 0) { |
|
|
if (isUpper(j)) { |
|
|
if (PRINTcase == sKdowncase || |
|
|
(PRINTcase == sKcapitalize && i!=lw)) |
|
|
j += 'a' - 'A'; |
|
|
} else if (!isLower(j)) |
|
|
lw = i + 1; |
|
|
} |
|
|
write_ch(j); |
|
|
} |
|
|
if (k > 0) |
|
|
write_ch('|'); |
|
|
if (find_symbol(x, x->s.s_hpack) != x) |
|
|
error("can't print symbol"); |
|
|
if (PRINTpackage || intern_flag == INTERNAL) |
|
|
write_str("::"); |
|
|
else if (intern_flag == EXTERNAL) |
|
|
write_ch(':'); |
|
|
else |
|
|
FEerror("Pathological symbol --- cannot print.", 0); |
|
|
} |
|
|
k = 0; |
|
|
if (potential_number_p(x, PRINTbase)) |
|
|
k++; |
|
|
for (i = 0; i < x->s.s_fillp; i++) { |
|
|
j = x->s.s_self[i]; |
|
|
if (to_be_escaped(j)) |
|
|
k++; |
|
1015 |
} |
} |
1016 |
for (i = 0; i < x->s.s_fillp; i++) |
if (PRINTgensym) |
1017 |
if (x->s.s_self[i] != '.') |
write_str("#:"); |
1018 |
goto NOT_DOT; |
} else if (x->s.s_hpack == keyword_package) { |
1019 |
k++; |
write_ch(':'); |
1020 |
|
} else if (PRINTpackage||find_symbol(x,current_package())!=x || !intern_flag) { |
1021 |
NOT_DOT: |
|
1022 |
if (k > 0) |
print_symbol_name_body(x->s.s_hpack->p.p_name,0); |
1023 |
write_ch('|'); |
|
1024 |
for (lw = 0, i = 0; i < x->s.s_fillp; i++) { |
if (find_symbol(x, x->s.s_hpack) != x) |
1025 |
j = x->s.s_self[i]; |
error("can't print symbol"); |
1026 |
if (j == '|' || j == '\\') |
if (PRINTpackage || intern_flag == INTERNAL) |
1027 |
write_ch('\\'); |
write_str("::"); |
1028 |
if (k == 0) { |
else if (intern_flag == EXTERNAL) |
1029 |
if (isUpper(j)) { |
write_ch(':'); |
1030 |
if (PRINTcase == sKdowncase || |
else |
1031 |
(PRINTcase == sKcapitalize && i != lw)) |
FEerror("Pathological symbol --- cannot print.", 0); |
1032 |
j += 'a' - 'A'; |
|
1033 |
} else if (!isLower(j)) |
} |
|
lw = i + 1; |
|
|
} |
|
|
write_ch(j); |
|
|
} |
|
|
if (k > 0) |
|
|
write_ch('|'); |
|
|
break; |
|
1034 |
|
|
1035 |
|
} |
1036 |
|
print_symbol_name_body(x,1); |
1037 |
|
break; |
1038 |
|
} |
1039 |
case t_array: |
case t_array: |
1040 |
{ |
{ |
1041 |
int subscripts[ARANKLIM]; |
int subscripts[ARANKLIM]; |