Commit 5a7d8182 authored by Erick's avatar Erick

Added the R7RS function write-shared & write-simple

parent b5a87929
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 3-Aug-2018 18:48 (eg)
;;;; Last file update: 22-Aug-2018 13:03 (eg)
;;;;
......@@ -29,6 +29,7 @@
(define read-chars read-bytes)
(define read-chars! read-bytes!)
#|
<doc EXT gensym
* (gensym)
......
......@@ -21,9 +21,16 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 19-Aug-2018 09:38 (eg)
;;;; Last file update: 22-Aug-2018 13:03 (eg)
;;;;
;;;; Aliases
(define write-shared write*)
(define write-simple write)
;;;; ----------------------------------------------------------------------
;;;; 6.3 Booleans
;;;; ----------------------------------------------------------------------
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 19-Aug-2018 09:38 (eg)
* Last file update: 22-Aug-2018 12:59 (eg)
*
*/
......@@ -627,15 +627,19 @@ DEFINE_PRIMITIVE("write", write, subr12, (SCM expr, SCM port))
/*
<doc EXT write*
* (write* obj)
* (write* obj port)
<doc R7RS write* write-shared
* (write-shared obj)
* (write-shared obj port)
*
* Writes a written representation of |obj| to the given port. The
* main difference with the |write| procedure is that |write*|
* handles data structures with cycles. Circular structure written by
* this procedure use the ,(code (q "#n=")) and ,(code (q "#n#"))
* notations (see ,(ref :mark "Circular structure")).
* @l
* ,(bold "Note:") This function is also called |write*|.
* The name |write*| was the name used by ,(stklos) for
* |write-shared| before it was introduced in ,(rseven).
*
doc>
<doc EXT write-with-shared-structure
......
/*
* vport.c -- Virtual Ports
* vport.c -- Virtual Ports
*
* Copyright © 2005-2012 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright © 2005-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,16 +21,16 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 17-Aug-2005 08:31 (eg)
* Last file update: 18-Mar-2012 18:47 (eg)
* Last file update: 20-Aug-2018 11:23 (eg)
*/
#include "stklos.h"
struct vstream {
SCM port; /* circular reference to find back the port */
SCM getc, readyp, eofp; /* input port */
SCM putc, putstring, flush; /* output port */
SCM close; /* input & output port */
SCM port; /* circular reference to find back the port */
SCM getc, readyp, eofp; /* input port */
SCM putc, putstring, flush; /* output port */
SCM close; /* input & output port */
};
......@@ -58,9 +58,9 @@ static void vport_print(SCM obj, SCM port) /* Generic printing of virtual port
char buffer[MAX_PATH_LENGTH + 20];
sprintf(buffer, "#[%s-virtual-port %lx%s]",
IVPORTP(obj) ? "input" : "output",
(unsigned long) obj,
PORT_IS_CLOSEDP(obj) ? " (closed)" : "");
IVPORTP(obj) ? "input" : "output",
(unsigned long) obj,
PORT_IS_CLOSEDP(obj) ? " (closed)" : "");
STk_puts(buffer, port);
}
......@@ -274,28 +274,28 @@ DEFINE_PRIMITIVE("%open-input-virtual", open_input_vport, subr1, (SCM v))
vs->port = z;
vs->putc = vs->putstring = vs->flush = NULL;
PORT_STREAM(z) = vs;
PORT_FLAGS(z) = PORT_READ | PORT_IS_VIRTUAL | flag;
PORT_UNGETC(z) = EOF;
PORT_LINE(z) = 1;
PORT_POS(z) = 0;
PORT_FNAME(z) = "virtual input port";
PORT_CLOSEHOOK(z) = STk_false;
PORT_PRINT(z) = vport_print;
PORT_RELEASE(z) = vport_release;
PORT_GETC(z) = call_user_getc;
PORT_READY(z) = call_user_ready;
PORT_EOFP(z) = call_user_eofp;
PORT_CLOSE(z) = call_user_close;
PORT_PUTC(z) = NULL;
PORT_PUTS(z) = NULL;
PORT_PUTSTRING(z) = NULL;
PORT_NPUTS(z) = NULL;
PORT_FLUSH(z) = NULL;
PORT_BREAD(z) = vport_read;
PORT_BWRITE(z) = NULL;
PORT_SEEK(z) = vport_seek;
PORT_STREAM(z) = vs;
PORT_FLAGS(z) = PORT_READ | PORT_IS_VIRTUAL | PORT_TEXTUAL | flag;
PORT_UNGETC(z) = EOF;
PORT_LINE(z) = 1;
PORT_POS(z) = 0;
PORT_FNAME(z) = "virtual input port";
PORT_CLOSEHOOK(z) = STk_false;
PORT_PRINT(z) = vport_print;
PORT_RELEASE(z) = vport_release;
PORT_GETC(z) = call_user_getc;
PORT_READY(z) = call_user_ready;
PORT_EOFP(z) = call_user_eofp;
PORT_CLOSE(z) = call_user_close;
PORT_PUTC(z) = NULL;
PORT_PUTS(z) = NULL;
PORT_PUTSTRING(z) = NULL;
PORT_NPUTS(z) = NULL;
PORT_FLUSH(z) = NULL;
PORT_BREAD(z) = vport_read;
PORT_BWRITE(z) = NULL;
PORT_SEEK(z) = vport_seek;
return (struct port_obj *) z;
}
......@@ -368,27 +368,27 @@ DEFINE_PRIMITIVE("%open-output-virtual", open_output_vport, subr1, (SCM v))
vs->port = z;
vs->getc = vs->readyp = vs->eofp = NULL;
PORT_STREAM(z) = vs;
PORT_FLAGS(z) = PORT_WRITE | PORT_IS_VIRTUAL | flag;
PORT_UNGETC(z) = EOF;
PORT_LINE(z) = 1;
PORT_POS(z) = 0;
PORT_FNAME(z) = "virtual output port";
PORT_PRINT(z) = vport_print;
PORT_RELEASE(z) = vport_release;
PORT_GETC(z) = NULL;
PORT_READY(z) = NULL;
PORT_EOFP(z) = NULL;
PORT_CLOSE(z) = call_user_close;
PORT_PUTC(z) = call_user_putc;
PORT_PUTS(z) = vport_puts;
PORT_PUTSTRING(z) = call_user_putstring;
PORT_NPUTS(z) = vport_nputs;
PORT_FLUSH(z) = call_user_flush;
PORT_BREAD(z) = NULL;
PORT_BWRITE(z) = vport_write;
PORT_SEEK(z) = vport_seek;
PORT_STREAM(z) = vs;
PORT_FLAGS(z) = PORT_WRITE | PORT_IS_VIRTUAL | PORT_TEXTUAL | flag;
PORT_UNGETC(z) = EOF;
PORT_LINE(z) = 1;
PORT_POS(z) = 0;
PORT_FNAME(z) = "virtual output port";
PORT_PRINT(z) = vport_print;
PORT_RELEASE(z) = vport_release;
PORT_GETC(z) = NULL;
PORT_READY(z) = NULL;
PORT_EOFP(z) = NULL;
PORT_CLOSE(z) = call_user_close;
PORT_PUTC(z) = call_user_putc;
PORT_PUTS(z) = vport_puts;
PORT_PUTSTRING(z) = call_user_putstring;
PORT_NPUTS(z) = vport_nputs;
PORT_FLUSH(z) = call_user_flush;
PORT_BREAD(z) = NULL;
PORT_BWRITE(z) = vport_write;
PORT_SEEK(z) = vport_seek;
return (struct port_obj *) z;
}
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 5-Aug-2018 19:40 (eg)
;;;; Last file update: 22-Aug-2018 13:20 (eg)
;;;;
(require "test")
......@@ -527,6 +527,24 @@
(read-bytevector! bv (open-input-bytevector #u8(0 1 2 3 4)) 3 4)
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)))
(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))))
;; --------------------------------------------------
(let ((p (open-output-bytevector)))
(test "write-u8.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