Commit 60bd9995 authored by Erick's avatar Erick

Modified display to be R7RS (no loop on cyclic structures).

parent e6c0837e
/*
*
* e r r o r . c -- The error procedure
* e r r o r . c -- The error procedure
*
* Copyright © 1993-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 14-Nov-1993 14:58
* Last file update: 30-May-2007 16:27 (eg)
* Last file update: 23-Aug-2018 15:07 (eg)
*/
#include "stklos.h"
......@@ -40,8 +40,8 @@
* %% for printing a '%'
* ~A for printing a Scheme object in display mode
* ~S for printing a Scheme object in write mode
* ~W for printing a Scheme object in write mode (circular)
* ~% for printing a newline
* ~W for printing a Scheme object in write mode (circular)
* ~% for printing a newline
* ~~ for printing a tilde character
*
\*===========================================================================*/
......@@ -64,50 +64,50 @@ static void print_format(SCM port,char *format, va_list ap)
if (*s == '%') {
/* % format (C-like) */
switch (*++s) {
case '%': STk_putc('%', port); break;
case 'S': STk_putc('`', port); /* No break */
case 's': for (str = va_arg(ap, char *); *str; str++)
STk_putc(*str, port);
if (*s == 'S') STk_putc('\'', port);
break;
case 'c': STk_putc(va_arg(ap, int), port); break;
case 'x': print_int(port, va_arg(ap, unsigned int), 16); break;
case 'd': {
int val = va_arg(ap, unsigned int);
if (val < 0) {
STk_putc('-', port);
print_int(port, -val, 10);
}
else
print_int(port, val, 10);
break;
}
default: STk_putc('%', port);
if (*s) STk_putc(*s, port);
break;
case '%': STk_putc('%', port); break;
case 'S': STk_putc('`', port); /* No break */
case 's': for (str = va_arg(ap, char *); *str; str++)
STk_putc(*str, port);
if (*s == 'S') STk_putc('\'', port);
break;
case 'c': STk_putc(va_arg(ap, int), port); break;
case 'x': print_int(port, va_arg(ap, unsigned int), 16); break;
case 'd': {
int val = va_arg(ap, unsigned int);
if (val < 0) {
STk_putc('-', port);
print_int(port, -val, 10);
}
else
print_int(port, val, 10);
break;
}
default: STk_putc('%', port);
if (*s) STk_putc(*s, port);
break;
}
} else if (*s == '~') {
/* ~ format (CL like) */
switch (*++s) {
case 'A': STk_putc('`', port); /* No break */
case 'a': STk_print(va_arg(ap, SCM), port, DSP_MODE);
if (*s == 'A') STk_putc('\'', port);
break;
case 'W': STk_putc('`', port); /* No break */
case 'w': STk_print_star(va_arg(ap, SCM), port);
if (*s == 'W') STk_putc('\'', port);
break;
case 'S': STk_putc('`', port); /* No break */
case 's': STk_print(va_arg(ap, SCM), port, WRT_MODE);
if (*s == 'S') STk_putc('\'', port);
break;
case '~': STk_putc('~', port); break;
case '%': STk_putc('\n', port); break;
default: STk_putc('~', port);
if (*s) STk_putc(*s, port);
break;
case 'A': STk_putc('`', port); /* No break */
case 'a': STk_print(va_arg(ap, SCM), port, DSP_MODE);
if (*s == 'A') STk_putc('\'', port);
break;
case 'W': STk_putc('`', port); /* No break */
case 'w': STk_print_star(va_arg(ap, SCM), port,WRT_MODE);
if (*s == 'W') STk_putc('\'', port);
break;
case 'S': STk_putc('`', port); /* No break */
case 's': STk_print(va_arg(ap, SCM), port, WRT_MODE);
if (*s == 'S') STk_putc('\'', port);
break;
case '~': STk_putc('~', port); break;
case '%': STk_putc('\n', port); break;
default: STk_putc('~', port);
if (*s) STk_putc(*s, port);
break;
}
} else {
/* Normal character */
......@@ -237,8 +237,8 @@ void STk_panic(char *format, ...)
void STk_signal(char *str)
{
STk_raise_exception(STk_make_C_cond(STk_message_condition,
1,
STk_Cstring2string(str)));
1,
STk_Cstring2string(str)));
}
......@@ -260,7 +260,7 @@ void STk_debug(char *format, ...)
STk_flush(eport);
}
void STk_gdb(SCM obj) /* associated to the gdb write function */
void STk_gdb(SCM obj) /* associated to the gdb write function */
{
STk_debug("Object 0x%lx value = ~s", (unsigned long) obj, obj);
}
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 22-Aug-2018 16:14 (eg)
* Last file update: 23-Aug-2018 15:45 (eg)
*
*/
......@@ -665,12 +665,12 @@ doc>
DEFINE_PRIMITIVE("write*", write_star, subr12, (SCM expr, SCM port))
{
port = verify_port(port, PORT_WRITE | PORT_TEXTUAL);
STk_print_star(expr, port);
STk_print_star(expr, port, WRT_MODE);
return STk_void;
}
/*
<doc display
<doc display
* (display obj)
* (display obj port)
*
......@@ -684,15 +684,19 @@ DEFINE_PRIMITIVE("write*", write_star, subr12, (SCM expr, SCM port))
* @l
* ,(bold "Rationale:") |Write| is intended for producing machine-readable
* output and |display| is for producing human-readable output.
* @l
* ,(bold "Note:") As required by ,(rseven) does not loop forever when
* |obj| contains self-references.
doc>
*/
DEFINE_PRIMITIVE("display", display, subr12, (SCM expr, SCM port))
{
port = verify_port(port, PORT_WRITE | PORT_TEXTUAL);
STk_print(expr, port, DSP_MODE);
STk_print_star(expr, port, DSP_MODE);
return STk_void;
}
/*
<doc newline
* (newline)
......@@ -883,7 +887,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
break;
case 'W':
case 'w': if (argc-- <= 0) goto TooMuch;
STk_print_star(*argv--, port);
STk_print_star(*argv--, port, WRT_MODE);
break;
case 'X':
case 'x': if (argc-- <= 0) goto TooMuch;
......
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 5-Aug-2018 17:23 (eg)
* Last file update: 23-Aug-2018 15:06 (eg)
*/
......@@ -1034,12 +1034,12 @@ extern int STk_interactive; /* We are in intearctive mode */
----
------------------------------------------------------------------------------
*/
void STk_print(SCM exp, SCM port, int mode);
void STk_print_star(SCM exp, SCM port);
#define DSP_MODE 0
#define WRT_MODE 1
void STk_print(SCM exp, SCM port, int mode);
void STk_print_star(SCM exp, SCM port, int mode);
int STk_init_printer(void);
/*
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 22-Aug-2018 16:23 (eg)
;;;; Last file update: 23-Aug-2018 15:52 (eg)
;;;;
(require "test")
......@@ -528,21 +528,38 @@
bv))
;; --------------------------------------------------
(let* ((x '(a b c d))
(y (list x x)))
(test "write-simple"
"((a b c d) (a b c d))"
(let ((out (open-output-string)))
(test "write-simple"
"((a b c d) (a b c d))"
(let* ((x '(a b c d))
(y (list x x))
(out (open-output-string)))
(write-simple y out)
(get-output-string out))))
(let* ((x '(a b c d))
(y (list x x)))
(test "write-shared"
"(#0=(a b c d) #0#)"
(let ((out (open-output-string)))
(write-shared y out)
(get-output-string out))))
(get-output-string out)))
(test "write-shared"
"(#0=(a b c d) #0#)"
(let* ((x '(a b c d))
(y (list x x))
(out (open-output-string)))
(write-shared y out)
(get-output-string out)))
(test "display (cyclic list).1"
"(#0=(abc def A foo) #0#)"
(let* ((x '("abc" "def" #\A foo))
(y (list x x))
(out (open-output-string)))
(display y out)
(get-output-string out)))
(test "write-shared (cyclic list).1"
"(#0=(\"abc\" \"def\" #\\A foo) #0#)"
(let* ((x '("abc" "def" #\A foo))
(y (list x x))
(out (open-output-string)))
(write-shared y out)
(get-output-string out)))
;; --------------------------------------------------
(test "chibi write-string.1"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment