Menu
▾
▴
clisp-cvs digest, Vol 1 #929 - 8 msgs
|
From: <cli...@li...> - 2005-01-27 04:11:04
|
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 compiler.lisp,1.172,1.172.2.1 ChangeLog,1.2750.2.87,1.2750.2.88 (Bruno Haible) 2. clisp/src NEWS,1.231,1.232 (Bruno Haible) 3. clisp/src makemake.in,1.507,1.508 ChangeLog,1.4155,1.4156 (Bruno Haible) 4. clisp/src init.lisp,1.215,1.216 ChangeLog,1.4156,1.4157 NEWS,1.232,1.233 (Bruno Haible) 5. clisp/src macros2.lisp,1.31,1.32 condition.lisp,1.76,1.77 foreign1.lisp,1.79,1.80 (Bruno Haible) 6. clisp/doc impbody.xml,1.355,1.356 (Bruno Haible) 7. clisp/doc impbody.xml,1.356,1.357 (Sam Steingold) 8. clisp/src stream.d,1.500,1.501 ChangeLog,1.4157,1.4158 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src compiler.lisp,1.172,1.172.2.1 ChangeLog,1.2750.2.87,1.2750.2.88 Date: Wed, 26 Jan 2005 13:29:32 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv392/src Modified Files: Tag: clisp_2_33-patched compiler.lisp ChangeLog Log Message: Fix handling of SPECIAL-declared optional variables in inline LAMBDA. Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.172 retrieving revision 1.172.2.1 diff -u -d -r1.172 -r1.172.2.1 --- compiler.lisp 3 Mar 2004 17:56:47 -0000 1.172 +++ compiler.lisp 26 Jan 2005 13:29:26 -0000 1.172.2.1 @@ -5973,6 +5973,7 @@ (let (*specials* *ignores* *ignorables* *readonlys* req-vars req-anodes req-stackzs opt-vars opt-anodes opt-stackzs ; optional and svar together! + optdefaulted-vars optdefaulted-anodes optdefaulted-stackzs rest-vars rest-anodes rest-stackzs fixed-anodes fixed-stackz reqfixed-vars reqfixed-dummys reqfixed-stackzs @@ -6063,30 +6064,43 @@ (return-from main-args (finish-using-applyarg '() optvarr optinitr optsvarr restvar)) - (let* ((svar-init (not (null arglist))) ; = NIL or T - (anode (if svar-init - (progn - (let ((*no-code* t)) - (c-form (car optinitr) 'NIL)) - (let ((*venv* oldvenv) - (*fenv* oldfenv) - (*benv* oldbenv) - (*genv* oldgenv) - (*denv* olddenv)) - (c-form (pop arglist) 'ONE))) - (c-form (car optinitr) 'ONE))) - (var (bind-movable-var (car optvarr) anode))) - (push anode opt-anodes) - (push var opt-vars) - (push *stackz* opt-stackzs) - (push-*venv* var) - (unless (eql (car optsvarr) 0) - (let* ((anode (c-form svar-init 'ONE)) - (var (bind-movable-var (car optsvarr) anode))) - (push anode opt-anodes) - (push var opt-vars) - (push *stackz* opt-stackzs) - (push-*venv* var)))))) + (let ((svar-init (not (null arglist)))) ; = NIL or T + (if svar-init + (progn + (let ((*no-code* t)) + (c-form (car optinitr) 'NIL)) + (let* ((anode + (let ((*venv* oldvenv) + (*fenv* oldfenv) + (*benv* oldbenv) + (*genv* oldgenv) + (*denv* olddenv)) + (c-form (pop arglist) 'ONE))) + (var (bind-movable-var (car optvarr) anode))) + (push anode opt-anodes) + (push var opt-vars) + (push *stackz* opt-stackzs) + (push-*venv* var) + (unless (eql (car optsvarr) 0) + (let* ((anode (c-form svar-init 'ONE)) + (var (bind-movable-var (car optsvarr) anode))) + (push anode opt-anodes) + (push var opt-vars) + (push *stackz* opt-stackzs) + (push-*venv* var))))) + (let* ((anode (c-form (car optinitr) 'ONE)) + (var (bind-movable-var (car optvarr) anode))) + (push anode optdefaulted-anodes) + (push var optdefaulted-vars) + (push *stackz* optdefaulted-stackzs) + (push-*venv* var) + (unless (eql (car optsvarr) 0) + (let* ((anode (c-form svar-init 'ONE)) + (var (bind-movable-var (car optsvarr) anode))) + (push anode optdefaulted-anodes) + (push var optdefaulted-vars) + (push *stackz* optdefaulted-stackzs) + (push-*venv* var)))))))) (if (eql restvar 0) ;; consume further arguments: (when applyarglist @@ -6115,19 +6129,23 @@ (setq opt-vars (nreverse opt-vars)) (setq opt-anodes (nreverse opt-anodes)) (setq opt-stackzs (nreverse opt-stackzs)) + (setq optdefaulted-vars (nreverse optdefaulted-vars)) + (setq optdefaulted-anodes (nreverse optdefaulted-anodes)) + (setq optdefaulted-stackzs (nreverse optdefaulted-stackzs)) ;; activate the bindings of the Aux-Variables: (multiple-value-setq (aux-vars aux-anodes) (bind-aux-vars auxvar auxinit)) (let* ((body-anode (c-form `(PROGN ,@body-rest))) ;; check the variables: (varlist - (append req-vars opt-vars rest-vars + (append req-vars opt-vars optdefaulted-vars rest-vars reqfixed-vars optfixed-vars optsfixed-vars restfixed-vars aux-vars)) (closurevars (append (checking-movable-var-list req-vars req-anodes) (checking-movable-var-list opt-vars opt-anodes) + (checking-movable-var-list optdefaulted-vars optdefaulted-anodes) (checking-movable-var-list rest-vars rest-anodes) (checking-fixed-var-list reqfixed-vars) (checking-fixed-var-list optfixed-vars) @@ -6144,6 +6162,8 @@ (append req-anodes opt-anodes rest-anodes ) (append req-stackzs opt-stackzs rest-stackzs) fixed-anodes)) + ,@(mapcap #'c-bind-movable-var-anode + optdefaulted-vars optdefaulted-anodes) ,@(mapcap #'c-bind-fixed-var reqfixed-vars reqfixed-dummys reqfixed-stackzs) ,@(c-bind-with-svars optfixed-vars optfixed-dummys @@ -6159,14 +6179,14 @@ (make-anode :type 'FUNCALL :sub-anodes - `(,@req-anodes ,@opt-anodes ,@rest-anodes + `(,@req-anodes ,@opt-anodes ,@optdefaulted-anodes ,@rest-anodes ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes) ,@aux-anodes ,body-anode) :seclass (seclass-without (anodelist-seclass-or - `(,@req-anodes ,@opt-anodes ,@rest-anodes + `(,@req-anodes ,@opt-anodes ,@optdefaulted-anodes ,@rest-anodes ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes) ,@aux-anodes ,body-anode)) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2750.2.87 retrieving revision 1.2750.2.88 diff -u -d -r1.2750.2.87 -r1.2750.2.88 --- ChangeLog 25 Jan 2005 09:45:24 -0000 1.2750.2.87 +++ ChangeLog 26 Jan 2005 13:29:27 -0000 1.2750.2.88 @@ -1,3 +1,10 @@ +2005-01-22 Bruno Haible <br...@cl...> + + * compiler.lisp (c-FUNCALL-INLINE): Fix long-standing bug in the + handling of SPECIAL-declared optional variables: If the initforms + of these variables come from the lambdalist, use sequential calls to + c-bind-movable-var-anode instead of c-parallel-bind-movable-var-anode. + 2005-01-24 Bruno Haible <br...@cl...> * stream.d (read_byte, wr_ch_unbuffered_unix, --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src NEWS,1.231,1.232 Date: Wed, 26 Jan 2005 13:33:07 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1216 Modified Files: NEWS Log Message: Fixed handling of SPECIAL-declared optional variables in inline LAMBDA. Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.231 retrieving revision 1.232 diff -u -d -r1.231 -r1.232 --- NEWS 26 Jan 2005 13:25:29 -0000 1.231 +++ NEWS 26 Jan 2005 13:33:05 -0000 1.232 @@ -308,6 +308,10 @@ + When an interpreted INITIALIZE-INSTANCE method uses CALL-NEXT-METHOD with a modified argument list, MAKE-INSTANCE could in some cases initialize the new object three times instead of just once. + + Fixed a compiler bug that could lead to incorrect code when a LAMBDA + with SPECIAL-declared optional variables was compiled inline and the + initforms of the optional variables depended on the values of the previous + optional variables. + Passing a package as second argument of RENAME-PACKAGE led to an unjustified error. + Passing a displaced vector as argument to REVERSE could lead to an --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src makemake.in,1.507,1.508 ChangeLog,1.4155,1.4156 Date: Wed, 26 Jan 2005 13:35:22 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1678/src Modified Files: makemake.in ChangeLog Log Message: Perform the ansi-tests also with the compiler instead of the evaluator. Index: makemake.in =================================================================== RCS file: /cvsroot/clisp/clisp/src/makemake.in,v retrieving revision 1.507 retrieving revision 1.508 diff -u -d -r1.507 -r1.508 --- makemake.in 25 Jan 2005 09:29:43 -0000 1.507 +++ makemake.in 26 Jan 2005 13:35:18 -0000 1.508 @@ -3002,7 +3002,7 @@ if [ $CROSS = false ] ; then echol "# Perform self-tests." - echol "check : check-recompile check-fresh-line check-tests check-sacla-tests check-ansi-tests" + echol "check : check-recompile check-fresh-line check-tests check-sacla-tests check-ansi-tests check-ansi-tests-compiled" echodummyrule check echol @@ -3137,7 +3137,13 @@ echotab "cd ${ANSITESTSDIR} && ${ANSI_CLISP} -x '(in-package \"CL-TEST\") (time (regression-test:do-tests)) (ext:exit (regression-test:pending-tests))' 2>&1 | tee ../ansi-tests-log" echol echol "check-ansi-tests-debug : ${ANSITESTSDIR} lisp${LEXE} lispinit.mem" - echotab "cd ${ANSITESTSDIR} && ${ANSI_CLISP} -p CL-TEST -repl" + echotab "cd ${ANSITESTSDIR} && ${ANSI_CLISP} -x '(in-package \"CL-TEST\")' -repl" + echol + echol "check-ansi-tests-compiled : ${ANSITESTSDIR} lisp${LEXE} lispinit.mem" + echotab "cd ${ANSITESTSDIR} && ${ANSI_CLISP} -x '(in-package \"CL-TEST\") (setq regression-test::*compile-tests* t) (time (regression-test:do-tests)) (ext:exit (regression-test:pending-tests))' 2>&1 | tee ../ansi-tests-compiled-log" + echol + echol "check-ansi-tests-compiled-debug : ${ANSITESTSDIR} lisp${LEXE} lispinit.mem" + echotab "cd ${ANSITESTSDIR} && ${ANSI_CLISP} -x '(in-package \"CL-TEST\") (setq regression-test::*compile-tests* t)' -repl" echol echol "${ANSITESTSDIR} :" echotab "-mkdir ${ANSITESTSDIR}" Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4155 retrieving revision 1.4156 diff -u -d -r1.4155 -r1.4156 --- ChangeLog 26 Jan 2005 13:28:26 -0000 1.4155 +++ ChangeLog 26 Jan 2005 13:35:19 -0000 1.4156 @@ -1,5 +1,13 @@ 2005-01-22 Bruno Haible <br...@cl...> + * makemake.in (check-ansi-tests-debug): Make more similar to the + check-ansi-tests target. + (check-ansi-tests-compiled, check-ansi-tests-compiled-debug): New + targets. + (check): Depend on check-ansi-tests-compiled. + +2005-01-22 Bruno Haible <br...@cl...> + * compiler.lisp (c-FUNCALL-INLINE): Fix long-standing bug in the handling of SPECIAL-declared optional variables: If the initforms of these variables come from the lambdalist, use sequential calls to --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src init.lisp,1.215,1.216 ChangeLog,1.4156,1.4157 NEWS,1.232,1.233 Date: Wed, 26 Jan 2005 13:38:22 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2428/src Modified Files: init.lisp ChangeLog NEWS Log Message: Fix the behaviour of IN-PACKAGE at compile time. Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.232 retrieving revision 1.233 diff -u -d -r1.232 -r1.233 --- NEWS 26 Jan 2005 13:33:05 -0000 1.232 +++ NEWS 26 Jan 2005 13:38:20 -0000 1.233 @@ -208,6 +208,8 @@ CUSTOM:*PRINT-UNREADABLE-ANSI* is true. + In the #n= and #n# reader syntax, the integer n may now be larger than 7 digits. + + IN-PACKAGE forms with constant arguments are no longer executed by the + compiler if they occur in a non-null lexical environment. Thanks to Paul F. Dietz <di...@dl...> and his ANSI compliance suite, which helped detect some of these deficiencies. Thanks to Yuji Minejima <ggb...@ni...> and his ANSI compliance Index: init.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/init.lisp,v retrieving revision 1.215 retrieving revision 1.216 diff -u -d -r1.215 -r1.216 --- init.lisp 24 Jan 2005 10:43:58 -0000 1.215 +++ init.lisp 26 Jan 2005 13:38:16 -0000 1.216 @@ -253,7 +253,7 @@ (function in-package (lambda (form env) (declare (ignore env)) (let ((package-name (string (cadr form)))) - (list 'EVAL-WHEN '(COMPILE LOAD EVAL) + (list 'EVAL-WHEN '(:COMPILE-TOPLEVEL LOAD EVAL) (list 'SETQ 'COMMON-LISP::*PACKAGE* (list 'SYS::%FIND-PACKAGE package-name)))))))) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4156 retrieving revision 1.4157 diff -u -d -r1.4156 -r1.4157 --- ChangeLog 26 Jan 2005 13:35:19 -0000 1.4156 +++ ChangeLog 26 Jan 2005 13:38:17 -0000 1.4157 @@ -1,5 +1,11 @@ 2005-01-22 Bruno Haible <br...@cl...> + * init.lisp (in-package): Execute at compile-time only if it occurs + as a top-level form. + Found by Paul Dietz's ansi-tests test suite. + +2005-01-22 Bruno Haible <br...@cl...> + * makemake.in (check-ansi-tests-debug): Make more similar to the check-ansi-tests target. (check-ansi-tests-compiled, check-ansi-tests-compiled-debug): New --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src macros2.lisp,1.31,1.32 condition.lisp,1.76,1.77 foreign1.lisp,1.79,1.80 Date: Wed, 26 Jan 2005 13:39:10 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2669/src Modified Files: macros2.lisp condition.lisp foreign1.lisp Log Message: Indentation and style. Index: foreign1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/foreign1.lisp,v retrieving revision 1.79 retrieving revision 1.80 diff -u -d -r1.79 -r1.80 --- foreign1.lisp 25 Jan 2005 14:35:09 -0000 1.79 +++ foreign1.lisp 26 Jan 2005 13:39:07 -0000 1.80 @@ -850,7 +850,8 @@ (defmacro with-c-place ((var fvar) &body body) (let ((fv (gensym (symbol-name var)))) `(LET ((,fv ,fvar)) - (SYMBOL-MACROLET ((,var (FOREIGN-VALUE ,fv))) ,@body)))) + (SYMBOL-MACROLET ((,var (FOREIGN-VALUE ,fv))) + ,@body)))) ;; ============================ Stack allocation ============================ @@ -869,18 +870,20 @@ (defmacro with-foreign-object ((var c-type &optional (init nil init-p)) &body body) `(EXEC-ON-STACK - (LAMBDA (,var) ,@body) - (PARSE-C-TYPE ,c-type) - . ,(if init-p (list init)))) + #'(LAMBDA (,var) ,@body) + (PARSE-C-TYPE ,c-type) + ,@(if init-p `(,init)))) ;; symbol-macro based interface (like DEF-C-VAR) ;; WITH-C-VAR appears as a composition of WITH-FOREIGN-OBJECT and WITH-C-PLACE (defmacro with-c-var ((var c-type &optional (init nil init-p)) &body body) (let ((fv (gensym (symbol-name var)))) `(EXEC-ON-STACK - (LAMBDA (,fv) (SYMBOL-MACROLET ((,var (FOREIGN-VALUE ,fv))) ,@body)) - (PARSE-C-TYPE ,c-type) - . ,(if init-p (list init))))) + #'(LAMBDA (,fv) + (SYMBOL-MACROLET ((,var (FOREIGN-VALUE ,fv))) + ,@body)) + (PARSE-C-TYPE ,c-type) + ,@(if init-p `(,init))))) (defun exec-with-foreign-string (thunk string ; ABI &key (encoding #+UNICODE custom:*foreign-encoding* @@ -899,7 +902,7 @@ (declare (ignore encoding null-terminated-p start end)) ; get them via keywords `(EXEC-WITH-FOREIGN-STRING #'(LAMBDA (,foreign-variable ,char-count ,byte-count) ,@body) - ,string .,keywords)) + ,string ,@keywords)) ;; ============================ heap allocation ============================ Index: condition.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/condition.lisp,v retrieving revision 1.76 retrieving revision 1.77 diff -u -d -r1.76 -r1.77 --- condition.lisp 24 Jan 2005 10:15:34 -0000 1.76 +++ condition.lisp 26 Jan 2005 13:39:07 -0000 1.77 @@ -1065,8 +1065,8 @@ restart-clauses &body body &environment env) (expand-restart-case 'with-restarts whole-form restart-clauses (if (cdr body) - (cons 'PROGN body) - (macroexpand (car body) env)))) + (cons 'PROGN body) + (macroexpand (car body) env)))) ;; WITH-SIMPLE-RESTART, CLtL2 p. 902 (defmacro with-simple-restart ((name format-string &rest format-arguments) &body body) Index: macros2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/macros2.lisp,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- macros2.lisp 7 Jan 2005 13:30:39 -0000 1.31 +++ macros2.lisp 26 Jan 2005 13:39:07 -0000 1.32 @@ -306,7 +306,7 @@ (UNWIND-PROTECT (PROGN ,@body-rest) ,@(if sindex - `((SETF ,index (SYSTEM::STRING-INPUT-STREAM-INDEX ,var))) '()) + `((SETF ,index (SYSTEM::STRING-INPUT-STREAM-INDEX ,var))) '()) (CLOSE ,var))))) ;; ---------------------------------------------------------------------------- (defmacro with-open-file ((stream &rest options) &body body) --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc impbody.xml,1.355,1.356 Date: Wed, 26 Jan 2005 15:06:28 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24246 Modified Files: impbody.xml Log Message: Document that ((setf foo) ...) is allowed. Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.355 retrieving revision 1.356 diff -u -d -r1.355 -r1.356 --- impbody.xml 26 Jan 2005 13:11:26 -0000 1.355 +++ impbody.xml 26 Jan 2005 15:06:24 -0000 1.356 @@ -156,6 +156,20 @@ in the &glo-env;. The compiler &signal;s a &warning-t; when it encounters an undefined variable.</para> </section> + +<section id="function-form"><title>Conses as Forms + <ulink url="&clhs;/Body/sec_3-1-2-1-2.html">[CLHS-3.1.2.1.2]</ulink></title> +<para>Lists of the form <literal>((&setf; symbol) ...)</literal> are also + treated as function forms. This makes the syntax + <literal>(function-name arguments...)</literal> consistent with the syntax + <literal>(&funcall; #'function-name arguments...)</literal>. + It implements the item 7 of issue + <ulink url="&clhs;/Issues/iss174.html">FUNCTION-NAME:LARGE</ulink> and the + definition of + <ulink url="&clhs;/Body/glo_f.html#function_form">function form</ulink>s, + and is consistent with the use of function names elsewhere in Common Lisp. +</para> +</section> </section> <section id="compilation"><title>Compilation --__--__-- Message: 7 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impbody.xml,1.356,1.357 Date: Wed, 26 Jan 2005 18:29:44 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10264/doc Modified Files: impbody.xml Log Message: formatting Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.356 retrieving revision 1.357 diff -u -d -r1.356 -r1.357 --- impbody.xml 26 Jan 2005 15:06:24 -0000 1.356 +++ impbody.xml 26 Jan 2005 18:29:39 -0000 1.357 @@ -644,10 +644,10 @@ <varlistentry><term>&values-list;</term> <listitem><simpara><code>(&setf; (&values-list; &list-r;) &form-r;)</code> is equivalent to <code>(&values-list; (&setf; &list-r; - (&multiple-value-list; &form-r;)))</code>. Note that this &place; is - restricted: it can only be used in &setf;, &letf;, &letf-star;, not - in other positions. - </simpara></listitem></varlistentry> + (&multiple-value-list; &form-r;)))</code>.</simpara> + <note><simpara>Note that this &place; is restricted: it can only be + used in &setf;, &letf;, &letf-star;, not in other positions. + </simpara></note></listitem></varlistentry> </variablelist></para> <para>&key-amp; markers in &defsetf; &lalist;s are supported, but the --__--__-- Message: 8 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src stream.d,1.500,1.501 ChangeLog,1.4157,1.4158 Date: Wed, 26 Jan 2005 21:01:24 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16130/src Modified Files: stream.d ChangeLog Log Message: (same_handle_p): added debugging infrastructure Index: stream.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/stream.d,v retrieving revision 1.500 retrieving revision 1.501 diff -u -d -r1.500 -r1.501 --- stream.d 26 Jan 2005 01:21:28 -0000 1.500 +++ stream.d 26 Jan 2005 21:00:43 -0000 1.501 @@ -3567,13 +3567,19 @@ # > handle1: Handle of the first open device # > handle2: Handle of the second open device # < result: true if handle1 and handle2 are exchangeable +#define SAME_HANDLE_P_OUT(x) do { /*printf x; fflush(stdout);*/ } while(0) local bool same_handle_p (Handle handle1, Handle handle2) { #if defined(UNIX) var struct stat statbuf1; var struct stat statbuf2; begin_system_call(); + SAME_HANDLE_P_OUT(("\nsame_handle_p(%d,%d)\n",handle1,handle2)); if (!( fstat(handle1,&statbuf1) ==0)) { OS_error(); } if (!( fstat(handle2,&statbuf2) ==0)) { OS_error(); } + SAME_HANDLE_P_OUT(("dev: 0x%lx 0x%lx ino: 0x%lx 0x%lx mode: 0x%x 0x%x\n", + statbuf1.st_dev,statbuf2.st_dev, + statbuf1.st_ino,statbuf2.st_ino, + statbuf1.st_mode,statbuf2.st_mode)); if (statbuf1.st_dev == statbuf2.st_dev && statbuf1.st_ino == statbuf2.st_ino) { /* handle1 and handle2 point to the same inode. */ @@ -3582,8 +3588,10 @@ /* handle1 and handle2 are exchangeable only if they are positioned at the same file position. */ var off_t pos1 = lseek(handle1,0,SEEK_CUR); + SAME_HANDLE_P_OUT(("pos1: %ld\n",pos1)); if (pos1 >= 0) { var off_t pos2 = lseek(handle2,0,SEEK_CUR); + SAME_HANDLE_P_OUT(("pos2: %ld\n",pos2)); if (pos2 >= 0) { end_system_call(); return (pos1 == pos2); @@ -3599,6 +3607,7 @@ #endif #if defined(WIN32_NATIVE) /* Same handle? */ + SAME_HANDLE_P_OUT(("\nsame_handle_p(0x%lx,0x%lx)\n",handle1,handle2)); if (handle1 == handle2) return true; /* Same handle type? */ @@ -3607,6 +3616,7 @@ var DWORD filetype2; filetype1 = GetFileType(handle1); filetype2 = GetFileType(handle2); + SAME_HANDLE_P_OUT(("GetFileType: 0x%lx 0x%lx\n",filetype1,filetype2)); if (filetype1 == filetype2) { if (filetype1 == FILE_TYPE_DISK) { /* handle1 and handle2 are both files. */ @@ -3614,6 +3624,16 @@ var BY_HANDLE_FILE_INFORMATION fileinfo2; if (!GetFileInformationByHandle(handle1,&fileinfo1)) { OS_error(); } if (!GetFileInformationByHandle(handle2,&fileinfo2)) { OS_error(); } + SAME_HANDLE_P_OUT(("GetFileInformationByHandle:\n vol: 0x%lx 0x%lx\n" + " index: 0x%x,0x%x 0x%x,0x%x\n attr: 0x%lx 0x%lx\n" + " size: 0x%x,0x%x 0x%x,0x%x\n", + fileinfo1.dwVolumeSerialNumber, + fileinfo2.dwVolumeSerialNumber, + fileinfo1.nFileIndexHigh,fileinfo1.nFileIndexLow, + fileinfo2.nFileIndexHigh,fileinfo2.nFileIndexLow, + fileinfo1.dwFileAttributes,fileinfo2.dwFileAttributes, + fileinfo1.nFileSizeHigh,fileinfo1.nFileSizeLow, + fileinfo2.nFileSizeHigh,fileinfo2.nFileSizeLow)); end_system_call(); #define TIME_EQ(ft1,ft2) \ ((ft1).dwLowDateTime == (ft2).dwLowDateTime \ @@ -3634,18 +3654,24 @@ } else if (filetype1 == FILE_TYPE_CHAR) { /* Same console? */ var DWORD console_mode; - if (GetConsoleMode(handle1,&console_mode) - && GetConsoleMode(handle2,&console_mode)) { - end_system_call(); - return true; + SAME_HANDLE_P_OUT(("FILE_TYPE_CHAR\n")); + if (GetConsoleMode(handle1,&console_mode)) { + SAME_HANDLE_P_OUT(("console_mode1: 0x%lx\n",console_mode)); + if (GetConsoleMode(handle2,&console_mode)) { + SAME_HANDLE_P_OUT(("console_mode2: 0x%lx\n",console_mode)); + end_system_call(); + return true; + } } - } + } else + SAME_HANDLE_P_OUT(("neither FILE_TYPE_CHAR nor FILE_TYPE_DISK\n")); /* Cannot determine equality. Assume they are different. */ } end_system_call(); return false; #endif } +#undef SAME_HANDLE_P_OUT # Channel-Streams Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4157 retrieving revision 1.4158 diff -u -d -r1.4157 -r1.4158 --- ChangeLog 26 Jan 2005 13:38:17 -0000 1.4157 +++ ChangeLog 26 Jan 2005 21:01:16 -0000 1.4158 @@ -1,3 +1,7 @@ +2005-01-26 Sam Steingold <sd...@gn...> + + * stream.d (same_handle_p): added debugging infrastructure + 2005-01-22 Bruno Haible <br...@cl...> * init.lisp (in-package): Execute at compile-time only if it occurs --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |
