Menu
▾
▴
clisp-cvs Digest, Vol 27, Issue 36
|
From: <cli...@li...> - 2008-07-21 17:58:08
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src pprint.lisp,1.15,1.16 (Sam Steingold) 2. clisp/tests iofkts.tst,1.51,1.52 ChangeLog,1.570,1.571 (Sam Steingold) 3. clisp/src ChangeLog,1.6404,1.6405 (Sam Steingold) 4. clisp/src io.d,1.348,1.349 (Sam Steingold) 5. clisp/tests ChangeLog,1.570,1.571 iofkts.tst,1.51,1.52 (Sam Steingold) 6. clisp/src pprint.lisp,1.15,1.16 (Sam Steingold) 7. clisp/src ChangeLog,1.6405,1.6406 encoding.d,1.160,1.161 (Sam Steingold) 8. clisp/utils clispload.lsp,1.53,1.54 (Sam Steingold) 9. clisp/src ChangeLog,1.6406,1.6407 (Sam Steingold) 10. clisp/utils clispload.lsp,1.54,1.55 (Sam Steingold) 11. clisp/src ChangeLog, 1.6407, 1.6408 NEWS, 1.472, 1.473 constsym.d, 1.369, 1.370 pathname.d, 1.462, 1.463 spvw.d, 1.436, 1.437 (Sam Steingold) ---------------------------------------------------------------------- Message: 1 Date: Mon, 21 Jul 2008 14:52:23 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src pprint.lisp,1.15,1.16 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv27511/src Modified Files: pprint.lisp Log Message: src/ChangeLog Index: pprint.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/pprint.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- pprint.lisp 31 Jan 2008 02:56:47 -0000 1.15 +++ pprint.lisp 21 Jul 2008 14:52:21 -0000 1.16 @@ -59,20 +59,21 @@ (setq top (car tail))) (pop tail)))) -(defun copy-pprint-dispatch (&optional (table nil table-p)) ; ABI +(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) ; ABI ;; table ---a pprint dispatch table, or nil. ;; value: ;; new-table---a fresh pprint dispatch table. - (if table-p - (if table - (if (pprint-dispatch-p table) - (copy-alist table) - (error-of-type 'type-error - :datum table :expected-type '(satisfies pprint-dispatch-p) - (TEXT "~S: ~S is not a valid print dispatch table") - 'copy-pprint-dispatch table)) - (make-pprint-dispatch)) - *print-pprint-dispatch*)) + ;; Creates and returns a copy of the specified table, + ;; or of the value of *print-pprint-dispatch* if no table is specified, + ;; or of the initial value of *print-pprint-dispatch* if nil is specified. + (if table + (if (pprint-dispatch-p table) + (copy-alist table) + (error-of-type 'type-error + :datum table :expected-type '(satisfies pprint-dispatch-p) + (TEXT "~S: ~S is not a valid print dispatch table") + 'copy-pprint-dispatch table)) + (make-pprint-dispatch))) (defun set-pprint-dispatch (type-specifier function &optional (priority 0) (table *print-pprint-dispatch*)) ------------------------------ Message: 2 Date: Mon, 21 Jul 2008 14:52:23 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/tests iofkts.tst,1.51,1.52 ChangeLog,1.570,1.571 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv27511/tests Modified Files: iofkts.tst ChangeLog Log Message: src/ChangeLog Index: iofkts.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/iofkts.tst,v retrieving revision 1.51 retrieving revision 1.52 diff -u -d -r1.51 -r1.52 --- iofkts.tst 20 Jul 2008 14:56:12 -0000 1.51 +++ iofkts.tst 21 Jul 2008 14:52:21 -0000 1.52 @@ -885,7 +885,8 @@ "FOO:(123.)" ;; http://article.gmane.org/gmane.lisp.clisp.devel:17529 -(eq *print-pprint-dispatch* (copy-pprint-dispatch)) T +;; required by ANSI, tested by COPY-PPRINT-DISPATCH.[145] +(eq *print-pprint-dispatch* (copy-pprint-dispatch)) NIL ;; https://sourceforge.net/tracker/?func=detail&atid=101355&aid=1834193&group_id=1355 (with-output-to-string (s) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.570 retrieving revision 1.571 diff -u -d -r1.570 -r1.571 --- ChangeLog 18 Jul 2008 20:27:05 -0000 1.570 +++ ChangeLog 21 Jul 2008 14:52:21 -0000 1.571 @@ -1,3 +1,7 @@ +2008-07-20 Sam Steingold <sd...@gn...> + + * iofkts.tst: (copy-pprint-dispatch) returns a fresh object + 2008-07-18 Sam Steingold <sd...@gn...> * iofkts.tst: enable the formerly risky test ------------------------------ Message: 3 Date: Mon, 21 Jul 2008 14:55:50 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6404,1.6405 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv28631/src Modified Files: ChangeLog Log Message: (copy-pprint-dispatch): as per ANSI, when no table is specified, return a COPY of *PRINT-PPRINT-DISPATCH*, not its value Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6404 retrieving revision 1.6405 diff -u -d -r1.6404 -r1.6405 --- ChangeLog 20 Jul 2008 14:56:13 -0000 1.6404 +++ ChangeLog 21 Jul 2008 14:55:47 -0000 1.6405 @@ -1,7 +1,12 @@ 2008-07-20 Sam Steingold <sd...@gn...> + * pprint.lisp (copy-pprint-dispatch): as per ANSI, when no table + is specified, return a COPY of *PRINT-PPRINT-DISPATCH*, not its value + +2008-07-20 Sam Steingold <sd...@gn...> + * io.d (justify_empty_2): concatenate all strings in a single-liner - into one string instead of pushing all the compoments into the block + into one string instead of pushing all the components into the block 2008-07-18 Sam Steingold <sd...@gn...> ------------------------------ Message: 4 Date: Mon, 21 Jul 2008 15:04:10 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src io.d,1.348,1.349 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv31799/src Modified Files: io.d Log Message: (justify_empty_2): concatenate all strings in a single-liner into one string instead of pushing all the components into the block Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.348 retrieving revision 1.349 diff -u -d -r1.348 -r1.349 --- io.d 18 Jul 2008 20:27:04 -0000 1.348 +++ io.d 21 Jul 2008 15:04:08 -0000 1.349 @@ -5767,20 +5767,44 @@ can trigger GC */ local maygc void justify_empty_2 (const gcv_object_t* stream_) { var object stream = *stream_; - var object new_cons = TheStream(stream)->strm_pphelp_strings; + var object new_cons; /* extend SYS::*PRIN-JBLOCKS* by the content of the Stream: */ - if (eq(TheStream(stream)->strm_pphelp_modus,mehrzeiler) /* multi-liner. */ - || !nullp(Cdr(new_cons))) { /* many strings in the stream */ + if (eq(TheStream(stream)->strm_pphelp_modus,mehrzeiler)) { /* multi-liner. */ /* (push strings SYS::*PRIN-JBLOCKS*) */ new_cons = allocate_cons(); /* new Cons */ Car(new_cons) = TheStream(*stream_)->strm_pphelp_strings; - } /* else: single-liner & single string in the stream - (push (first strings) SYS::*PRIN-JBLOCKS*), or shorter: - (setq SYS::*PRIN-JBLOCKS* (rplacd strings SYS::*PRIN-JBLOCKS*)) */ + } else { /* single-liner. */ + /* collect all constituent strings into one */ + var uintL needed_len = 0; + var uintL string_count = 0; + new_cons = TheStream(stream)->strm_pphelp_strings; + for (; consp(new_cons); new_cons = Cdr(new_cons)) + if (stringp(Car(new_cons))) { + pushSTACK(Car(new_cons)); + needed_len += vector_length(STACK_0); + string_count++; + } + if (--string_count) { /* more than 1 string */ + STACK_0 = ssstring_extend(STACK_0,needed_len); + var cint32* ptr = TheS32string(TheIarray(STACK_0)->data)->data + + vector_length(STACK_0); + do { /* append STACK_1 to STACK_0 and drop STACK_1 */ + var uintL len = vector_length(STACK_1); + var cint32* ptr1 = TheS32string(TheIarray(STACK_1)->data)->data; + while (len--) *ptr++ = *ptr1++; + STACK_1 = STACK_0; + skipSTACK(1); + } while (--string_count); + TheIarray(STACK_0)->dims[1] = needed_len; + Car(TheStream(*stream_)->strm_pphelp_strings) = popSTACK(); + } else skipSTACK(1); /* drop the only string */ + /* (push (first strings) SYS::*PRIN-JBLOCKS*), or shorter: + (setq SYS::*PRIN-JBLOCKS* (rplacd strings SYS::*PRIN-JBLOCKS*)) */ + new_cons = TheStream(*stream_)->strm_pphelp_strings; + } Cdr(new_cons) = Symbol_value(S(prin_jblocks)); Symbol_value(S(prin_jblocks)) = new_cons; } - /* UP: prints space, which can be stretched with Justify. justify_space(&stream); > stream: Stream ------------------------------ Message: 5 Date: Mon, 21 Jul 2008 15:04:52 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/tests ChangeLog,1.570,1.571 iofkts.tst,1.51,1.52 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv32090/tests Modified Files: ChangeLog iofkts.tst Log Message: (copy-pprint-dispatch): as per ANSI, when no table is specified, return a COPY of *PRINT-PPRINT-DISPATCH*, not its value Index: iofkts.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/iofkts.tst,v retrieving revision 1.51 retrieving revision 1.52 diff -u -d -r1.51 -r1.52 --- iofkts.tst 20 Jul 2008 14:56:12 -0000 1.51 +++ iofkts.tst 21 Jul 2008 15:04:50 -0000 1.52 @@ -885,7 +885,8 @@ "FOO:(123.)" ;; http://article.gmane.org/gmane.lisp.clisp.devel:17529 -(eq *print-pprint-dispatch* (copy-pprint-dispatch)) T +;; required by ANSI, tested by COPY-PPRINT-DISPATCH.[145] +(eq *print-pprint-dispatch* (copy-pprint-dispatch)) NIL ;; https://sourceforge.net/tracker/?func=detail&atid=101355&aid=1834193&group_id=1355 (with-output-to-string (s) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.570 retrieving revision 1.571 diff -u -d -r1.570 -r1.571 --- ChangeLog 18 Jul 2008 20:27:05 -0000 1.570 +++ ChangeLog 21 Jul 2008 15:04:50 -0000 1.571 @@ -1,3 +1,7 @@ +2008-07-20 Sam Steingold <sd...@gn...> + + * iofkts.tst: (copy-pprint-dispatch) returns a fresh object + 2008-07-18 Sam Steingold <sd...@gn...> * iofkts.tst: enable the formerly risky test ------------------------------ Message: 6 Date: Mon, 21 Jul 2008 15:04:52 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src pprint.lisp,1.15,1.16 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv32090/src Modified Files: pprint.lisp Log Message: (copy-pprint-dispatch): as per ANSI, when no table is specified, return a COPY of *PRINT-PPRINT-DISPATCH*, not its value Index: pprint.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/pprint.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- pprint.lisp 31 Jan 2008 02:56:47 -0000 1.15 +++ pprint.lisp 21 Jul 2008 15:04:50 -0000 1.16 @@ -59,20 +59,21 @@ (setq top (car tail))) (pop tail)))) -(defun copy-pprint-dispatch (&optional (table nil table-p)) ; ABI +(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) ; ABI ;; table ---a pprint dispatch table, or nil. ;; value: ;; new-table---a fresh pprint dispatch table. - (if table-p - (if table - (if (pprint-dispatch-p table) - (copy-alist table) - (error-of-type 'type-error - :datum table :expected-type '(satisfies pprint-dispatch-p) - (TEXT "~S: ~S is not a valid print dispatch table") - 'copy-pprint-dispatch table)) - (make-pprint-dispatch)) - *print-pprint-dispatch*)) + ;; Creates and returns a copy of the specified table, + ;; or of the value of *print-pprint-dispatch* if no table is specified, + ;; or of the initial value of *print-pprint-dispatch* if nil is specified. + (if table + (if (pprint-dispatch-p table) + (copy-alist table) + (error-of-type 'type-error + :datum table :expected-type '(satisfies pprint-dispatch-p) + (TEXT "~S: ~S is not a valid print dispatch table") + 'copy-pprint-dispatch table)) + (make-pprint-dispatch))) (defun set-pprint-dispatch (type-specifier function &optional (priority 0) (table *print-pprint-dispatch*)) ------------------------------ Message: 7 Date: Mon, 21 Jul 2008 15:17:47 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6405,1.6406 encoding.d,1.160,1.161 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv4587/src Modified Files: ChangeLog encoding.d Log Message: do not #include <stdio.h>, it is already done by lispbibl Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6405 retrieving revision 1.6406 diff -u -d -r1.6405 -r1.6406 --- ChangeLog 21 Jul 2008 14:55:47 -0000 1.6405 +++ ChangeLog 21 Jul 2008 15:17:45 -0000 1.6406 @@ -1,3 +1,7 @@ +2008-07-21 Sam Steingold <sd...@gn...> + + * encoding.d: do not #include <stdio.h>, it is already done by lispbibl + 2008-07-20 Sam Steingold <sd...@gn...> * pprint.lisp (copy-pprint-dispatch): as per ANSI, when no table Index: encoding.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/encoding.d,v retrieving revision 1.160 retrieving revision 1.161 diff -u -d -r1.160 -r1.161 --- encoding.d 16 Jul 2008 02:48:54 -0000 1.160 +++ encoding.d 21 Jul 2008 15:17:45 -0000 1.161 @@ -7,7 +7,6 @@ #include "lispbibl.c" #include <string.h> /* declares memcpy() */ -#include <stdio.h> /* declares fprintf() */ #ifdef UNICODE #include "localcharset.h" /* from gnulib */ ------------------------------ Message: 8 Date: Mon, 21 Jul 2008 16:09:35 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/utils clispload.lsp,1.53,1.54 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/utils In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv24063/utils Modified Files: clispload.lsp Log Message: (*pprint-first-newline*): set to NIL to conform to Paul's expectations Index: clispload.lsp =================================================================== RCS file: /cvsroot/clisp/clisp/utils/clispload.lsp,v retrieving revision 1.53 retrieving revision 1.54 diff -u -d -r1.53 -r1.54 --- clispload.lsp 18 Nov 2005 18:54:12 -0000 1.53 +++ clispload.lsp 21 Jul 2008 16:09:33 -0000 1.54 @@ -257,6 +257,9 @@ )) +;; for the pretty-printer +(setq custom:*pprint-first-newline* nil) + ;; For ENSURE-DIRECTORIES-EXIST.8 (when (ext:probe-directory "scratch/") (mapc #'delete-file (directory "scratch/*")) ------------------------------ Message: 9 Date: Mon, 21 Jul 2008 16:09:35 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6406,1.6407 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv24063/src Modified Files: ChangeLog Log Message: (*pprint-first-newline*): set to NIL to conform to Paul's expectations Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6406 retrieving revision 1.6407 diff -u -d -r1.6406 -r1.6407 --- ChangeLog 21 Jul 2008 15:17:45 -0000 1.6406 +++ ChangeLog 21 Jul 2008 16:09:33 -0000 1.6407 @@ -1,5 +1,10 @@ 2008-07-21 Sam Steingold <sd...@gn...> + * utils/clispload.lsp (*pprint-first-newline*): set to NIL to + conform to Paul's expenctations + +2008-07-21 Sam Steingold <sd...@gn...> + * encoding.d: do not #include <stdio.h>, it is already done by lispbibl 2008-07-20 Sam Steingold <sd...@gn...> ------------------------------ Message: 10 Date: Mon, 21 Jul 2008 17:57:49 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/utils clispload.lsp,1.54,1.55 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/utils In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv31499/utils Modified Files: clispload.lsp Log Message: New user variable CUSTOM:*REOPEN-OPEN-FILE* controls CLISP behavior when opening an already open file. Index: clispload.lsp =================================================================== RCS file: /cvsroot/clisp/clisp/utils/clispload.lsp,v retrieving revision 1.54 retrieving revision 1.55 diff -u -d -r1.54 -r1.55 --- clispload.lsp 21 Jul 2008 16:09:33 -0000 1.54 +++ clispload.lsp 21 Jul 2008 17:57:47 -0000 1.55 @@ -260,6 +260,10 @@ ;; for the pretty-printer (setq custom:*pprint-first-newline* nil) +;; for READ-BYTE.ERROR.3 READ-BYTE.ERROR.4 READ-BYTE.ERROR.6 +;; WRITE-BYTE.ERROR.3 OPEN.66 OPEN.OUTPUT.30 +(setq custom:*reopen-open-file* 'warn) + ;; For ENSURE-DIRECTORIES-EXIST.8 (when (ext:probe-directory "scratch/") (mapc #'delete-file (directory "scratch/*")) ------------------------------ Message: 11 Date: Mon, 21 Jul 2008 17:57:49 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog, 1.6407, 1.6408 NEWS, 1.472, 1.473 constsym.d, 1.369, 1.370 pathname.d, 1.462, 1.463 spvw.d, 1.436, 1.437 To: cli...@li... Message-ID: <E1K...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv31499/src Modified Files: ChangeLog NEWS constsym.d pathname.d spvw.d Log Message: New user variable CUSTOM:*REOPEN-OPEN-FILE* controls CLISP behavior when opening an already open file. Index: spvw.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw.d,v retrieving revision 1.436 retrieving revision 1.437 diff -u -d -r1.436 -r1.437 --- spvw.d 6 Jul 2008 22:50:29 -0000 1.436 +++ spvw.d 21 Jul 2008 17:57:43 -0000 1.437 @@ -1289,6 +1289,7 @@ define_variable(S(print_empty_arrays_ansi),NIL); /* CUSTOM:*PRINT-EMPTY-ARRAYS-ANSI* */ define_variable(S(print_unreadable_ansi),NIL); /* CUSTOM:*PRINT-UNREADABLE-ANSI* */ define_variable(S(parse_namestring_ansi),NIL); /* CUSTOM:*PARSE-NAMESTRING-ANSI* */ + define_variable(S(reopen_open_file),S(error)); /* CUSTOM:*REOPEN-OPEN-FILE* */ #ifdef PATHNAME_NOEXT define_variable(S(parse_namestring_dot_file),S(Ktype)); /* CUSTOM:*PARSE-NAMESTRING-DOT-FILE* */ #endif Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.462 retrieving revision 1.463 diff -u -d -r1.462 -r1.463 --- pathname.d 17 Jul 2008 19:39:33 -0000 1.462 +++ pathname.d 21 Jul 2008 17:57:42 -0000 1.463 @@ -6600,9 +6600,9 @@ /* UP: check that the file we are about to open has not been opened yet > object truename - the name of the file that is being opened > direction_t direction - the direction of the pending OPEN - can trigger GC - if CERROR is signaled */ + can trigger GC - if CERROR or WARNING is signaled */ extern void* find_open_file (struct file_id *fid, void* data); -local maygc void check_file_re_open (object truename, direction_t direction) { +local maygc void check_file_reopen (object truename, direction_t direction) { var uintB flags; switch (direction) { case DIRECTION_INPUT_IMMUTABLE: case DIRECTION_INPUT: @@ -6621,18 +6621,29 @@ if (ret) bad_stream = popSTACK(); }); if (!eq(bad_stream,nullobj)) { /* found an existing open stream */ - pushSTACK(NIL); /* 8: continue-format-string */ - pushSTACK(S(file_error)); /* 7: error type */ - pushSTACK(S(Kpathname)); /* 6: :PATHNAME */ - pushSTACK(truename); /* 5: the offending pathname */ - pushSTACK(NIL); /* 4: error-format-string */ - pushSTACK(TheSubr(subr_self)->name); /* 3: caller */ - pushSTACK(bad_stream); /* 2: bad stream */ - pushSTACK(truename); /* 1: truename */ - pushSTACK(direction_symbol(direction)); /* 0: direction */ - STACK_8 = CLSTEXT("Open the file anyway"); /* continue-format-string */ - STACK_4 = CLSTEXT("~S: ~S already points to file ~S, opening the file again for ~S may produce unexpected results"); /* error-format-string */ - funcall(L(cerror_of_type),9); + #define error_format_string CLSTEXT("~S: ~S already points to file ~S, opening the file again for ~S may produce unexpected results") + if (eq(Symbol_value(S(reopen_open_file)),S(error))) { + pushSTACK(NIL); /* 8: continue-format-string */ + pushSTACK(S(file_error)); /* 7: error type */ + pushSTACK(S(Kpathname)); /* 6: :PATHNAME */ + pushSTACK(truename); /* 5: the offending pathname */ + pushSTACK(NIL); /* 4: error-format-string */ + pushSTACK(TheSubr(subr_self)->name); /* 3: caller */ + pushSTACK(bad_stream); /* 2: bad stream */ + pushSTACK(truename); /* 1: truename */ + pushSTACK(direction_symbol(direction)); /* 0: direction */ + STACK_8 = CLSTEXT("Open the file anyway"); /* continue-format-string */ + STACK_4 = error_format_string; + funcall(L(cerror_of_type),9); + } else if (eq(Symbol_value(S(reopen_open_file)),S(warn))) { + pushSTACK(error_format_string); /* 0 */ + pushSTACK(TheSubr(subr_self)->name); /* 1: caller */ + pushSTACK(bad_stream); /* 2: bad stream */ + pushSTACK(truename); /* 3: truename */ + pushSTACK(direction_symbol(direction)); /* 4: direction */ + funcall(S(warn),5); + } + #undef error_format_string } } @@ -6670,7 +6681,8 @@ *namestring_ = fs.fs_namestring; /* stack layout: Namestring, Pathname, Truename check filename and get the handle: */ - check_file_re_open(*namestring_,direction); + if (!nullpSv(reopen_open_file)) + check_file_reopen(*namestring_,direction); var object handle; {var bool append_flag = false; var bool wronly_flag = false; Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.369 retrieving revision 1.370 diff -u -d -r1.369 -r1.370 --- constsym.d 16 Jul 2008 14:56:11 -0000 1.369 +++ constsym.d 21 Jul 2008 17:57:42 -0000 1.370 @@ -662,6 +662,7 @@ LISPSYM(rename_file,"RENAME-FILE",lisp) LISPSYM(file_error,"FILE-ERROR",lisp) LISPSYM(open,"OPEN",lisp) +LISPSYM(reopen_open_file,"*REOPEN-OPEN-FILE*",custom) LISPSYM(directory,"DIRECTORY",lisp) LISPSYM(cd,"CD",ext) LISPSYM(make_directory,"MAKE-DIRECTORY",ext) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6407 retrieving revision 1.6408 diff -u -d -r1.6407 -r1.6408 --- ChangeLog 21 Jul 2008 16:09:33 -0000 1.6407 +++ ChangeLog 21 Jul 2008 17:57:41 -0000 1.6408 @@ -1,7 +1,16 @@ 2008-07-21 Sam Steingold <sd...@gn...> + * pathname.d (check_file_reopen): when *REOPEN-OPEN-FILE* is WARN, + issue a warning instead of signaling an error + * constsym.d (check_file_reopen): declare + * spvw.d (init_symbol_values): init *REOPEN-OPEN-FILE* to ERROR + * utils/clispload.lsp (*reopen-open-file*): set to WARN to pacify + 6 tests + +2008-07-21 Sam Steingold <sd...@gn...> + * utils/clispload.lsp (*pprint-first-newline*): set to NIL to - conform to Paul's expenctations + conform to Paul's expectations 2008-07-21 Sam Steingold <sd...@gn...> Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.472 retrieving revision 1.473 diff -u -d -r1.472 -r1.473 --- NEWS 17 Jul 2008 19:51:29 -0000 1.472 +++ NEWS 21 Jul 2008 17:57:42 -0000 1.473 @@ -9,6 +9,10 @@ before processing it. See <http://clisp.cons.org/impnotes/macros3.html#canonicalize> for details. +* New user variable CUSTOM:*REOPEN-OPEN-FILE* controls CLISP behavior + when opening an already open file. + See <http://clisp.cons.org/impnotes/open.html#reopen> for details. + * LOAD now uses DIRECTORY only for wild *LOAD-PATHS* components, thus speeding up the most common cases and preventing the denial-of-service attack whereas CLISP would not start if a file with a name ------------------------------ ------------------------------------------------------------------------- This SF.Net email is sponsored by the Moblin Your Move Developer's challenge Build the coolest Linux based applications with Moblin SDK & win great prizes Grand prize is a trip for two to an Open Source event anywhere in the world http://moblin-contest.org/redirect.php?banner_id=100&url=/ ------------------------------ _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest, Vol 27, Issue 36 ***************************************** |