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)) {
623
if (PRINTradix && PRINTbase != 10)
628
if (PRINTradix && PRINTbase == 10)
634
if (i == MOST_NEG_FIXNUM) {
635
x = fixnum_add(1,(MOST_POSITIVE_FIXNUM));
639
write_object(x, level);
642
if (PRINTradix && PRINTbase == 10)
649
for (vsp = vs_top; i != 0; i /= PRINTbase)
650
vs_push(code_char(digit_weight(i%PRINTbase,
653
write_ch(char_code((vs_pop)));
654
if (PRINTradix && PRINTbase == 10)
661
if (PRINTradix && PRINTbase != 10)
666
if (PRINTradix && PRINTbase == 10)
670
{ object s = coerce_big_to_string(x,PRINTbase);
672
while (i<s->ust.ust_fillp) { write_ch(s->ust.ust_self[i++]); }
674
if (PRINTradix && PRINTbase == 10)
683
write_object(x->rat.rat_num, level);
685
write_object(x->rat.rat_den, level);
688
write_object(x->rat.rat_num, level);
690
write_object(x->rat.rat_den, level);
695
r = symbol_value(sLAread_default_float_formatA);
696
if (r == sLshort_float)
697
write_double((double)sf(x), 0, TRUE);
699
write_double((double)sf(x), 'S', TRUE);
703
r = symbol_value(sLAread_default_float_formatA);
704
if (r == sLsingle_float ||
705
r == sLlong_float || r == sLdouble_float)
706
write_double(lf(x), 0, FALSE);
708
write_double(lf(x), 'F', FALSE);
713
write_object(x->cmp.cmp_real, level);
715
write_object(x->cmp.cmp_imag, level);
721
write_ch(char_code(x));
725
switch (char_code(x)) {
747
write_str("Backspace");
751
write_str("Newline");
755
if (char_code(x) & 0200) {
758
write_ch(((i>>6)&7) + '0');
759
write_ch(((i>>3)&7) + '0');
760
write_ch(((i>>0)&7) + '0');
761
} else if (char_code(x) < 040) {
763
write_ch(char_code(x) + 0100);
765
write_ch(char_code(x));
772
for (lw = 0,i = 0; i < x->s.s_fillp; i++) {
775
if (PRINTcase == sKdowncase ||
776
(PRINTcase == sKcapitalize && i!=lw))
778
} else if (!isLower(j))
785
if (x->s.s_hpack == Cnil) {
787
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
791
write_decimal((vp-PRINTvs_top)/2);
796
write_decimal((vp-PRINTvs_top)/2);
804
} else if (x->s.s_hpack == keyword_package)
806
else if (PRINTpackage||find_symbol(x,current_package())!=x
811
i < x->s.s_hpack->p.p_name->st.st_fillp;
813
j = x->s.s_hpack->p.p_name
815
if (to_be_escaped(j))
821
i < x->s.s_hpack->p.p_name->st.st_fillp;
823
j = x->s.s_hpack->p.p_name
825
if (j == '|' || j == '\\')
829
if (PRINTcase == sKdowncase ||
830
(PRINTcase == sKcapitalize && i!=lw))
832
} else if (!isLower(j))
839
if (find_symbol(x, x->s.s_hpack) != x)
840
error("can't print symbol");
841
if (PRINTpackage || intern_flag == INTERNAL)
843
else if (intern_flag == EXTERNAL)
846
FEerror("Pathological symbol --- cannot print.", 0);
849
if (potential_number_p(x, PRINTbase))
851
for (i = 0; i < x->s.s_fillp; i++) {
853
if (to_be_escaped(j))
856
for (i = 0; i < x->s.s_fillp; i++)
857
if (x->s.s_self[i] != '.')
864
for (lw = 0, i = 0; i < x->s.s_fillp; i++) {
866
if (j == '|' || j == '\\')
870
if (PRINTcase == sKdowncase ||
871
(PRINTcase == sKcapitalize && i != lw))
873
} else if (!isLower(j))
884
int subscripts[ARANKLIM];
888
write_str("#<array ");
894
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
898
write_decimal((vp-PRINTvs_top)/2);
903
write_decimal((vp-PRINTvs_top)/2);
910
if (PRINTlevel >= 0 && level >= PRINTlevel) {
918
if (PRINTlevel >= 0 && level+n >= PRINTlevel)
919
n = PRINTlevel - level;
920
for (i = 0; i < n; i++)
925
for (i = j; i < n; i++) {
926
if (subscripts[i] == 0) {
929
write_ch(SET_INDENT);
930
if (x->a.a_dims[i] == 0) {
938
if (subscripts[i] > 0)
940
if (PRINTlength >= 0 &&
941
subscripts[i] >= PRINTlength) {
944
k=x->a.a_dims[i]-subscripts[i];
946
for (j = i+1; j < n; j++)
952
if (n == x->a.a_rank) {
954
write_object(vs_head, level+n);
963
if (++subscripts[j] < x->a.a_dims[j])
979
write_str("#<vector ");
985
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
989
write_decimal((vp-PRINTvs_top)/2);
994
write_decimal((vp-PRINTvs_top)/2);
1001
if (PRINTlevel >= 0 && level >= PRINTlevel) {
1008
write_ch(SET_INDENT);
1009
if (x->v.v_fillp > 0) {
1010
if (PRINTlength == 0) {
1015
vs_push(aref(x, 0));
1016
write_object(vs_head, level+1);
1018
for (i = 1; i < x->v.v_fillp; i++) {
1020
if (PRINTlength>=0 && i>=PRINTlength){
1024
vs_push(aref(x, i));
1025
write_object(vs_head, level+1);
1035
for (i = 0; i < x->st.st_fillp; i++)
1036
write_ch(x->st.st_self[i]);
1040
for (i = 0; i < x->st.st_fillp; i++) {
1041
if (x->st.st_self[i] == '"' ||
1042
x->st.st_self[i] == '\\')
1044
write_ch(x->st.st_self[i]);
1051
write_str("#<bit-vector ");
1057
for (i = x->bv.bv_offset; i < x->bv.bv_fillp + x->bv.bv_offset; i++)
1058
if (x->bv.bv_self[i/8] & (0200 >> i%8))
1065
if (x->c.c_car == siSsharp_comma) {
1067
write_object(x->c.c_cdr, level);
1071
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
1073
if (vp[1] != Cnil) {
1075
write_decimal((vp-PRINTvs_top)/2);
1080
write_decimal((vp-PRINTvs_top)/2);
1088
if (x->c.c_car == sLquote &&
1089
type_of(x->c.c_cdr) == t_cons &&
1090
x->c.c_cdr->c.c_cdr == Cnil) {
1092
write_object(x->c.c_cdr->c.c_car, level);
1095
if (x->c.c_car == sLfunction &&
1096
type_of(x->c.c_cdr) == t_cons &&
1097
x->c.c_cdr->c.c_cdr == Cnil) {
1100
write_object(x->c.c_cdr->c.c_car, level);
1104
if (PRINTlevel >= 0 && level >= PRINTlevel) {
1110
write_ch(SET_INDENT);
1111
if (PRINTpretty && x->c.c_car != OBJNULL &&
1112
type_of(x->c.c_car) == t_symbol &&
1113
(r = getf(x->c.c_car->s.s_plist,
1114
sSpretty_print_format, Cnil)) != Cnil)
1115
goto PRETTY_PRINT_FORMAT;
1116
for (i = 0; ; i++) {
1117
if (PRINTlength >= 0 && i >= PRINTlength) {
1123
write_object(y, level+1);
1124
if (type_of(x) != t_cons) {
1128
write_object(x, level);
1133
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
1135
if (vp[1] != Cnil) {
1137
write_decimal((vp-PRINTvs_top)/2);
1143
write_object(x, level);
1148
if (i == 0 && y != OBJNULL && type_of(y) == t_symbol)
1159
PRETTY_PRINT_FORMAT:
1161
for (i = 0; ; i++) {
1162
if (PRINTlength >= 0 && i >= PRINTlength) {
1168
if (i <= j && y == Cnil)
1171
write_object(y, level+1);
1172
if (type_of(x) != t_cons) {
1176
write_object(x, level);
1191
write_object(x->p.p_name, level);
1192
write_str(" package>");
1196
write_str("#<hash-table ");
1202
switch (x->sm.sm_mode) {
1204
write_str("#<input stream ");
1205
write_object(x->sm.sm_object1, level);
1210
write_str("#<output stream ");
1211
write_object(x->sm.sm_object1, level);
1216
write_str("#<io stream ");
1217
write_object(x->sm.sm_object1, level);
1222
write_str("#<socket stream ");
1223
write_object(x->sm.sm_object0, level);
1229
write_str("#<probe stream ");
1230
write_object(x->sm.sm_object1, level);
1235
write_str("#<synonym stream to ");
1236
write_object(x->sm.sm_object0, level);
1241
write_str("#<broadcast stream ");
1246
case smm_concatenated:
1247
write_str("#<concatenated stream ");
1253
write_str("#<two-way stream ");
1259
write_str("#<echo stream ");
1264
case smm_string_input:
1265
write_str("#<string-input stream from \"");
1266
y = x->sm.sm_object0;
1268
for (i = 0; i < j && i < 16; i++)
1269
write_ch(y->st.st_self[i]);
1274
#ifdef USER_DEFINED_STREAMS
1275
case smm_user_defined:
1276
write_str("#<use-define stream");
1282
case smm_string_output:
1283
write_str("#<string-output stream ");
1289
error("illegal stream mode");
1295
y = alloc_object(t_fixnum);
1296
fix(y) = x->rnd.rnd_value;
1298
write_object(y, level);
1304
for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
1306
if (vp[1] != Cnil) {
1308
write_decimal((vp-PRINTvs_top)/2);
1313
write_decimal((vp-PRINTvs_top)/2);
1320
if (PRINTlevel >= 0 && level >= PRINTlevel) {
1324
if (type_of(x->str.str_def) != t_structure)
1325
FEwrong_type_argument(sLstructure, x->str.str_def);
1326
if (PRINTstructure ||
1327
S_DATA(x->str.str_def)->print_function == Cnil)
1330
x = structure_to_list(x);
1332
write_object(x, level);
1336
call_structure_print_function(x, level);
1340
write_str("#<readtable ");
1346
if (1 || PRINTescape) {
1349
vs_push(namestring(x));
1350
write_object(vs_head, level);
1353
write_str("#<pathname ");
1363
write_str("#<compiled-function ");
1364
if (x->cf.cf_name != Cnil)
1365
write_object(x->cf.cf_name, level);
1373
write_str("#<compiled-closure ");
1374
if (x->cc.cc_name != Cnil)
1375
write_object(x->cc.cc_name, level);
1382
write_str("#<\100");
1383
for (i = 8*sizeof(long)-4; i >= 0; i -= 4) {
1384
j = ((long)x >> i) & 0xf;
1388
write_ch('A' + (j - 10));
1394
error("illegal type --- cannot print");
1398
char travel_push_type[32];
1401
travel_push_object(x)
1412
if(travel_push_type[(int)t]==0) return;
1413
if(t==t_symbol && x->s.s_hpack != Cnil) return;
1415
for (vp = PRINTvs_top; vp < vs_top; vp += 2)
1423
vs_check_push(Cnil);
1424
if (t == t_array && (enum aelttype)x->a.a_elttype == aet_object)
1425
for (i = 0; i < x->a.a_dim; i++)
1426
travel_push_object(x->a.a_self[i]);
1427
else if (t == t_vector && (enum aelttype)x->v.v_elttype == aet_object)
1428
for (i = 0; i < x->v.v_fillp; i++)
1429
travel_push_object(x->v.v_self[i]);
1430
else if (t == t_cons) {
1431
travel_push_object(x->c.c_car);
1434
} else if (t == t_structure) {
1435
for (i = 0; i < S_DATA(x->str.str_def)->length; i++)
1436
travel_push_object(structure_ref(x,x->str.str_def,i));
1441
setupPRINTcircle(x,dogensyms)
1445
travel_push_type[(int)t_symbol]=dogensyms;
1446
travel_push_type[(int)t_array]=
1447
(travel_push_type[(int)t_vector]=PRINTarray);
1448
travel_push_object(x);
1449
for (vp = vq = PRINTvs_top; vp < vs_top; vp += 2)
1450
if (vp[1] != Cnil) {
1455
PRINTvs_limit = vs_top = vq;
1459
setupPRINTdefault(x)
1464
PRINTvs_top = vs_top;
1465
PRINTstream = symbol_value(sLAstandard_outputA);
1466
if (type_of(PRINTstream) != t_stream) {
1467
sLAstandard_outputA->s.s_dbind
1468
= symbol_value(sLAterminal_ioA);
1469
vs_push(PRINTstream);
1470
FEwrong_type_argument(sLstream, PRINTstream);
1472
PRINTescape = symbol_value(sLAprint_escapeA) != Cnil;
1473
PRINTreadably = symbol_value(sLAprint_readablyA) != Cnil;
1474
PRINTpretty = symbol_value(sLAprint_prettyA) != Cnil;
1475
PRINTcircle = symbol_value(sLAprint_circleA) != Cnil;
1476
y = symbol_value(sLAprint_baseA);
1477
if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) {
1478
sLAprint_baseA->s.s_dbind = make_fixnum(10);
1480
FEerror("~S is an illegal PRINT-BASE.", 1, y);
1483
PRINTradix = symbol_value(sLAprint_radixA) != Cnil;
1484
PRINTcase = symbol_value(sLAprint_caseA);
1485
if (PRINTcase != sKupcase && PRINTcase != sKdowncase &&
1486
PRINTcase != sKcapitalize) {
1487
sLAprint_caseA->s.s_dbind = sKdowncase;
1489
FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase);
1491
PRINTgensym = symbol_value(sLAprint_gensymA) != Cnil;
1492
y = symbol_value(sLAprint_levelA);
1495
else if (type_of(y) != t_fixnum || fix(y) < 0) {
1496
sLAprint_levelA->s.s_dbind = Cnil;
1498
FEerror("~S is an illegal PRINT-LEVEL.", 1, y);
1500
PRINTlevel = fix(y);
1501
y = symbol_value(sLAprint_lengthA);
1504
else if (type_of(y) != t_fixnum || fix(y) < 0) {
1505
sLAprint_lengthA->s.s_dbind = Cnil;
1507
FEerror("~S is an illegal PRINT-LENGTH.", 1, y);
1509
PRINTlength = fix(y);
1510
PRINTarray = symbol_value(sLAprint_arrayA) != Cnil;
1511
if (PRINTcircle) setupPRINTcircle(x,1);
1515
indent_stack[0] = 0;
1516
write_ch_fun = writec_queue;
1518
write_ch_fun = writec_PRINTstream;
1519
PRINTpackage = symbol_value(sSAprint_packageA) != Cnil;
1520
PRINTstructure = symbol_value(sSAprint_structureA) != Cnil;
1526
vs_top = PRINTvs_top;
1532
write_object_by_default(x)
1535
SETUP_PRINT_DEFAULT(x);
1537
flush_stream(PRINTstream);
1538
CLEANUP_PRINT_DEFAULT;
1544
PRINTstream = symbol_value(sLAstandard_outputA);
1545
if (type_of(PRINTstream) != t_stream)
1546
FEwrong_type_argument(sLstream, PRINTstream);
1547
WRITEC_NEWLINE(PRINTstream);
1551
potential_number_p(strng, base)
1558
l = strng->st.st_fillp;
1561
s = strng->st.st_self;
1564
if (digitp(c, base) >= 0)
1566
else if (c != '+' && c != '-' && c != '^' && c != '_')
1568
if (s[l-1] == '+' || s[l-1] == '-')
1570
for (i = 1; i < l; i++) {
1572
if (digitp(c, base) >= 0) {
1576
if (c != '+' && c != '-' && c != '/' && c != '.' &&
1577
c != '^' && c != '_' &&
1578
c != 'e' && c != 'E' &&
1579
c != 's' && c != 'S' && c != 'l' && c != 'L')
1587
&key ((:stream strm) Cnil)
1588
(escape `symbol_value(sLAprint_escapeA)`)
1589
(readably `symbol_value(sLAprint_readablyA)`)
1590
(radix `symbol_value(sLAprint_radixA)`)
1591
(base `symbol_value(sLAprint_baseA)`)
1592
(circle `symbol_value(sLAprint_circleA)`)
1593
(pretty `symbol_value(sLAprint_prettyA)`)
1594
(level `symbol_value(sLAprint_levelA)`)
1595
(length `symbol_value(sLAprint_lengthA)`)
1596
((:case cas) `symbol_value(sLAprint_caseA)`)
1597
(gensym `symbol_value(sLAprint_gensymA)`)
1598
(array `symbol_value(sLAprint_arrayA)`))
1599
struct printStruct printStructBuf;
1600
struct printStruct *old_printStructBufp = printStructBufp;
1603
printStructBufp = &printStructBuf;
1605
strm = symbol_value(sLAstandard_outputA);
1606
else if (strm == Ct)
1607
strm = symbol_value(sLAterminal_ioA);
1608
if (type_of(strm) != t_stream)
1609
FEerror("~S is not a stream.", 1, strm);
1610
PRINTvs_top = vs_top;
1612
PRINTreadably = readably != Cnil;
1613
PRINTescape = PRINTreadably || escape != Cnil;
1614
PRINTpretty = pretty != Cnil;
1615
PRINTcircle = circle != Cnil;
1616
if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36)
1617
FEerror("~S is an illegal PRINT-BASE.", 1, base);
1619
PRINTbase = fix((base));
1620
PRINTradix = radix != Cnil;
1622
if (PRINTcase != sKupcase && PRINTcase != sKdowncase &&
1623
PRINTcase != sKcapitalize)
1624
FEerror("~S is an illegal PRINT-CASE.", 1, cas);
1625
PRINTgensym = PRINTreadably || gensym != Cnil;
1626
if (PRINTreadably || level == Cnil)
1628
else if (type_of(level) != t_fixnum || fix((level)) < 0)
1629
FEerror("~S is an illegal PRINT-LEVEL.", 1, level);
1631
PRINTlevel = fix((level));
1632
if (PRINTreadably || length == Cnil)
1634
else if (type_of(length) != t_fixnum || fix((length)) < 0)
1635
FEerror("~S is an illegal PRINT-LENGTH.", 1, length);
1637
PRINTlength = fix((length));
1638
PRINTarray = PRINTreadably || array != Cnil;
1639
if (PRINTcircle) setupPRINTcircle(x,1);
1643
indent_stack[0] = 0;
1644
write_ch_fun = writec_queue;
1646
write_ch_fun = writec_PRINTstream;
1647
PRINTpackage = symbol_value(sSAprint_packageA) != Cnil;
1648
PRINTstructure = symbol_value(sSAprint_structureA) != Cnil;
1650
CLEANUP_PRINT_DEFAULT;
1651
flush_stream(PRINTstream);
1655
@(defun prin1 (obj &optional strm)
1661
@(defun print (obj &optional strm)
1667
@(defun pprint (obj &optional strm)
1670
strm = symbol_value(sLAstandard_outputA);
1671
else if (strm == Ct)
1672
strm = symbol_value(sLAterminal_ioA);
1673
check_type_stream(&strm);
1674
WRITEC_NEWLINE(strm);
1675
{SETUP_PRINT_DEFAULT(obj);
1677
PRINTreadably = FALSE;
1682
indent_stack[0] = 0;
1683
write_ch_fun = writec_queue;
1684
write_object(obj, 0);
1685
CLEANUP_PRINT_DEFAULT;
1686
flush_stream(strm);}
1690
@(defun princ (obj &optional strm)
1696
@(defun write_char (c &optional strm)
1699
strm = symbol_value(sLAstandard_outputA);
1700
else if (strm == Ct)
1701
strm = symbol_value(sLAterminal_ioA);
1702
check_type_character(&c);
1703
check_type_stream(&strm);
1704
writec_stream(char_code(c), strm);
1711
@(defun write_string (strng &o strm &k start end)
1714
get_string_start_end(strng, start, end, &s, &e);
1716
strm = symbol_value(sLAstandard_outputA);
1717
else if (strm == Ct)
1718
strm = symbol_value(sLAterminal_ioA);
1719
check_type_string(&strng);
1720
check_type_stream(&strm);
1721
for (i = s; i < e; i++)
1722
writec_stream(strng->st.st_self[i], strm);
1727
@(defun write_line (strng &o strm &k start end)
1730
get_string_start_end(strng, start, end, &s, &e);
1732
strm = symbol_value(sLAstandard_outputA);
1733
else if (strm == Ct)
1734
strm = symbol_value(sLAterminal_ioA);
1735
check_type_string(&strng);
1736
check_type_stream(&strm);
1737
for (i = s; i < e; i++)
1738
writec_stream(strng->st.st_self[i], strm);
1739
WRITEC_NEWLINE(strm);
1744
@(defun terpri (&optional strm)
1750
@(defun fresh_line (&optional strm)
1753
strm = symbol_value(sLAstandard_outputA);
1754
else if (strm == Ct)
1755
strm = symbol_value(sLAterminal_ioA);
1756
/* we need to get the real output stream, if possible */
1757
{object tmp=coerce_stream(strm,1);
1758
if(tmp != Cnil) strm = tmp ;
1760
check_type_stream(&strm);
1762
if (file_column(strm) == 0)
1764
WRITEC_NEWLINE(strm);
1769
@(defun finish_output (&o strm)
1772
strm = symbol_value(sLAstandard_outputA);
1773
else if (strm == Ct)
1774
strm = symbol_value(sLAterminal_ioA);
1775
check_type_stream(&strm);
1780
@(defun force_output (&o strm)
1783
strm = symbol_value(sLAstandard_outputA);
1784
else if (strm == Ct)
1785
strm = symbol_value(sLAterminal_ioA);
1786
check_type_stream(&strm);
1791
@(defun clear_output (&o strm)
1794
strm = symbol_value(sLAstandard_outputA);
1795
else if (strm == Ct)
1796
strm = symbol_value(sLAterminal_ioA);
1797
check_type_stream(&strm);
1801
@(defun write_byte (integer binary_output_stream)
1803
if (type_of(integer) != t_fixnum)
1804
FEerror("~S is not a byte.", 1, integer);
1805
check_type_stream(&binary_output_stream);
1806
writec_stream(fix(integer), binary_output_stream);
1810
DEF_ORDINARY("UPCASE",sKupcase,KEYWORD,"");
1811
DEF_ORDINARY("DOWNCASE",sKdowncase,KEYWORD,"");
1812
DEF_ORDINARY("CAPITALIZE",sKcapitalize,KEYWORD,"");
1813
DEF_ORDINARY("STREAM",sKstream,KEYWORD,"");
1814
DEF_ORDINARY("ESCAPE",sKescape,KEYWORD,"");
1815
DEF_ORDINARY("READABLY",sKreadably,KEYWORD,"");
1816
DEF_ORDINARY("PRETTY",sKpretty,KEYWORD,"");
1817
DEF_ORDINARY("CIRCLE",sKcircle,KEYWORD,"");
1818
DEF_ORDINARY("BASE",sKbase,KEYWORD,"");
1819
DEF_ORDINARY("RADIX",sKradix,KEYWORD,"");
1820
DEF_ORDINARY("CASE",sKcase,KEYWORD,"");
1821
DEF_ORDINARY("GENSYM",sKgensym,KEYWORD,"");
1822
DEF_ORDINARY("LEVEL",sKlevel,KEYWORD,"");
1823
DEF_ORDINARY("LENGTH",sKlength,KEYWORD,"");
1824
DEF_ORDINARY("ARRAY",sKarray,KEYWORD,"");
1825
DEFVAR("*PRINT-ESCAPE*",sLAprint_escapeA,LISP,Ct,"");
1826
DEFVAR("*PRINT-READABLY*",sLAprint_readablyA,LISP,Ct,"");
1827
DEFVAR("*PRINT-PRETTY*",sLAprint_prettyA,LISP,Ct,"");
1828
DEFVAR("*PRINT-CIRCLE*",sLAprint_circleA,LISP,Cnil,"");
1829
DEFVAR("*PRINT-BASE*",sLAprint_baseA,LISP,make_fixnum(10),"");
1830
DEFVAR("*PRINT-RADIX*",sLAprint_radixA,LISP,Cnil,"");
1831
DEFVAR("*PRINT-CASE*",sLAprint_caseA,LISP,sKupcase,"");
1832
DEFVAR("*PRINT-GENSYM*",sLAprint_gensymA,LISP,Ct,"");
1833
DEFVAR("*PRINT-LEVEL*",sLAprint_levelA,LISP,Cnil,"");
1834
DEFVAR("*PRINT-LENGTH*",sLAprint_lengthA,LISP,Cnil,"");
1835
DEFVAR("*PRINT-ARRAY*",sLAprint_arrayA,LISP,Ct,"");
1836
DEFVAR("*PRINT-PACKAGE*",sSAprint_packageA,SI,Cnil,"");
1837
DEFVAR("*PRINT-STRUCTURE*",sSAprint_structureA,SI,Cnil,"");
1838
DEF_ORDINARY("PRETTY-PRINT-FORMAT",sSpretty_print_format,SI,"");
1844
travel_push_type[(int)t_array]=1;
1845
travel_push_type[(int)t_vector]=1;
1846
travel_push_type[(int)t_structure]=1;
1847
travel_push_type[(int) t_cons]=1;
1848
if(sizeof(travel_push_type) < (int) t_other)
1849
error("travel_push_size to small see print.d");
1852
enter_mark_origin(&PRINTstream);
1853
PRINTreadably = FALSE;
1855
PRINTpretty = FALSE;
1856
PRINTcircle = FALSE;
1859
PRINTcase = sKupcase;
1860
enter_mark_origin(&PRINTcase);
1866
write_ch_fun = writec_PRINTstream;
1874
strm = symbol_value(sLAstandard_outputA);
1875
else if (strm == Ct)
1876
strm = symbol_value(sLAterminal_ioA);
1877
if (type_of(strm) != t_stream)
1878
FEerror("~S is not a stream.", 1, strm);
1881
switch (type_of(obj)) {
1883
PRINTcase = symbol_value(sLAprint_caseA);
1884
PRINTpackage = symbol_value(sSAprint_packageA) != Cnil;
1890
PRINTreadably = FALSE;
1891
PRINTescape = FALSE;
1892
write_ch_fun = writec_PRINTstream;
1893
write_object(obj, 0);
1897
{SETUP_PRINT_DEFAULT(obj);
1899
PRINTreadably = FALSE;
1900
PRINTescape = FALSE;
1901
write_object(obj, 0);
1902
CLEANUP_PRINT_DEFAULT;}
1913
strm = symbol_value(sLAstandard_outputA);
1914
else if (strm == Ct)
1915
strm = symbol_value(sLAterminal_ioA);
1916
if (type_of(strm) != t_stream)
1917
FEerror("~S is not a stream.", 1, strm);
1920
switch (type_of(obj)) {
1925
PRINTreadably = FALSE;
1927
write_ch_fun = writec_PRINTstream;
1928
write_object(obj, 0);
1932
{SETUP_PRINT_DEFAULT(obj);
1934
PRINTreadably = FALSE;
1936
write_object(obj, 0);
1937
CLEANUP_PRINT_DEFAULT;}
1950
princ(code_char(' '),strm);
1959
strm = symbol_value(sLAstandard_outputA);
1960
else if (strm == Ct)
1961
strm = symbol_value(sLAterminal_ioA);
1962
if (type_of(strm) != t_stream)
1963
FEerror("~S is not a stream.", 1, strm);
1964
WRITEC_NEWLINE(strm);
1970
write_string(strng, strm)
1976
strm = symbol_value(sLAstandard_outputA);
1977
else if (strm == Ct)
1978
strm = symbol_value(sLAterminal_ioA);
1979
check_type_string(&strng);
1980
check_type_stream(&strm);
1981
for (i = 0; i < strng->st.st_fillp; i++)
1982
writec_stream(strng->st.st_self[i], strm);
1987
THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION
1994
sym = symbol_value(sym);
1996
sym = symbol_value(sLAstandard_outputA);
1998
sym = symbol_value(sLAterminal_ioA);
1999
check_type_stream(&sym);
2000
writestr_stream(s, sym);
2008
sym = symbol_value(sym);
2010
sym = symbol_value(sLAstandard_outputA);
2012
sym = symbol_value(sLAterminal_ioA);
2013
check_type_stream(&sym);
2015
{WRITEC_NEWLINE(sym);
2018
writec_stream(c, sym);
2028
flush_stream(symbol_value(sLAstandard_outputA));
2032
FFN(set_line_length)(n)
2036
return make_fixnum(line_length);
2039
DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Cnil,"");
2042
gcl_init_print_function()
2044
make_function("WRITE", Lwrite);
2045
make_function("PRIN1", Lprin1);
2046
make_function("PRINT", Lprint);
2047
make_function("PPRINT", Lpprint);
2048
make_function("PRINC", Lprinc);
2050
make_function("WRITE-CHAR", Lwrite_char);
2051
make_function("WRITE-STRING", Lwrite_string);
2052
make_function("WRITE-LINE", Lwrite_line);
2053
make_function("TERPRI", Lterpri);
2054
make_function("FRESH-LINE", Lfresh_line);
2055
make_function("FINISH-OUTPUT", Lfinish_output);
2056
make_function("FORCE-OUTPUT", Lforce_output);
2057
make_function("CLEAR-OUTPUT", Lclear_output);
2058
make_function("WRITE-BYTE", Lwrite_byte);
2059
make_si_sfun("SET-LINE-LENGTH",set_line_length,ARGTYPE1(f_fixnum)
2060
| RESTYPE(f_fixnum));