2
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4
This file is part of GNU Common Lisp, herein referred to as GCL
6
GCL is free software; you can redistribute it and/or modify it under
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
8
the Free Software Foundation; either version 2, or (at your option)
11
GCL is distributed in the hope that it will be useful, but WITHOUT
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
14
License for more details.
16
You should have received a copy of the GNU Library General Public License
17
along with GCL; see the file COPYING. If not, write to the Free Software
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
30
#define LINE_LENGTH line_length
33
#ifndef WRITEC_NEWLINE
34
#define WRITEC_NEWLINE(strm) (writec_stream('\n',strm))
37
#define to_be_escaped(c) \
38
(standard_readtable->rt.rt_self[(c)&0377].rte_chattrib \
39
!= cat_constituent || \
40
isLower((c)&0377) || (c) == ':')
43
#define mod(x) ((x)%Q_SIZE)
46
#define queue printStructBufp->p_queue
47
#define indent_stack printStructBufp->p_indent_stack
48
#define qh printStructBufp->p_qh
49
#define qt printStructBufp->p_qt
50
#define qc printStructBufp->p_qc
51
#define isp printStructBufp->p_isp
52
#define iisp printStructBufp->p_iisp
55
object sSAprint_packageA;
56
object sSAprint_structureA;
59
/* bool RPINcircle; ??typo?? */
63
#define write_ch (*write_ch_fun)
68
#define SET_INDENT 0402
73
extern object coerce_stream(object,int);
85
FEerror("Can't pretty-print.", 0);
92
flush_queue(int force)
94
int c, i, j, k, l, i0;
101
else if (c == UNMARK)
103
else if (c == SET_INDENT)
104
indent_stack[isp] = file_column(PRINTstream);
105
else if (c == INDENT) {
107
} else if (c == INDENT1) {
108
i = file_column(PRINTstream)-indent_stack[isp];
109
if (i < 8 && indent_stack[isp] < LINE_LENGTH/2) {
110
writec_stream(' ', PRINTstream);
112
= file_column(PRINTstream);
114
if (indent_stack[isp] < LINE_LENGTH/2) {
116
= indent_stack[isp-1] + 4;
120
} else if (c == INDENT2) {
121
indent_stack[isp] = indent_stack[isp-1] + 2;
124
writec_stream(c, PRINTstream);
131
k = LINE_LENGTH - 1 - file_column(PRINTstream);
132
for (i = 1, j = 0, l = 1; l > 0 && i < qc && j < k; i++) {
133
c = queue[mod(qh + i)];
136
else if (c == UNMARK)
138
else if (c == INDENT || c == INDENT1 || c == INDENT2)
145
if (i == qc && !force)
149
if (++isp >= IS_SIZE-1)
150
FEerror("Can't pretty-print.", 0);
151
indent_stack[isp++] = file_column(PRINTstream);
152
indent_stack[isp] = indent_stack[isp-1];
158
k = LINE_LENGTH - 1 - file_column(PRINTstream);
159
for (i0 = 0, i = 1, j = 0, l = 1; i < qc && j < k; i++) {
160
c = queue[mod(qh + i)];
163
else if (c == UNMARK) {
166
} else if (c == SET_INDENT) {
169
} else if (c == INDENT) {
173
} else if (c == INDENT1) {
177
} else if (c == INDENT2) {
186
if (i == qc && !force)
197
WRITEC_NEWLINE(PRINTstream);
198
for (i = indent_stack[isp]; i > 0; --i)
199
writec_stream(' ', PRINTstream);
204
for (j = 0; j < i; j++) {
206
if (c == INDENT || c == INDENT1 || c == INDENT2)
207
writec_stream(' ', PRINTstream);
209
writec_stream(c, PRINTstream);
217
writec_PRINTstream(c)
220
if (c == INDENT || c == INDENT1)
221
writec_stream(' ', PRINTstream);
223
writec_stream(c, PRINTstream);
254
write_decimal1(i/10);
255
write_ch(i%10 + '0');
266
for (j = 8*sizeof(i)-4; j >= 0; j -= 4) {
271
write_ch('a' + k - 10);
280
else if (PRINTbase == 8)
282
else if (PRINTbase == 16)
284
else if (PRINTbase >= 10) {
286
write_ch(PRINTbase/10+'0');
287
write_ch(PRINTbase%10+'0');
291
write_ch(PRINTbase+'0');
296
/* The floating point precision required to make the most-positive-long-float
297
printed expression readable. If this is too small, then the rounded
298
off fraction, may be too big to read */
304
object sSAprint_nansA;
307
edit_double(n, d, sp, s, ep)
314
char *p, buff[FPRC + 9];
318
/* if ((*((int *)&d +HIND) & 0x7ff00000) == 0x7ff00000)*/
320
{if (sSAprint_nansA->s.s_dbind !=Cnil)
326
FEerror("Can't print a non-number.",
329
sprintf(buff, "%*.*e",FPRC+8,FPRC, d);
330
if (buff[FPRC+3] != 'e') {
331
sprintf(buff, "%*.*e",FPRC+7,FPRC,d);
332
*ep = (buff[FPRC+5]-'0')*10 + (buff[FPRC+6]-'0');
334
*ep = (buff[FPRC+5]-'0')*100 +
335
(buff[FPRC+6]-'0')*10 + (buff[FPRC+7]-'0');
340
sprintf(buff, "%*.*e",FPRC+7,FPRC, d);
341
/* "-D.MMMMMMMMMMMMMMMe+EE" */
342
/* 0123456789012345678901 */
346
*ep = (buff[FPRC+5]-'0')*10 + (buff[FPRC+6]-'0');
349
if (buff[FPRC+4] == '-')
355
for (i = n - 1; i >= 0; --i)
367
for (i = 0; i < n; i++)
370
for (i = 0; i < FPRC+1; i++)
379
write_double(d, e, shortp)
392
edit_double(n, d, &sign, buff, &exp);
393
if (sign==2) {write_str("#<");
400
if (-3 <= exp && exp < 7) {
405
for (i = 0; i < exp; i++)
408
if (buff[n-1] != '0')
410
if (exp == 0 && n == 0)
412
for (i = 0; i < n; i++)
416
for (i = 0; i < exp; i++)
428
if (buff[n-1] != '0')
439
if (buff[n-1] != '0')
441
for (i = 2; i < n; i++)
444
if (exp == 0 && e == 0)
457
call_structure_print_function(x, level)
465
void (*wf)(int) = write_ch_fun;
467
object *vt = PRINTvs_top;
468
object *vl = PRINTvs_limit;
469
bool e = PRINTescape;
470
bool ra = PRINTreadably;
473
bool c = PRINTcircle;
474
bool p = PRINTpretty;
476
int ln = PRINTlength;
477
bool g = PRINTgensym;
492
if (interrupt_flag) {
493
interrupt_flag = FALSE;
497
terminal_interrupt(TRUE);
510
/* No need to save the queue, since it is flushed.
511
for (i = 0; i < Q_SIZE; i++)
515
for (i = 0; i <= isp; i++)
516
ois[i] = indent_stack[i];
518
vs_push(PRINTstream);
521
vs_push(make_fixnum(level));
523
old_bds_top = bds_top;
524
bds_bind(sLAprint_escapeA, PRINTescape?Ct:Cnil);
525
bds_bind(sLAprint_readablyA, PRINTreadably?Ct:Cnil);
526
bds_bind(sLAprint_radixA, PRINTradix?Ct:Cnil);
527
bds_bind(sLAprint_baseA, make_fixnum(PRINTbase));
528
bds_bind(sLAprint_circleA, PRINTcircle?Ct:Cnil);
529
bds_bind(sLAprint_prettyA, PRINTpretty?Ct:Cnil);
530
bds_bind(sLAprint_levelA, PRINTlevel<0?Cnil:make_fixnum(PRINTlevel));
531
bds_bind(sLAprint_lengthA, PRINTlength<0?Cnil:make_fixnum(PRINTlength));
532
bds_bind(sLAprint_gensymA, PRINTgensym?Ct:Cnil);
533
bds_bind(sLAprint_arrayA, PRINTarray?Ct:Cnil);
534
bds_bind(sLAprint_caseA, PRINTcase);
536
frs_push(FRS_PROTECT, Cnil);
542
ifuncall3(S_DATA(x->str.str_def)->print_function,
543
x, PRINTstream, vs_head);
549
bds_unwind(old_bds_top);
552
for (i = 0; i < Q_SIZE; i++)
556
for (i = 0; i <= oisp; i++)
557
indent_stack[i] = ois[i];
566
PRINTstream = vs_pop;
584
unwind(nlj_fr, nlj_tag);
588
object coerce_big_to_string(object,int);
591
potential_number_p(object,int);
594
write_object(x, level)
605
write_str("#<OBJNULL>");
608
if (x->d.m == FREE) {
609
write_str("#<FREE OBJECT ");
615
switch (type_of(x)) {
621
if (PRINTradix && PRINTbase != 10)
626
if (PRINTradix && PRINTbase == 10)
632
if (i == MOST_NEG_FIXNUM) {
633
x = fixnum_add(1,(MOST_POSITIVE_FIXNUM));
637
write_object(x, level);
640
if (PRINTradix && PRINTbase == 10)
647
for (vsp = vs_top; i != 0; i /= PRINTbase)
648
vs_push(code_char(digit_weight(i%PRINTbase,
651
write_ch(char_code((vs_pop)));
652
if (PRINTradix && PRINTbase == 10)
659
if (PRINTradix && PRINTbase != 10)
664
if (PRINTradix && PRINTbase == 10)
668
{ object s = coerce_big_to_string(x,PRINTbase);
670
while (i<s->ust.ust_fillp) { write_ch(s->ust.ust_self[i++]); }
672
if (PRINTradix && PRINTbase == 10)
681
write_object(x->rat.rat_num, level);
683
write_object(x->rat.rat_den, level);
686
write_object(x->rat.rat_num, level);
688
write_object(x->rat.rat_den, level);
693
r = symbol_value(sLAread_default_float_formatA);
694
if (r == sLshort_float)
695
write_double((double)sf(x), 0, TRUE);
697
write_double((double)sf(x), 'S', TRUE);
701
r = symbol_value(sLAread_default_float_formatA);
702
if (r == sLsingle_float ||
703
r == sLlong_float || r == sLdouble_float)
704
write_double(lf(x), 0, FALSE);
706
write_double(lf(x), 'F', FALSE);
711
write_object(x->cmp.cmp_real, level);
713
write_object(x->cmp.cmp_imag, level);
719
write_ch(char_code(x));
723
switch (char_code(x)) {
745
write_str("Backspace");
749
write_str("Newline");
753
if (char_code(x) & 0200) {
756
write_ch(((i>>6)&7) + '0');
757
write_ch(((i>>3)&7) + '0');
758
write_ch(((i>>0)&7) + '0');
759
} else if (char_code(x) < 040) {
761
write_ch(char_code(x) + 0100);
763
write_ch(char_code(x));
770
for (lw = 0,i = 0; i < x->s.s_fillp; i++) {
773
if (PRINTcase == sKdowncase ||
774
(PRINTcase == sKcapitalize && i!=lw))
776
} else if (!isLower(j))
783
if (x->s.s_hpack == Cnil) {
785
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
789
write_decimal((vp-PRINTvs_top)/2);
794
write_decimal((vp-PRINTvs_top)/2);
802
} else if (x->s.s_hpack == keyword_package)
804
else if (PRINTpackage||find_symbol(x,current_package())!=x
809
i < x->s.s_hpack->p.p_name->st.st_fillp;
811
j = x->s.s_hpack->p.p_name
813
if (to_be_escaped(j))
819
i < x->s.s_hpack->p.p_name->st.st_fillp;
821
j = x->s.s_hpack->p.p_name
823
if (j == '|' || j == '\\')
827
if (PRINTcase == sKdowncase ||
828
(PRINTcase == sKcapitalize && i!=lw))
830
} else if (!isLower(j))
837
if (find_symbol(x, x->s.s_hpack) != x)
838
error("can't print symbol");
839
if (PRINTpackage || intern_flag == INTERNAL)
841
else if (intern_flag == EXTERNAL)
844
FEerror("Pathological symbol --- cannot print.", 0);
847
if (potential_number_p(x, PRINTbase))
849
for (i = 0; i < x->s.s_fillp; i++) {
851
if (to_be_escaped(j))
854
for (i = 0; i < x->s.s_fillp; i++)
855
if (x->s.s_self[i] != '.')
862
for (lw = 0, i = 0; i < x->s.s_fillp; i++) {
864
if (j == '|' || j == '\\')
868
if (PRINTcase == sKdowncase ||
869
(PRINTcase == sKcapitalize && i != lw))
871
} else if (!isLower(j))
882
int subscripts[ARANKLIM];
886
write_str("#<array ");
892
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
896
write_decimal((vp-PRINTvs_top)/2);
901
write_decimal((vp-PRINTvs_top)/2);
908
if (PRINTlevel >= 0 && level >= PRINTlevel) {
916
if (PRINTlevel >= 0 && level+n >= PRINTlevel)
917
n = PRINTlevel - level;
918
for (i = 0; i < n; i++)
923
for (i = j; i < n; i++) {
924
if (subscripts[i] == 0) {
927
write_ch(SET_INDENT);
928
if (x->a.a_dims[i] == 0) {
936
if (subscripts[i] > 0)
938
if (PRINTlength >= 0 &&
939
subscripts[i] >= PRINTlength) {
942
k=x->a.a_dims[i]-subscripts[i];
944
for (j = i+1; j < n; j++)
950
if (n == x->a.a_rank) {
952
write_object(vs_head, level+n);
961
if (++subscripts[j] < x->a.a_dims[j])
977
write_str("#<vector ");
983
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
987
write_decimal((vp-PRINTvs_top)/2);
992
write_decimal((vp-PRINTvs_top)/2);
999
if (PRINTlevel >= 0 && level >= PRINTlevel) {
1006
write_ch(SET_INDENT);
1007
if (x->v.v_fillp > 0) {
1008
if (PRINTlength == 0) {
1013
vs_push(aref(x, 0));
1014
write_object(vs_head, level+1);
1016
for (i = 1; i < x->v.v_fillp; i++) {
1018
if (PRINTlength>=0 && i>=PRINTlength){
1022
vs_push(aref(x, i));
1023
write_object(vs_head, level+1);
1033
for (i = 0; i < x->st.st_fillp; i++)
1034
write_ch(x->st.st_self[i]);
1038
for (i = 0; i < x->st.st_fillp; i++) {
1039
if (x->st.st_self[i] == '"' ||
1040
x->st.st_self[i] == '\\')
1042
write_ch(x->st.st_self[i]);
1049
write_str("#<bit-vector ");
1055
for (i = x->bv.bv_offset; i < x->bv.bv_fillp + x->bv.bv_offset; i++)
1056
if (x->bv.bv_self[i/8] & (0200 >> i%8))
1063
if (x->c.c_car == siSsharp_comma) {
1065
write_object(x->c.c_cdr, level);
1069
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
1071
if (vp[1] != Cnil) {
1073
write_decimal((vp-PRINTvs_top)/2);
1078
write_decimal((vp-PRINTvs_top)/2);
1086
if (x->c.c_car == sLquote &&
1087
type_of(x->c.c_cdr) == t_cons &&
1088
x->c.c_cdr->c.c_cdr == Cnil) {
1090
write_object(x->c.c_cdr->c.c_car, level);
1093
if (x->c.c_car == sLfunction &&
1094
type_of(x->c.c_cdr) == t_cons &&
1095
x->c.c_cdr->c.c_cdr == Cnil) {
1098
write_object(x->c.c_cdr->c.c_car, level);
1102
if (PRINTlevel >= 0 && level >= PRINTlevel) {
1108
write_ch(SET_INDENT);
1109
if (PRINTpretty && x->c.c_car != OBJNULL &&
1110
type_of(x->c.c_car) == t_symbol &&
1111
(r = getf(x->c.c_car->s.s_plist,
1112
sSpretty_print_format, Cnil)) != Cnil)
1113
goto PRETTY_PRINT_FORMAT;
1114
for (i = 0; ; i++) {
1115
if (PRINTlength >= 0 && i >= PRINTlength) {
1121
write_object(y, level+1);
1122
if (type_of(x) != t_cons) {
1126
write_object(x, level);
1131
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
1133
if (vp[1] != Cnil) {
1135
write_decimal((vp-PRINTvs_top)/2);
1141
write_object(x, level);
1146
if (i == 0 && y != OBJNULL && type_of(y) == t_symbol)
1157
PRETTY_PRINT_FORMAT:
1159
for (i = 0; ; i++) {
1160
if (PRINTlength >= 0 && i >= PRINTlength) {
1166
if (i <= j && y == Cnil)
1169
write_object(y, level+1);
1170
if (type_of(x) != t_cons) {
1174
write_object(x, level);
1189
write_object(x->p.p_name, level);
1190
write_str(" package>");
1194
write_str("#<hash-table ");
1200
switch (x->sm.sm_mode) {
1202
write_str("#<input stream ");
1203
write_object(x->sm.sm_object1, level);
1208
write_str("#<output stream ");
1209
write_object(x->sm.sm_object1, level);
1214
write_str("#<io stream ");
1215
write_object(x->sm.sm_object1, level);
1220
write_str("#<socket stream ");
1221
write_object(x->sm.sm_object0, level);
1227
write_str("#<probe stream ");
1228
write_object(x->sm.sm_object1, level);
1233
write_str("#<synonym stream to ");
1234
write_object(x->sm.sm_object0, level);
1239
write_str("#<broadcast stream ");
1244
case smm_concatenated:
1245
write_str("#<concatenated stream ");
1251
write_str("#<two-way stream ");
1257
write_str("#<echo stream ");
1262
case smm_string_input:
1263
write_str("#<string-input stream from \"");
1264
y = x->sm.sm_object0;
1266
for (i = 0; i < j && i < 16; i++)
1267
write_ch(y->st.st_self[i]);
1272
#ifdef USER_DEFINED_STREAMS
1273
case smm_user_defined:
1274
write_str("#<use-define stream");
1280
case smm_string_output:
1281
write_str("#<string-output stream ");
1287
error("illegal stream mode");
1293
y = alloc_object(t_fixnum);
1294
fix(y) = x->rnd.rnd_value;
1296
write_object(y, level);
1302
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
1304
if (vp[1] != Cnil) {
1306
write_decimal((vp-PRINTvs_top)/2);
1311
write_decimal((vp-PRINTvs_top)/2);
1318
if (PRINTlevel >= 0 && level >= PRINTlevel) {
1322
if (type_of(x->str.str_def) != t_structure)
1323
FEwrong_type_argument(sLstructure, x->str.str_def);
1324
if (PRINTstructure ||
1325
S_DATA(x->str.str_def)->print_function == Cnil)
1328
x = structure_to_list(x);
1330
write_object(x, level);
1334
call_structure_print_function(x, level);
1338
write_str("#<readtable ");
1344
if (1 || PRINTescape) {
1347
vs_push(namestring(x));
1348
write_object(vs_head, level);
1351
write_str("#<pathname ");
1361
write_str("#<compiled-function ");
1362
if (x->cf.cf_name != Cnil)
1363
write_object(x->cf.cf_name, level);
1371
write_str("#<compiled-closure ");
1372
if (x->cc.cc_name != Cnil)
1373
write_object(x->cc.cc_name, level);
1380
write_str("#<\100");
1381
for (i = 8*sizeof(long)-4; i >= 0; i -= 4) {
1382
j = ((long)x >> i) & 0xf;
1386
write_ch('A' + (j - 10));
1392
error("illegal type --- cannot print");
1396
char travel_push_type[32];
1399
travel_push_object(x)
1410
if(travel_push_type[(int)t]==0) return;
1411
if(t==t_symbol && x->s.s_hpack != Cnil) return;
1413
for (vp = PRINTvs_top; vp < vs_top; vp += 2)
1421
vs_check_push(Cnil);
1422
if (t == t_array && (enum aelttype)x->a.a_elttype == aet_object)
1423
for (i = 0; i < x->a.a_dim; i++)
1424
travel_push_object(x->a.a_self[i]);
1425
else if (t == t_vector && (enum aelttype)x->v.v_elttype == aet_object)
1426
for (i = 0; i < x->v.v_fillp; i++)
1427
travel_push_object(x->v.v_self[i]);
1428
else if (t == t_cons) {
1429
travel_push_object(x->c.c_car);
1432
} else if (t == t_structure) {
1433
for (i = 0; i < S_DATA(x->str.str_def)->length; i++)
1434
travel_push_object(structure_ref(x,x->str.str_def,i));
1439
setupPRINTcircle(x,dogensyms)
1443
travel_push_type[(int)t_symbol]=dogensyms;
1444
travel_push_type[(int)t_array]=
1445
(travel_push_type[(int)t_vector]=PRINTarray);
1446
travel_push_object(x);
1447
for (vp = vq = PRINTvs_top; vp < vs_top; vp += 2)
1448
if (vp[1] != Cnil) {
1453
PRINTvs_limit = vs_top = vq;
1457
setupPRINTdefault(x)
1462
PRINTvs_top = vs_top;
1463
PRINTstream = symbol_value(sLAstandard_outputA);
1464
if (type_of(PRINTstream) != t_stream) {
1465
sLAstandard_outputA->s.s_dbind
1466
= symbol_value(sLAterminal_ioA);
1467
vs_push(PRINTstream);
1468
FEwrong_type_argument(sLstream, PRINTstream);
1470
PRINTescape = symbol_value(sLAprint_escapeA) != Cnil;
1471
PRINTreadably = symbol_value(sLAprint_readablyA) != Cnil;
1472
PRINTpretty = symbol_value(sLAprint_prettyA) != Cnil;
1473
PRINTcircle = symbol_value(sLAprint_circleA) != Cnil;
1474
y = symbol_value(sLAprint_baseA);
1475
if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) {
1476
sLAprint_baseA->s.s_dbind = make_fixnum(10);
1478
FEerror("~S is an illegal PRINT-BASE.", 1, y);
1481
PRINTradix = symbol_value(sLAprint_radixA) != Cnil;
1482
PRINTcase = symbol_value(sLAprint_caseA);
1483
if (PRINTcase != sKupcase && PRINTcase != sKdowncase &&
1484
PRINTcase != sKcapitalize) {
1485
sLAprint_caseA->s.s_dbind = sKdowncase;
1487
FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase);
1489
PRINTgensym = symbol_value(sLAprint_gensymA) != Cnil;
1490
y = symbol_value(sLAprint_levelA);
1493
else if (type_of(y) != t_fixnum || fix(y) < 0) {
1494
sLAprint_levelA->s.s_dbind = Cnil;
1496
FEerror("~S is an illegal PRINT-LEVEL.", 1, y);
1498
PRINTlevel = fix(y);
1499
y = symbol_value(sLAprint_lengthA);
1502
else if (type_of(y) != t_fixnum || fix(y) < 0) {
1503
sLAprint_lengthA->s.s_dbind = Cnil;
1505
FEerror("~S is an illegal PRINT-LENGTH.", 1, y);
1507
PRINTlength = fix(y);
1508
PRINTarray = symbol_value(sLAprint_arrayA) != Cnil;
1509
if (PRINTcircle) setupPRINTcircle(x,1);
1513
indent_stack[0] = 0;
1514
write_ch_fun = writec_queue;
1516
write_ch_fun = writec_PRINTstream;
1517
PRINTpackage = symbol_value(sSAprint_packageA) != Cnil;
1518
PRINTstructure = symbol_value(sSAprint_structureA) != Cnil;
1524
vs_top = PRINTvs_top;
1530
write_object_by_default(x)
1533
SETUP_PRINT_DEFAULT(x);
1535
flush_stream(PRINTstream);
1536
CLEANUP_PRINT_DEFAULT;
1542
PRINTstream = symbol_value(sLAstandard_outputA);
1543
if (type_of(PRINTstream) != t_stream)
1544
FEwrong_type_argument(sLstream, PRINTstream);
1545
WRITEC_NEWLINE(PRINTstream);
1549
potential_number_p(strng, base)
1556
l = strng->st.st_fillp;
1559
s = strng->st.st_self;
1562
if (digitp(c, base) >= 0)
1564
else if (c != '+' && c != '-' && c != '^' && c != '_')
1566
if (s[l-1] == '+' || s[l-1] == '-')
1568
for (i = 1; i < l; i++) {
1570
if (digitp(c, base) >= 0) {
1574
if (c != '+' && c != '-' && c != '/' && c != '.' &&
1575
c != '^' && c != '_' &&
1576
c != 'e' && c != 'E' &&
1577
c != 's' && c != 'S' && c != 'l' && c != 'L')
1585
&key ((:stream strm) Cnil)
1586
(escape `symbol_value(sLAprint_escapeA)`)
1587
(readably `symbol_value(sLAprint_readablyA)`)
1588
(radix `symbol_value(sLAprint_radixA)`)
1589
(base `symbol_value(sLAprint_baseA)`)
1590
(circle `symbol_value(sLAprint_circleA)`)
1591
(pretty `symbol_value(sLAprint_prettyA)`)
1592
(level `symbol_value(sLAprint_levelA)`)
1593
(length `symbol_value(sLAprint_lengthA)`)
1594
((:case cas) `symbol_value(sLAprint_caseA)`)
1595
(gensym `symbol_value(sLAprint_gensymA)`)
1596
(array `symbol_value(sLAprint_arrayA)`))
1597
struct printStruct printStructBuf;
1598
struct printStruct *old_printStructBufp = printStructBufp;
1601
printStructBufp = &printStructBuf;
1603
strm = symbol_value(sLAstandard_outputA);
1604
else if (strm == Ct)
1605
strm = symbol_value(sLAterminal_ioA);
1606
if (type_of(strm) != t_stream)
1607
FEerror("~S is not a stream.", 1, strm);
1608
PRINTvs_top = vs_top;
1610
PRINTreadably = readably != Cnil;
1611
PRINTescape = PRINTreadably || escape != Cnil;
1612
PRINTpretty = pretty != Cnil;
1613
PRINTcircle = circle != Cnil;
1614
if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36)
1615
FEerror("~S is an illegal PRINT-BASE.", 1, base);
1617
PRINTbase = fix((base));
1618
PRINTradix = radix != Cnil;
1620
if (PRINTcase != sKupcase && PRINTcase != sKdowncase &&
1621
PRINTcase != sKcapitalize)
1622
FEerror("~S is an illegal PRINT-CASE.", 1, cas);
1623
PRINTgensym = PRINTreadably || gensym != Cnil;
1624
if (PRINTreadably || level == Cnil)
1626
else if (type_of(level) != t_fixnum || fix((level)) < 0)
1627
FEerror("~S is an illegal PRINT-LEVEL.", 1, level);
1629
PRINTlevel = fix((level));
1630
if (PRINTreadably || length == Cnil)
1632
else if (type_of(length) != t_fixnum || fix((length)) < 0)
1633
FEerror("~S is an illegal PRINT-LENGTH.", 1, length);
1635
PRINTlength = fix((length));
1636
PRINTarray = PRINTreadably || array != Cnil;
1637
if (PRINTcircle) setupPRINTcircle(x,1);
1641
indent_stack[0] = 0;
1642
write_ch_fun = writec_queue;
1644
write_ch_fun = writec_PRINTstream;
1645
PRINTpackage = symbol_value(sSAprint_packageA) != Cnil;
1646
PRINTstructure = symbol_value(sSAprint_structureA) != Cnil;
1648
CLEANUP_PRINT_DEFAULT;
1649
flush_stream(PRINTstream);
1653
@(defun prin1 (obj &optional strm)
1659
@(defun print (obj &optional strm)
1665
@(defun pprint (obj &optional strm)
1668
strm = symbol_value(sLAstandard_outputA);
1669
else if (strm == Ct)
1670
strm = symbol_value(sLAterminal_ioA);
1671
check_type_stream(&strm);
1672
WRITEC_NEWLINE(strm);
1673
{SETUP_PRINT_DEFAULT(obj);
1675
PRINTreadably = FALSE;
1680
indent_stack[0] = 0;
1681
write_ch_fun = writec_queue;
1682
write_object(obj, 0);
1683
CLEANUP_PRINT_DEFAULT;
1684
flush_stream(strm);}
1688
@(defun princ (obj &optional strm)
1694
@(defun write_char (c &optional strm)
1697
strm = symbol_value(sLAstandard_outputA);
1698
else if (strm == Ct)
1699
strm = symbol_value(sLAterminal_ioA);
1700
check_type_character(&c);
1701
check_type_stream(&strm);
1702
writec_stream(char_code(c), strm);
1709
@(defun write_string (strng &o strm &k start end)
1712
get_string_start_end(strng, start, end, &s, &e);
1714
strm = symbol_value(sLAstandard_outputA);
1715
else if (strm == Ct)
1716
strm = symbol_value(sLAterminal_ioA);
1717
check_type_string(&strng);
1718
check_type_stream(&strm);
1719
for (i = s; i < e; i++)
1720
writec_stream(strng->st.st_self[i], strm);
1725
@(defun write_line (strng &o strm &k start end)
1728
get_string_start_end(strng, start, end, &s, &e);
1730
strm = symbol_value(sLAstandard_outputA);
1731
else if (strm == Ct)
1732
strm = symbol_value(sLAterminal_ioA);
1733
check_type_string(&strng);
1734
check_type_stream(&strm);
1735
for (i = s; i < e; i++)
1736
writec_stream(strng->st.st_self[i], strm);
1737
WRITEC_NEWLINE(strm);
1742
@(defun terpri (&optional strm)
1748
@(defun fresh_line (&optional strm)
1751
strm = symbol_value(sLAstandard_outputA);
1752
else if (strm == Ct)
1753
strm = symbol_value(sLAterminal_ioA);
1754
/* we need to get the real output stream, if possible */
1755
{object tmp=coerce_stream(strm,1);
1756
if(tmp != Cnil) strm = tmp ;
1758
check_type_stream(&strm);
1760
if (file_column(strm) == 0)
1762
WRITEC_NEWLINE(strm);
1767
@(defun finish_output (&o strm)
1770
strm = symbol_value(sLAstandard_outputA);
1771
else if (strm == Ct)
1772
strm = symbol_value(sLAterminal_ioA);
1773
check_type_stream(&strm);
1778
@(defun force_output (&o strm)
1781
strm = symbol_value(sLAstandard_outputA);
1782
else if (strm == Ct)
1783
strm = symbol_value(sLAterminal_ioA);
1784
check_type_stream(&strm);
1789
@(defun clear_output (&o strm)
1792
strm = symbol_value(sLAstandard_outputA);
1793
else if (strm == Ct)
1794
strm = symbol_value(sLAterminal_ioA);
1795
check_type_stream(&strm);
1799
@(defun write_byte (integer binary_output_stream)
1801
if (type_of(integer) != t_fixnum)
1802
FEerror("~S is not a byte.", 1, integer);
1803
check_type_stream(&binary_output_stream);
1804
writec_stream(fix(integer), binary_output_stream);
1808
DEF_ORDINARY("UPCASE",sKupcase,KEYWORD,"");
1809
DEF_ORDINARY("DOWNCASE",sKdowncase,KEYWORD,"");
1810
DEF_ORDINARY("CAPITALIZE",sKcapitalize,KEYWORD,"");
1811
DEF_ORDINARY("STREAM",sKstream,KEYWORD,"");
1812
DEF_ORDINARY("ESCAPE",sKescape,KEYWORD,"");
1813
DEF_ORDINARY("READABLY",sKreadably,KEYWORD,"");
1814
DEF_ORDINARY("PRETTY",sKpretty,KEYWORD,"");
1815
DEF_ORDINARY("CIRCLE",sKcircle,KEYWORD,"");
1816
DEF_ORDINARY("BASE",sKbase,KEYWORD,"");
1817
DEF_ORDINARY("RADIX",sKradix,KEYWORD,"");
1818
DEF_ORDINARY("CASE",sKcase,KEYWORD,"");
1819
DEF_ORDINARY("GENSYM",sKgensym,KEYWORD,"");
1820
DEF_ORDINARY("LEVEL",sKlevel,KEYWORD,"");
1821
DEF_ORDINARY("LENGTH",sKlength,KEYWORD,"");
1822
DEF_ORDINARY("ARRAY",sKarray,KEYWORD,"");
1823
DEFVAR("*PRINT-ESCAPE*",sLAprint_escapeA,LISP,Ct,"");
1824
DEFVAR("*PRINT-READABLY*",sLAprint_readablyA,LISP,Ct,"");
1825
DEFVAR("*PRINT-PRETTY*",sLAprint_prettyA,LISP,Ct,"");
1826
DEFVAR("*PRINT-CIRCLE*",sLAprint_circleA,LISP,Cnil,"");
1827
DEFVAR("*PRINT-BASE*",sLAprint_baseA,LISP,make_fixnum(10),"");
1828
DEFVAR("*PRINT-RADIX*",sLAprint_radixA,LISP,Cnil,"");
1829
DEFVAR("*PRINT-CASE*",sLAprint_caseA,LISP,sKupcase,"");
1830
DEFVAR("*PRINT-GENSYM*",sLAprint_gensymA,LISP,Ct,"");
1831
DEFVAR("*PRINT-LEVEL*",sLAprint_levelA,LISP,Cnil,"");
1832
DEFVAR("*PRINT-LENGTH*",sLAprint_lengthA,LISP,Cnil,"");
1833
DEFVAR("*PRINT-ARRAY*",sLAprint_arrayA,LISP,Ct,"");
1834
DEFVAR("*PRINT-PACKAGE*",sSAprint_packageA,SI,Cnil,"");
1835
DEFVAR("*PRINT-STRUCTURE*",sSAprint_structureA,SI,Cnil,"");
1836
DEF_ORDINARY("PRETTY-PRINT-FORMAT",sSpretty_print_format,SI,"");
1842
travel_push_type[(int)t_array]=1;
1843
travel_push_type[(int)t_vector]=1;
1844
travel_push_type[(int)t_structure]=1;
1845
travel_push_type[(int) t_cons]=1;
1846
if(sizeof(travel_push_type) < (int) t_other)
1847
error("travel_push_size to small see print.d");
1850
enter_mark_origin(&PRINTstream);
1851
PRINTreadably = FALSE;
1853
PRINTpretty = FALSE;
1854
PRINTcircle = FALSE;
1857
PRINTcase = sKupcase;
1858
enter_mark_origin(&PRINTcase);
1864
write_ch_fun = writec_PRINTstream;
1872
strm = symbol_value(sLAstandard_outputA);
1873
else if (strm == Ct)
1874
strm = symbol_value(sLAterminal_ioA);
1875
if (type_of(strm) != t_stream)
1876
FEerror("~S is not a stream.", 1, strm);
1879
switch (type_of(obj)) {
1881
PRINTcase = symbol_value(sLAprint_caseA);
1882
PRINTpackage = symbol_value(sSAprint_packageA) != Cnil;
1888
PRINTreadably = FALSE;
1889
PRINTescape = FALSE;
1890
write_ch_fun = writec_PRINTstream;
1891
write_object(obj, 0);
1895
{SETUP_PRINT_DEFAULT(obj);
1897
PRINTreadably = FALSE;
1898
PRINTescape = FALSE;
1899
write_object(obj, 0);
1900
CLEANUP_PRINT_DEFAULT;}
1911
strm = symbol_value(sLAstandard_outputA);
1912
else if (strm == Ct)
1913
strm = symbol_value(sLAterminal_ioA);
1914
if (type_of(strm) != t_stream)
1915
FEerror("~S is not a stream.", 1, strm);
1918
switch (type_of(obj)) {
1923
PRINTreadably = FALSE;
1925
write_ch_fun = writec_PRINTstream;
1926
write_object(obj, 0);
1930
{SETUP_PRINT_DEFAULT(obj);
1932
PRINTreadably = FALSE;
1934
write_object(obj, 0);
1935
CLEANUP_PRINT_DEFAULT;}
1948
princ(code_char(' '),strm);
1957
strm = symbol_value(sLAstandard_outputA);
1958
else if (strm == Ct)
1959
strm = symbol_value(sLAterminal_ioA);
1960
if (type_of(strm) != t_stream)
1961
FEerror("~S is not a stream.", 1, strm);
1962
WRITEC_NEWLINE(strm);
1968
write_string(strng, strm)
1974
strm = symbol_value(sLAstandard_outputA);
1975
else if (strm == Ct)
1976
strm = symbol_value(sLAterminal_ioA);
1977
check_type_string(&strng);
1978
check_type_stream(&strm);
1979
for (i = 0; i < strng->st.st_fillp; i++)
1980
writec_stream(strng->st.st_self[i], strm);
1985
THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION
1992
sym = symbol_value(sym);
1994
sym = symbol_value(sLAstandard_outputA);
1996
sym = symbol_value(sLAterminal_ioA);
1997
check_type_stream(&sym);
1998
writestr_stream(s, sym);
2006
sym = symbol_value(sym);
2008
sym = symbol_value(sLAstandard_outputA);
2010
sym = symbol_value(sLAterminal_ioA);
2011
check_type_stream(&sym);
2013
{WRITEC_NEWLINE(sym);
2016
writec_stream(c, sym);
2026
flush_stream(symbol_value(sLAstandard_outputA));
2030
FFN(set_line_length)(n)
2034
return make_fixnum(line_length);
2037
DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Cnil,"");
2040
gcl_init_print_function()
2042
make_function("WRITE", Lwrite);
2043
make_function("PRIN1", Lprin1);
2044
make_function("PRINT", Lprint);
2045
make_function("PPRINT", Lpprint);
2046
make_function("PRINC", Lprinc);
2048
make_function("WRITE-CHAR", Lwrite_char);
2049
make_function("WRITE-STRING", Lwrite_string);
2050
make_function("WRITE-LINE", Lwrite_line);
2051
make_function("TERPRI", Lterpri);
2052
make_function("FRESH-LINE", Lfresh_line);
2053
make_function("FINISH-OUTPUT", Lfinish_output);
2054
make_function("FORCE-OUTPUT", Lforce_output);
2055
make_function("CLEAR-OUTPUT", Lclear_output);
2056
make_function("WRITE-BYTE", Lwrite_byte);
2057
make_si_sfun("SET-LINE-LENGTH",set_line_length,ARGTYPE1(f_fixnum)
2058
| RESTYPE(f_fixnum));
added
removed
o/print.d
