feat: 9.5.9
This commit is contained in:
tmtt
parent
cb1753732b
commit
35f43a7909
1084 changed files with 558985 additions and 0 deletions
288
c/print.c
Normal file
288
c/print.c
Normal file
|
|
@ -0,0 +1,288 @@
|
|||
/* print.c
|
||||
* Copyright 1984-2017 Cisco Systems, Inc.
|
||||
*
|
||||
* Licensed under the Apache License, Version 2.0 (the "License");
|
||||
* you may not use this file except in compliance with the License.
|
||||
* You may obtain a copy of the License at
|
||||
*
|
||||
* http://www.apache.org/licenses/LICENSE-2.0
|
||||
*
|
||||
* Unless required by applicable law or agreed to in writing, software
|
||||
* distributed under the License is distributed on an "AS IS" BASIS,
|
||||
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
* See the License for the specific language governing permissions and
|
||||
* limitations under the License.
|
||||
*/
|
||||
|
||||
#include "system.h"
|
||||
|
||||
/* locally defined functions */
|
||||
static void pimmediate(ptr x);
|
||||
static void pbox(ptr x);
|
||||
static void pclo(ptr x);
|
||||
static void pcode(ptr x);
|
||||
static void pcons(ptr x);
|
||||
static void pfile(ptr x);
|
||||
static void pinexactnum(ptr x);
|
||||
static IBOOL exact_real_negativep(ptr x);
|
||||
static void pexactnum(ptr x);
|
||||
static void prat(ptr x);
|
||||
static void pchar(ptr x);
|
||||
static void pstr(ptr x);
|
||||
static void psym(ptr x);
|
||||
static void pvec(ptr x);
|
||||
static void pfxvector(ptr x);
|
||||
static void pbytevector(ptr x);
|
||||
static void pflonum(ptr x);
|
||||
static void pfixnum(ptr x);
|
||||
static void pbignum(ptr x);
|
||||
static void wrint(ptr x);
|
||||
|
||||
void S_print_init(void) {}
|
||||
|
||||
void S_prin1(ptr x) {
|
||||
if (Simmediatep(x)) pimmediate(x);
|
||||
else if (Spairp(x)) pcons(x);
|
||||
else if (Ssymbolp(x)) psym(x);
|
||||
else if (Sfixnump(x)) pfixnum(x);
|
||||
else if (Sbignump(x)) pbignum(x);
|
||||
else if (Sstringp(x)) pstr(x);
|
||||
else if (Sratnump(x)) prat(x);
|
||||
else if (Sflonump(x)) (void) pflonum(x);
|
||||
else if (Sinexactnump(x)) pinexactnum(x);
|
||||
else if (Sexactnump(x)) pexactnum(x);
|
||||
else if (Svectorp(x)) pvec(x);
|
||||
else if (Sfxvectorp(x)) pfxvector(x);
|
||||
else if (Sbytevectorp(x)) pbytevector(x);
|
||||
else if (Sboxp(x)) pbox(x);
|
||||
else if (Sprocedurep(x)) pclo(x);
|
||||
else if (Scodep(x)) pcode(x);
|
||||
else if (Sportp(x)) pfile(x);
|
||||
else if (Srecordp(x)) printf("#<record>");
|
||||
else printf("#<garbage>");
|
||||
fflush(stdout);
|
||||
}
|
||||
|
||||
|
||||
static void pimmediate(ptr x) {
|
||||
if (Scharp(x)) pchar(x);
|
||||
else if (x == Snil) printf("()");
|
||||
else if (x == Strue) printf("#t");
|
||||
else if (x == Sfalse) printf("#f");
|
||||
else if (x == Seof_object) printf("#!eof");
|
||||
else if (x == Sbwp_object) printf("#!bwp");
|
||||
else if (x == sunbound) printf("#<unbound>");
|
||||
else if (x == Svoid) printf("#<void>");
|
||||
else printf("#<garbage>");
|
||||
}
|
||||
|
||||
static void pbox(ptr x) {
|
||||
printf("#&");
|
||||
S_prin1(Sunbox(x));
|
||||
}
|
||||
|
||||
static void pclo(UNUSED ptr x) {
|
||||
if (CODETYPE(CLOSCODE(x)) & (code_flag_continuation << code_flags_offset))
|
||||
printf("#<continuation>");
|
||||
else
|
||||
printf("#<procedure>");
|
||||
}
|
||||
|
||||
static void pcode(UNUSED ptr x) {
|
||||
printf("#<code>");
|
||||
}
|
||||
|
||||
static void pcons(ptr x) {
|
||||
putchar('(');
|
||||
while (1) {
|
||||
S_prin1(Scar(x));
|
||||
x = Scdr(x);
|
||||
if (!Spairp(x)) break;
|
||||
putchar(' ');
|
||||
}
|
||||
if (x!=Snil) {
|
||||
printf(" . ");
|
||||
S_prin1(x);
|
||||
}
|
||||
putchar(')');
|
||||
}
|
||||
|
||||
|
||||
static void pfile(UNUSED ptr x) {
|
||||
printf("#<port>");
|
||||
}
|
||||
|
||||
static void pinexactnum(ptr x) {
|
||||
S_prin1(TYPE(&INEXACTNUM_REAL_PART(x),type_flonum));
|
||||
if (INEXACTNUM_IMAG_PART(x) >= 0.0) putchar('+');
|
||||
S_prin1(TYPE(&INEXACTNUM_IMAG_PART(x),type_flonum));
|
||||
putchar('i');
|
||||
}
|
||||
|
||||
static IBOOL exact_real_negativep(ptr x) {
|
||||
if (Sratnump(x)) x = RATNUM(x);
|
||||
return Sfixnump(x) ? UNFIX(x) < 0 : BIGSIGN(x);
|
||||
}
|
||||
|
||||
static void pexactnum(ptr x) {
|
||||
S_prin1(EXACTNUM_REAL_PART(x));
|
||||
if (!exact_real_negativep(EXACTNUM_IMAG_PART(x))) putchar('+');
|
||||
S_prin1(EXACTNUM_IMAG_PART(x));
|
||||
putchar('i');
|
||||
}
|
||||
|
||||
static void prat(ptr x) {
|
||||
wrint(RATNUM(x));
|
||||
putchar('/');
|
||||
wrint(RATDEN(x));
|
||||
}
|
||||
|
||||
static void pchar(ptr x) {
|
||||
int k = Schar_value(x);
|
||||
if (k >= 256) k = '?';
|
||||
printf("#\\");
|
||||
putchar(k);
|
||||
}
|
||||
|
||||
static void pstr(ptr x) {
|
||||
iptr i, n = Sstring_length(x);
|
||||
|
||||
putchar('"');
|
||||
for (i = 0; i < n; i += 1) {
|
||||
int k = Sstring_ref(x, i);
|
||||
if (k >= 256) k = '?';
|
||||
if ((k == '\\') || (k == '"')) putchar('\\');
|
||||
putchar(k);
|
||||
}
|
||||
putchar('"');
|
||||
}
|
||||
|
||||
static void display_string(ptr x) {
|
||||
iptr i, n = Sstring_length(x);
|
||||
|
||||
for (i = 0; i < n; i += 1) {
|
||||
int k = Sstring_ref(x, i);
|
||||
if (k >= 256) k = '?';
|
||||
putchar(k);
|
||||
}
|
||||
}
|
||||
|
||||
static void psym(ptr x) {
|
||||
ptr name = SYMNAME(x);
|
||||
if (Sstringp(name)) {
|
||||
display_string(name);
|
||||
} else if (Spairp(name)) {
|
||||
if (Scar(name) != Sfalse) {
|
||||
printf("#{");
|
||||
display_string(Scdr(name));
|
||||
printf(" ");
|
||||
display_string(Scar(name));
|
||||
printf("}");
|
||||
} else {
|
||||
printf("#<gensym ");
|
||||
display_string(Scdr(name));
|
||||
printf(">");
|
||||
}
|
||||
} else {
|
||||
printf("#<gensym>");
|
||||
}
|
||||
}
|
||||
|
||||
static void pvec(ptr x) {
|
||||
iptr n;
|
||||
|
||||
putchar('#');
|
||||
n = Svector_length(x);
|
||||
wrint(FIX(n));
|
||||
putchar('(');
|
||||
if (n != 0) {
|
||||
iptr i = 0;
|
||||
|
||||
while (1) {
|
||||
S_prin1(Svector_ref(x, i));
|
||||
if (++i == n) break;
|
||||
putchar(' ');
|
||||
}
|
||||
}
|
||||
putchar(')');
|
||||
}
|
||||
|
||||
static void pfxvector(ptr x) {
|
||||
iptr n;
|
||||
|
||||
putchar('#');
|
||||
n = Sfxvector_length(x);
|
||||
wrint(FIX(n));
|
||||
printf("vfx(");
|
||||
if (n != 0) {
|
||||
iptr i = 0;
|
||||
|
||||
while (1) {
|
||||
pfixnum(Sfxvector_ref(x, i));
|
||||
if (++i == n) break;
|
||||
putchar(' ');
|
||||
}
|
||||
}
|
||||
putchar(')');
|
||||
}
|
||||
|
||||
static void pbytevector(ptr x) {
|
||||
iptr n;
|
||||
|
||||
putchar('#');
|
||||
n = Sbytevector_length(x);
|
||||
wrint(FIX(n));
|
||||
printf("vu8(");
|
||||
if (n != 0) {
|
||||
iptr i = 0;
|
||||
|
||||
while (1) {
|
||||
pfixnum(FIX(Sbytevector_u8_ref(x, i)));
|
||||
if (++i == n) break;
|
||||
putchar(' ');
|
||||
}
|
||||
}
|
||||
putchar(')');
|
||||
}
|
||||
|
||||
static void pflonum(ptr x) {
|
||||
char buf[256], *s;
|
||||
|
||||
/* use snprintf to get it in a string */
|
||||
(void) snprintf(buf, 256, "%.16g",FLODAT(x));
|
||||
|
||||
/* print the silly thing */
|
||||
printf("%s", buf);
|
||||
|
||||
/* add .0 if it looks like an integer */
|
||||
s = buf;
|
||||
while (*s != 'E' && *s != 'e' && *s != '.')
|
||||
if (*s++ == 0) {
|
||||
printf(".0");
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
static void pfixnum(ptr x) {
|
||||
if (UNFIX(x) < 0) {
|
||||
putchar('-');
|
||||
x = S_sub(FIX(0), x);
|
||||
}
|
||||
wrint(x);
|
||||
}
|
||||
|
||||
static void pbignum(ptr x) {
|
||||
if (BIGSIGN(x)) {
|
||||
putchar('-');
|
||||
x = S_sub(FIX(0), x);
|
||||
}
|
||||
wrint(x);
|
||||
}
|
||||
|
||||
static void wrint(ptr x) {
|
||||
ptr q, r;
|
||||
|
||||
S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r);
|
||||
if (q != 0) wrint(q);
|
||||
putchar((INT)UNFIX(r) + '0');
|
||||
}
|
||||
Reference in a new issue