cmucl-cvs February 2013

cmucl-cvs@common-lisp.net

1 participants
25 discussions

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-23-ge8f64b3
by Raymond Toy 27 Feb '13

27 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via e8f64b3f83455a82edad394c472481fadde6ccb5 (commit) from fc60a7b508bb1e3fdc6d453f5b92a7f276331d2e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit e8f64b3f83455a82edad394c472481fadde6ccb5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Feb 26 20:44:18 2013 -0800 Fix ticket:74 When accounting for the octets left in the in-buffer that we haven't read (or converted to characters), we were subtracting the index from the total in-buffer length. This is wrong if the file is less than the total in-buffer length. We should have subtracted from the actual number of octets in the in-buffer. diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index e41b331..7fcd0bc 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1756,8 +1756,9 @@ #+nil (progn (format t "in-buffer-length = ~D~%" in-buffer-length) + (format t "in-length = ~D~%" (fd-stream-in-length stream)) (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream))) - (decf posn (- in-buffer-length + (decf posn (- (fd-stream-in-length stream) (fd-stream-in-index stream)))) #+nil (format t "fd-stream-unread = ~S~%" (fd-stream-unread stream)) ----------------------------------------------------------------------- Summary of changes: src/code/fd-stream.lisp | 3 ++- 1 files changed, 2 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-22-gfc60a7b
by Raymond Toy 24 Feb '13

24 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via fc60a7b508bb1e3fdc6d453f5b92a7f276331d2e (commit) from 10859380420e467d96a57a95f267c46320a6f57c (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit fc60a7b508bb1e3fdc6d453f5b92a7f276331d2e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 20:44:45 2013 -0800 Update from commit logs. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 41e0db9..f85b51d 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -41,11 +41,13 @@ New in this release: derivation.) * :I486 and :PENTIUM (Always assume we're running on at least a Pentium.) + * Attempts to modify the standard readtable or the standard pprint + dispatch table will now signal a continuable error. * ANSI compliance fixes: * Bugfixes: - * REPLACE and friends on strings was limited to strings less than + * REPLACE and friends on strings were limited to strings less than the maximum possible size. This has been fixed so strings of any supported length can be handled. (See ticket #66 and #68.) @@ -59,6 +61,7 @@ New in this release: * Ticket #65 fixed. * Ticket #71 fixed. * Ticket #72 fixed. + * Ticket #73 fixed. * Other changes: * -8 option for build-all.sh is deprecated since we don't ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20e.txt | 5 ++++- 1 files changed, 4 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-21-g1085938
by Raymond Toy 24 Feb '13

24 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 10859380420e467d96a57a95f267c46320a6f57c (commit) from 00844093cfc536936a1797bfbfa910ab1e4db7fe (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 10859380420e467d96a57a95f267c46320a6f57c Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 20:44:23 2013 -0800 Signal an error if the readtable case of the standard readtable is changed. * Rename the slot to %READTABLE-CASE (from READTABLE-CASE). * Add READTABLE-CASE and (SETF READTABLE-CASE) functions, as required. * Check for the standard readtable in (SETF READTABLE-CASE). diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 3b4d06b..4eabc4e 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -144,7 +144,7 @@ ;; vectors of CHAR-CODE-LIMIT functions, for use in defining dispatching ;; macros (like #-macro). (dispatch-tables () :type list) - (readtable-case :upcase :type (member :upcase :downcase :preserve :invert)) + (%readtable-case :upcase :type (member :upcase :downcase :preserve :invert)) ;; ;; The CHARACTER-ATTRIBUTE-HASH-TABLE handles the case of char codes ;; above ATTRIBUTE-TABLE-LIMIT, since we expect these to be @@ -466,6 +466,13 @@ (cerror "Modify it anyway." 'kernel:standard-readtable-modified-error :operation operation))) +(defun readtable-case (table) + (%readtable-case table)) + +(defun (setf readtable-case) (new-case table) + (assert-not-standard-readtable table '(setf readtable-case)) + (setf (%readtable-case table) new-case)) + (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) "A copy is made of from-readtable and place into to-readtable." (assert-not-standard-readtable to-readtable 'copy-readtable) ----------------------------------------------------------------------- Summary of changes: src/code/reader.lisp | 9 ++++++++- 1 files changed, 8 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-20-g0084409
by Raymond Toy 24 Feb '13

24 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 00844093cfc536936a1797bfbfa910ab1e4db7fe (commit) from f5250810f8507020e2479dd1ecb600a6fe710f78 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 00844093cfc536936a1797bfbfa910ab1e4db7fe Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 18:14:18 2013 -0800 Fix ticket:73 error.lisp:: * Create two new conditions, one for modifying the readtable and one for the pprint dispatch table. exports.lisp:: * Export the two new conditions. pprint.lisp:: * Add check to SET-PPRINT-DISPATCH to disallow modifying the standard pprint dispatch table. * Allow PPRINT-INIT to modify the standard pprint dispatch table. print.lisp:: * In WITH-STANDARD-IO-SYNTAX, don't copy a new dispatch table; bind *print-pprint-dispatch* to the standard table. reader.lisp:: * Add check to disallow modifying the standard readtable. * Allow INIT-STD-LISP-READTABLE to modify the standard readtable. diff --git a/src/code/error.lisp b/src/code/error.lisp index 2678d22..5b72100 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -1203,6 +1203,27 @@ `(handler-case (progn ,@forms) (error (condition) (values nil condition)))) + +;;;; Reader + +(define-condition standard-readtable-modified-error (reference-condition error) + ((operation :initarg :operation + :reader standard-readtable-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard readtable." + (standard-readtable-modified-operation condition)))) + (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) + (:ansi-cl :glossary "standard readtable")))) + +;;;; Pprint dispatch + +(define-condition standard-pprint-dispatch-table-modified-error (reference-condition error) + ((operation :initarg :operation + :reader standard-pprint-dispatch-table-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard pprint dispatch table." + (standard-pprint-dispatch-table-modified-operation condition)))) + (:default-initargs :references `((:ansi-cl :glossary "standard pprint dispatch table")))) ;;;; Restart definitions. @@ -1249,3 +1270,4 @@ (define-nil-returning-restart use-value (value) "Transfer control and value to a restart named use-value, returning nil if none exists.") + diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 3e9631b..2c3e0ff 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2321,7 +2321,9 @@ "%COMPLEX-SINGLE-FLOAT" "%COMPLEX-DOUBLE-FLOAT" - "%COMPLEX-DOUBLE-DOUBLE-FLOAT") + "%COMPLEX-DOUBLE-DOUBLE-FLOAT" + "STANDARD-READTABLE-MODIFIED-ERROR" + "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index d1f570f..15eafc0 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -1223,11 +1223,17 @@ When annotations are present, invoke them at the right positions." (output-ugly-object object stream)) nil)))) +(defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation) + (when (eq pprint-dispatch *initial-pprint-dispatch*) + (cerror "Modify it anyway." 'standard-pprint-dispatch-table-modified-error + :operation operation))) + (defun set-pprint-dispatch (type function &optional (priority 0) (table *print-pprint-dispatch*)) (declare (type (or null symbol function) function) (type real priority) (type pprint-dispatch-table table)) + (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch) (if function (if (cons-type-specifier-p type) (setf (gethash (second (second type)) @@ -1952,18 +1958,25 @@ When annotations are present, invoke them at the right positions." (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) (let ((*print-pprint-dispatch* *initial-pprint-dispatch*) (*building-initial-table* t)) - ;; Printers for regular types. - (set-pprint-dispatch 'array #'pprint-array) - (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) - #'pprint-function-call -1) - (set-pprint-dispatch 'cons #'pprint-fill -2) - ;; Cons cells with interesting things for the car. - (dolist (magic-form *magic-forms*) - (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) - ;; Other pretty-print init forms. - (lisp::backq-pp-init) - (loop-pp-init)) + (handler-bind + ((standard-pprint-dispatch-table-modified-error + (lambda (c) + (declare (ignore c)) + ;; Of course, we want to be able to modify the standard + ;; pprint dispatch table here! + (invoke-restart 'kernel::continue)))) + ;; Printers for regular types. + (set-pprint-dispatch 'array #'pprint-array) + (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) + #'pprint-function-call -1) + (set-pprint-dispatch 'cons #'pprint-fill -2) + ;; Cons cells with interesting things for the car. + (dolist (magic-form *magic-forms*) + (set-pprint-dispatch `(cons (eql ,(first magic-form))) + (symbol-function (second magic-form)))) + ;; Other pretty-print init forms. + (lisp::backq-pp-init) + (loop-pp-init))) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) (setf *pretty-printer* #'output-pretty-object) diff --git a/src/code/print.lisp b/src/code/print.lisp index 3f162d7..aae2e0b 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -115,7 +115,7 @@ (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) - (*print-pprint-dispatch* (copy-pprint-dispatch nil)) + (*print-pprint-dispatch* pp::*initial-pprint-dispatch*) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index de666d1..3b4d06b 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -461,8 +461,14 @@ ;;;; Readtable operations. +(defun assert-not-standard-readtable (readtable operation) + (when (eq readtable std-lisp-readtable) + (cerror "Modify it anyway." 'kernel:standard-readtable-modified-error + :operation operation))) + (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) "A copy is made of from-readtable and place into to-readtable." + (assert-not-standard-readtable to-readtable 'copy-readtable) (let ((from-readtable (or from-readtable std-lisp-readtable)) (to-readtable (or to-readtable (make-readtable)))) (flet ((copy-hash-table (to from) @@ -495,6 +501,7 @@ "Causes the syntax of to-char to be the same as from-char in the optional readtable (defaults to the current readtable). The from-table defaults the standard lisp readtable by being nil." + (assert-not-standard-readtable to-readtable 'set-syntax-from-char) (let ((from-readtable (or from-readtable std-lisp-readtable))) ;;copy from-char entries to to-char entries, but make sure that if ;;from char is a constituent you don't copy non-movable secondary @@ -538,10 +545,12 @@ make the macro character non-terminating. The optional readtable argument defaults to the current readtable. Set-macro-character returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char #.terminating-macro rt)) - (set-cmt-entry char function rt) + (let ((designated-readtable (or rt std-lisp-readtable))) + (assert-not-standard-readtable designated-readtable 'set-macro-character) + (if non-terminatingp + (set-cat-entry char (get-secondary-attribute char) designated-readtable) + (set-cat-entry char #.terminating-macro designated-readtable)) + (set-cmt-entry char function designated-readtable)) T) (defun get-macro-character (char &optional (rt *readtable*)) @@ -595,46 +604,54 @@ (setq std-lisp-readtable (make-readtable)) ;;all characters default to "constituent" in make-readtable ;;*** un-constituent-ize some of these *** - (let ((*readtable* std-lisp-readtable)) - (set-cat-entry #\tab #.whitespace) - (set-cat-entry #\linefeed #.whitespace) - (set-cat-entry #\space #.whitespace) - (set-cat-entry #\page #.whitespace) - (set-cat-entry #\return #.whitespace) - (set-cat-entry #\\ #.escape) - (set-cat-entry #\| #.multiple-escape) - (set-cmt-entry #\\ #'read-token) - (set-cmt-entry #\: #'read-token) - (set-cmt-entry #\| #'read-token) - ;;macro definitions - (set-macro-character #\" #'read-string) - ;;* # macro - (set-macro-character #\' #'read-quote) - (set-macro-character #\( #'read-list) - (set-macro-character #\) #'read-right-paren) - (set-macro-character #\; #'read-comment) - ;;* backquote - ;;all constituents - (do ((ichar 0 (1+ ichar)) - (len #+unicode-bootstrap #o200 - #-unicode-bootstrap char-code-limit)) - ((= ichar len)) - (let ((char (code-char ichar))) - #-unicode - (when (constituentp char std-lisp-readtable) - (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char #'read-token)) - #+unicode - (cond ((constituentp char std-lisp-readtable) - (set-cat-entry char (get-secondary-attribute char)) - (when (< ichar attribute-table-limit) - ;; The hashtable default in get-cmt-entry returns - ;; #'read-token, so don't need to set it here. - (set-cmt-entry char #'read-token))) - ((>= ichar attribute-table-limit) - ;; A non-constituent character that would be stored in - ;; the hash table gets #'undefined-macro-char. - (set-cmt-entry char #'undefined-macro-char))))))) + (handler-bind + ((standard-readtable-modified-error + (lambda (c) + (declare (ignore c)) + ;; Of course, we want to be able to modify the standard + ;; readtable here! + (invoke-restart 'kernel::continue)))) + (let ((*readtable* std-lisp-readtable) + (*assert-not-standard-readtable* nil)) + (set-cat-entry #\tab #.whitespace) + (set-cat-entry #\linefeed #.whitespace) + (set-cat-entry #\space #.whitespace) + (set-cat-entry #\page #.whitespace) + (set-cat-entry #\return #.whitespace) + (set-cat-entry #\\ #.escape) + (set-cat-entry #\| #.multiple-escape) + (set-cmt-entry #\\ #'read-token) + (set-cmt-entry #\: #'read-token) + (set-cmt-entry #\| #'read-token) + ;;macro definitions + (set-macro-character #\" #'read-string) + ;;* # macro + (set-macro-character #\' #'read-quote) + (set-macro-character #\( #'read-list) + (set-macro-character #\) #'read-right-paren) + (set-macro-character #\; #'read-comment) + ;;* backquote + ;;all constituents + (do ((ichar 0 (1+ ichar)) + (len #+unicode-bootstrap #o200 + #-unicode-bootstrap char-code-limit)) + ((= ichar len)) + (let ((char (code-char ichar))) + #-unicode + (when (constituentp char std-lisp-readtable) + (set-cat-entry char (get-secondary-attribute char)) + (set-cmt-entry char #'read-token)) + #+unicode + (cond ((constituentp char std-lisp-readtable) + (set-cat-entry char (get-secondary-attribute char)) + (when (< ichar attribute-table-limit) + ;; The hashtable default in get-cmt-entry returns + ;; #'read-token, so don't need to set it here. + (set-cmt-entry char #'read-token))) + ((>= ichar attribute-table-limit) + ;; A non-constituent character that would be stored in + ;; the hash table gets #'undefined-macro-char. + (set-cmt-entry char #'undefined-macro-char)))))))) ----------------------------------------------------------------------- Summary of changes: src/code/error.lisp | 22 ++++++++++ src/code/exports.lisp | 4 +- src/code/pprint.lisp | 37 ++++++++++++------ src/code/print.lisp | 2 +- src/code/reader.lisp | 105 ++++++++++++++++++++++++++++-------------------- 5 files changed, 112 insertions(+), 58 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-19-gf525081
by Raymond Toy 23 Feb '13

23 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via f5250810f8507020e2479dd1ecb600a6fe710f78 (commit) via 748f06c2b35fda55e5831d7df0e6a7f6a48f5086 (commit) from aabd62968d3137fb65237524ebfca3d6f27e90b0 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f5250810f8507020e2479dd1ecb600a6fe710f78 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 08:42:13 2013 -0800 Update asdf version. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 02953da..41e0db9 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -23,7 +23,7 @@ New in this release: * Feature enhancements * Changes - * ASDF2 updated to version 2.29. + * ASDF2 updated to version 2.30. * DEFINE-COMPILER-MACRO now has source-location information for the macro definition. * :ALIEN-CALLBACK added to *FEATURES* for platforms that support commit 748f06c2b35fda55e5831d7df0e6a7f6a48f5086 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 08:41:33 2013 -0800 Update to asdf 2.30. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index c229b07..bdd55ad 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.29: Another System Definition Facility. +;;; This is ASDF 2.30: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -54,7 +54,7 @@ (declaim (optimize (speed 1) (safety 3) (debug 3))) (setf ext:*gc-verbose* nil)) -#+(or abcl clisp cmu ecl xcl) +#+(or abcl clisp clozure cmu ecl xcl) (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :asdf3 *features*) (let* ((existing-version @@ -71,7 +71,8 @@ (existing-version-number (and existing-version (read-from-string existing-major-minor))) (away (format nil "~A-~A" :asdf existing-version))) (when (and existing-version (< existing-version-number - #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 #+ecl 2.21 #+xcl 2.27)) + #+abcl 2.25 #+clisp 2.27 #+clozure 2.27 + #+cmu 2.018 #+ecl 2.21 #+xcl 2.27)) (rename-package :asdf away) (when *load-verbose* (format t "; Renamed old ~A package away to ~A~%" :asdf away)))))) @@ -991,7 +992,6 @@ or when loading the package is optional." #:call-function #:call-functions #:register-hook-function #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions - #:load-string #:load-stream #:lexicographic< #:lexicographic<= #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version (in-package :asdf/utility) @@ -1362,9 +1362,6 @@ with later being determined by a lexicographical comparison of minor numbers." ;;; Condition control (with-upgradability () - (defvar *uninteresting-conditions* nil - "Uninteresting conditions, as per MATCH-CONDITION-P") - (defparameter +simple-condition-format-control-slot+ #+abcl 'system::format-control #+allegro 'excl::format-control @@ -1401,8 +1398,8 @@ or a string describing the format-control of a simple-condition." (muffle-warning c))))) (funcall thunk))) - (defmacro with-muffled-uninteresting-conditions ((conditions) &body body) - `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))) + (defmacro with-muffled-conditions ((conditions) &body body) + `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) ;;;; --------------------------------------------------------------------------- @@ -1596,7 +1593,7 @@ then returning the non-empty string value of the variable" (with-upgradability () (defun hostname () ;; Note: untested on RMCL - #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -1657,75 +1654,74 @@ then returning the non-empty string value of the variable" ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 -(with-upgradability () - #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. - (progn - (defparameter *link-initial-dword* 76) - (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) - - (defun read-null-terminated-string (s) - (with-output-to-string (out) - (loop :for code = (read-byte s) - :until (zerop code) - :do (write-char (code-char code) out)))) - - (defun read-little-endian (s &optional (bytes 4)) - (loop :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) - - (defun parse-file-location-info (s) - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (strcat (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) - - (defun parse-windows-shortcut (pathname) - (with-open-file (s pathname :element-type '(unsigned-byte 8)) - (handler-case - (when (and (= (read-little-endian s) *link-initial-dword*) - (let ((header (make-array (length *link-guid*)))) - (read-sequence header s) - (equalp header *link-guid*))) - (let ((flags (read-little-endian s))) - (file-position s 76) ;skip rest of header - (when (logbitp 0 flags) - ;; skip shell item id list - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (cond - ((logbitp 1 flags) - (parse-file-location-info s)) - (t - (when (logbitp 2 flags) - ;; skip description string - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (when (logbitp 3 flags) - ;; finally, our pathname - (let* ((length (read-little-endian s 2)) - (buffer (make-array length))) - (read-sequence buffer s) - (map 'string #'code-char buffer))))))) - (end-of-file (c) - (declare (ignore c)) - nil)))))) +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(with-upgradability () + (defparameter *link-initial-dword* 76) + (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) + + (defun read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + + (defun read-little-endian (s &optional (bytes 4)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + + (defun parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + + (defun parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file (c) + (declare (ignore c)) + nil))))) ;;;; ------------------------------------------------------------------------- @@ -2484,47 +2480,48 @@ or the original (parsed) pathname if it is false (the default)." (null nil) (string (probe-file* (parse-namestring p) :truename truename)) (pathname - (handler-case - (or - #+allegro - (probe-file p :follow-symlinks truename) - #-(or allegro clisp gcl2.6) - (if truename - (probe-file p) - (and (not (wild-pathname-p p)) + (and (not (wild-pathname-p p)) + (handler-case + (or + #+allegro + (probe-file p :follow-symlinks truename) + #-(or allegro clisp gcl2.6) + (if truename + (probe-file p) (ignore-errors (let ((pp (translate-logical-pathname p))) - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) - #+(and lispworks unix) (system:get-file-stat pp) - #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp))) - p)) - #+(or clisp gcl2.6) - #.(flet ((probe (probe) - `(let ((foundtrue ,probe)) - (cond - (truename foundtrue) - (foundtrue p))))) - #+gcl2.6 - (probe '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename* (subpathname - (ensure-directory-pathname p) "."))))))) - #+clisp - (let* ((fs (find-symbol* '#:file-stat :posix nil)) - (pp (find-symbol* '#:probe-pathname :ext nil)) - (resolve (if pp - `(ignore-errors (,pp p)) - '(or (truename* p) - (truename* (ignore-errors (ensure-directory-pathname p))))))) - (if fs - `(if truename - ,resolve - (and (ignore-errors (,fs p)) p)) - (probe resolve))))) - (file-error () nil)))))) + (and + #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) + #+(and lispworks unix) (system:get-file-stat pp) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) + #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) + p)))) + #+(or clisp gcl2.6) + #.(flet ((probe (probe) + `(let ((foundtrue ,probe)) + (cond + (truename foundtrue) + (foundtrue p))))) + #+gcl2.6 + (probe '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname + (ensure-directory-pathname p) "."))))))) + #+clisp + (let* ((fs (find-symbol* '#:file-stat :posix nil)) + (pp (find-symbol* '#:probe-pathname :ext nil)) + (resolve (if pp + `(ignore-errors (,pp p)) + '(or (truename* p) + (truename* (ignore-errors (ensure-directory-pathname p))))))) + (if fs + `(if truename + ,resolve + (and (ignore-errors (,fs p)) p)) + (probe resolve))))) + (file-error () nil))))))) (defun directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec @@ -2858,7 +2855,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (with-upgradability () (defun ensure-all-directories-exist (pathnames) (dolist (pathname pathnames) - (ensure-directories-exist (translate-logical-pathname pathname)))) + (when pathname + (ensure-directories-exist (translate-logical-pathname pathname))))) (defun rename-file-overwriting-target (source target) #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic @@ -2887,7 +2885,6 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #:with-input-file #:call-with-input-file #:finish-outputs #:format! #:safe-format! #:copy-stream-to-stream #:concatenate-files - #:copy-stream-to-stream-line-by-line #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line #:slurp-stream-forms #:slurp-stream-form #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form @@ -3335,7 +3332,7 @@ For the latter case, we ought pick random suffix and atomically open it." #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:*lisp-interaction* - #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition + #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition #:call-with-fatal-condition-handler #:with-fatal-condition-handler #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* #:*image-postlude* #:*image-dump-hook* @@ -3343,7 +3340,7 @@ For the latter case, we ought pick random suffix and atomically open it." #:shell-boolean-exit #:register-image-restore-hook #:register-image-dump-hook #:call-image-restore-hook #:call-image-dump-hook - #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image + #:restore-image #:dump-image #:create-image )) (in-package :asdf/image) @@ -3436,7 +3433,7 @@ This is designed to abstract away the implementation specific quit forms." (let ((*debug-io* stream)) (ccl:print-call-history :count count :start-frame-number 1) (finish-output stream)) - #+(or cmucl scl) + #+(or cmu scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace most-positive-fixnum stream)) @@ -4234,12 +4231,15 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (etypecase sexp (symbol (reify-symbol sexp)) ((or number character simple-string pathname) sexp) - (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))))) + (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) + (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) + (defun unreify-simple-sexp (sexp) (etypecase sexp ((or symbol number character simple-string pathname) sexp) (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) - ((simple-vector 2) (unreify-symbol sexp)))) + ((simple-vector 2) (unreify-symbol sexp)) + ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) #+clozure (progn @@ -4256,16 +4256,14 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos :source (unreify-source-note source))))) (defun reify-function-name (function-name) - (reify-simple-sexp - (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%)) - `(setf ,setfed) - function-name))) + (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%)) + `(setf ,setfed) + function-name)) (defun unreify-function-name (function-name) - (let ((name (unreify-simple-sexp function-name))) - (if (and (consp name) (eq (first name) 'setf)) - (let ((setfed (second name))) - (gethash setfed ccl::%setf-function-names%)) - name))) + (if (and (consp function-name) (eq (first function-name) 'setf)) + (let ((setfed (second function-name))) + (gethash setfed ccl::%setf-function-names%)) + function-name)) (defun reify-deferred-warning (deferred-warning) (with-accessors ((warning-type ccl::compiler-warning-warning-type) (args ccl::compiler-warning-args) @@ -4274,7 +4272,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (list :warning-type warning-type :function-name (reify-function-name function-name) :source-note (reify-source-note source-note) :args (destructuring-bind (fun . formals) args - (cons (reify-function-name fun) (reify-simple-sexp formals)))))) + (cons (reify-function-name fun) formals))))) (defun unreify-deferred-warning (reified-deferred-warning) (destructuring-bind (&key warning-type function-name source-note args) reified-deferred-warning @@ -4284,7 +4282,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when :source-note (unreify-source-note source-note) :warning-type warning-type :args (destructuring-bind (fun . formals) args - (cons (unreify-function-name fun) (unreify-simple-sexp formals))))))) + (cons (unreify-function-name fun) formals)))))) #+(or cmu scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit @@ -4330,9 +4328,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+allegro - (reify-simple-sexp - (list :functions-defined excl::.functions-defined. - :functions-called excl::.functions-called.)) + (list :functions-defined excl::.functions-defined. + :functions-called excl::.functions-called.) #+clozure (mapcar 'reify-deferred-warning (if-let (dw ccl::*outstanding-deferred-warnings*) @@ -4374,7 +4371,7 @@ One of three functions required for deferred-warnings support in ASDF." (declare (ignorable reified-deferred-warnings)) #+allegro (destructuring-bind (&key functions-defined functions-called) - (unreify-simple-sexp reified-deferred-warnings) + reified-deferred-warnings (setf excl::.functions-defined. (append functions-defined excl::.functions-defined.) excl::.functions-called. @@ -5118,7 +5115,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "2.29") + (asdf-version "2.30") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -5679,7 +5676,7 @@ in which the system specification (.asd file) is located." #:*central-registry* #:probe-asd #:sysdef-central-registry-search #:find-system-if-being-defined #:*systems-being-defined* #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed - #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems* + #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:clear-defined-systems #:*defined-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) @@ -5762,6 +5759,7 @@ of which is a system object.") (setf *defined-systems* (make-hash-table :test 'equal)) (when asdf (setf (component-version asdf) *asdf-version*) + (setf (builtin-system-p asdf) t) (register-system asdf))) (values)) @@ -5801,7 +5799,7 @@ called with an object of type asdf:system." (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) '(sysdef-central-registry-search sysdef-source-registry-search - sysdef-find-preloaded-systems))))) + sysdef-preloaded-system-search))))) (cleanup-system-definition-search-functions) (defun search-for-system-definition (system) @@ -5917,11 +5915,17 @@ Going forward, we recommend new users should be using the source-registry. (defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () ,@body))) - (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname)))) + (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. (with-system-definitions () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) + ;; Note that our backward-compatible *readtable* is + ;; a global readtable that gets globally side-effected. Ouch. + ;; Same for the *print-pprint-dispatch* table. + ;; We should do something about that for ASDF3 if possible, or else ASDF4. + (*readtable* readtable) + (*print-pprint-dispatch* print-pprint-dispatch) (*print-readably* nil) (*default-pathname-defaults* ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. @@ -6002,7 +6006,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (defvar *preloaded-systems* (make-hash-table :test 'equal)) - (defun sysdef-find-preloaded-systems (requested) + (defun sysdef-preloaded-system-search (requested) (let ((name (coerce-name requested))) (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) (when foundp @@ -6783,7 +6787,7 @@ in some previous image, or T if it needs to be done.") #:circular-dependency #:circular-dependency-actions #:node-for #:needed-in-image-p #:action-index #:action-planned-p #:action-valid-p - #:plan-record-dependency #:visiting-action-p + #:plan-record-dependency #:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies #:visit-dependencies #:compute-action-stamp #:traverse-action @@ -7218,12 +7222,11 @@ processed in order by OPERATE.")) :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export #:operate #:oos - #:*systems-being-operated* #:*asdf-upgrade-already-attempted* + #:*systems-being-operated* #:build-system #:load-system #:load-systems #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf - #:component-loaded-p #:already-loaded-systems - #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*)) + #:component-loaded-p #:already-loaded-systems)) (in-package :asdf/operate) (with-upgradability () @@ -7374,7 +7377,7 @@ for how to load or compile stuff") (clrhash *systems-being-defined*) (dolist (s l) (find-system s nil))))) - (pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)) + (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) ;;;; --------------------------------------------------------------------------- @@ -7700,11 +7703,11 @@ effectively disabling the output translation facility." (:recycle :asdf/source-registry :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) (:export - #:*source-registry* #:*source-registry-parameter* #:*default-source-registries* + #:*source-registry-parameter* #:*default-source-registries* #:invalid-source-registry - #:source-registry #:source-registry-initialized-p + #:source-registry-initialized-p #:initialize-source-registry #:clear-source-registry #:*source-registry* - #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter* + #:ensure-source-registry #:*source-registry-parameter* #:*default-source-registry-exclusions* #:*source-registry-exclusions* #:*wild-asd* #:directory-asd-files #:register-asd-directory #:collect-asds-in-directory #:collect-sub*directories-asd-files @@ -8795,9 +8798,7 @@ system names to pathnames of .asd files") #:monolithic-concatenate-source-op #:monolithic-load-concatenated-source-op #:monolithic-compile-concatenated-source-op - #:monolithic-load-compiled-concatenated-source-op - #:component-concatenated-source-file - #:concatenated-source-file)) + #:monolithic-load-compiled-concatenated-source-op)) (in-package :asdf/concatenate-source) ;;; @@ -9094,7 +9095,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:component #:parent-component #:child-component #:system #:module #:file-component #:source-file #:c-source-file #:java-source-file #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp - #:static-file #:doc-file #:html-file :text-file + #:static-file #:doc-file #:html-file #:source-file-type #:component-children ; component accessors @@ -9123,8 +9124,8 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:system-source-directory #:system-relative-pathname #:system-homepage + #:system-mailto #:system-bug-tracker - #:system-developers-email #:system-long-name #:system-source-control #:map-systems ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 317 +++++++++++++++++++------------------- src/general-info/release-20e.txt | 2 +- 2 files changed, 160 insertions(+), 159 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-17-gaabd629
by Raymond Toy 23 Feb '13

23 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via aabd62968d3137fb65237524ebfca3d6f27e90b0 (commit) from 8e1b40b35592720147dac16cfef2431b43ccbe5a (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit aabd62968d3137fb65237524ebfca3d6f27e90b0 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 08:40:00 2013 -0800 Update from commit logs. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index aa6e6ee..02953da 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -33,11 +33,14 @@ New in this release: However, there are no plans on supplying sparc binaries with this GC. * For x86, optimize TRUNCATE when the second arg is a compile-time - constant. (Sparc and ppc already had this optimization) + constant and use a multiplication instead of a division. (Sparc + and ppc already had this optimization) * The following *FEATURES* have been removed: * :COMMON (not used) * :CONSERVATIVE-FLOAT-TYPE (Always default to this in type derivation.) + * :I486 and :PENTIUM (Always assume we're running on at least a + Pentium.) * ANSI compliance fixes: ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20e.txt | 5 ++++- 1 files changed, 4 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-16-g8e1b40b
by Raymond Toy 23 Feb '13

23 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 8e1b40b35592720147dac16cfef2431b43ccbe5a (commit) from 3c88c09556da4e0f797dc90beba16c76ac972c26 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8e1b40b35592720147dac16cfef2431b43ccbe5a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 08:31:57 2013 -0800 Remove old stuff. * Remove support for :athlon in fp-pop. * Remove all of the enhanced pentium pro fp comparison code. Use the non ppro everywhere. diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index f8f57e6..a515e40 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -33,9 +33,7 @@ ;;; For the AMD Athlon, using ffreep fr0 is faster. ;;; (defun fp-pop () - (if (backend-featurep :athlon) - (inst ffreep fr0-tn) - (inst fstp fr0-tn))) + (inst fstp fr0-tn)) (macrolet ((ea-for-xf-desc (tn slot) @@ -1482,7 +1480,6 @@ (:conditional) (:info target not-p) (:policy :fast-safe) - (:guard (not (backend-featurep :ppro))) (:note _N"inline float comparison") (:ignore temp fr0) (:generator 3 @@ -1571,7 +1568,6 @@ (:conditional) (:info target not-p) (:policy :fast-safe) - (:guard (not (backend-featurep :ppro))) (:note _N"inline float comparison") (:ignore temp fr0) (:generator 3 @@ -1659,7 +1655,6 @@ (:conditional) (:info target not-p) (:policy :fast-safe) - (:guard (not (backend-featurep :ppro))) (:note _N"inline float comparison") (:ignore temp) (:generator 3 @@ -1768,99 +1763,6 @@ (frob = #x40)) - -;;;; Enhanced Pentium Pro floating point comparisons. - -;;; These comparisions use the faster sequences bases upon FCOMI and FUCOMI, -;;; which write to the condition codes. However, correct IEEE handling of -;;; unordered arguments requires the comparision of multiple flags which is -;;; only possible for the comparison (> ST0 operand) in which case the :b and -;;; :be tests can check that both ZF and CF are zero, or either is one -;;; respectively. For the opposite comparision (< ST0 operand), the arguments -;;; may be swapped and the > comparision used, but for equality the slower -;;; FNSTSW variation must be used. - -(define-vop (ppro-</float) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:guard (backend-featurep :ppro)) - (:note _N"inline float comparison") - (:generator 3 - ;; Handle a few special cases - (cond - ;; x is in ST0; y is in any reg. - ((zerop (tn-offset x)) - (inst fxch y) - (inst fcomi y) - (inst fxch y)) - ;; y is in ST0; x is in another reg. - ((zerop (tn-offset y)) - (inst fcomi x)) - ;; x and y are the same register, not ST0. - ((location= x y) - (inst fxch x) - (inst fcomi fr0-tn) - (inst fxch x)) - ;; x and y are different registers, neither ST0. - (t - (inst fxch y) - (inst fcomi x) - (inst fxch y))) - (inst jmp (if not-p :be :nbe) target))) - -(macrolet ((frob (type sc) - `(define-vop (,(symbolicate "PPRO-</" type) ppro-</float) - (:translate <) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,type ,type)))) - (frob single-float single-reg) - (frob double-float double-reg) - #+long-float (frob long-float long-reg)) - -(define-vop (ppro->/float) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:guard (backend-featurep :ppro)) - (:note _N"inline float comparison") - (:generator 3 - ;; Handle a few special cases - (cond - ;; x is in ST0; y is in any reg. - ((zerop (tn-offset x)) - (inst fcomi y)) - ;; y is in ST0; x is in another reg. - ((zerop (tn-offset y)) - (inst fxch x) - (inst fcomi x) - (inst fxch x)) - ;; x and y are the same register, not ST0. - ((location= x y) - (inst fxch x) - (inst fcomi fr0-tn) - (inst fxch x)) - ;; x and y are different registers, neither ST0. - (t - (inst fxch x) - (inst fcomi y) - (inst fxch x))) - (inst jmp (if not-p :be :nbe) target))) - -(macrolet ((frob (type sc) - `(define-vop (,(symbolicate "PPRO->/" type) ppro->/float) - (:translate >) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,type ,type)))) - (frob single-float single-reg) - (frob double-float double-reg) - #+long-float (frob long-float long-reg)) - - ;;;; Conversion: (macrolet ((frob (name translate to-sc to-type) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/float.lisp | 100 +------------------------------------------ 1 files changed, 1 insertions(+), 99 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-15-g3c88c09
by Raymond Toy 23 Feb '13

23 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 3c88c09556da4e0f797dc90beba16c76ac972c26 (commit) from ba036ec2f58f8bdd49a3807e32e9f48f72afb133 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 3c88c09556da4e0f797dc90beba16c76ac972c26 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 08:17:19 2013 -0800 Oops. Use the pentium version of the log1p vop and remove the other one. diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index 4d2ea5e..f8f57e6 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -3290,59 +3290,6 @@ (unless (zerop (tn-offset r)) (inst fstd r)))) -(define-vop (flog1p) - (:translate %log1p) - (:args (x :scs (double-reg) :to :result)) - (:temporary (:sc double-reg :offset fr0-offset - :from :argument :to :result) fr0) - (:temporary (:sc double-reg :offset fr1-offset - :from :argument :to :result) fr1) - (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:results (y :scs (double-reg))) - (:arg-types double-float) - (:result-types double-float) - (:policy :fast-safe) - (:guard (not (backend-featurep :sse2))) - (:note _N"inline log1p function") - (:ignore temp) - (:generator 5 - ;; x is in a FP reg, not fr0, fr1. - (fp-pop) - (fp-pop) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg *backend*) - :offset (- (tn-offset x) 2))) - ;; Check the range - (inst push #x3e947ae1) ; Constant 0.29 - (inst fabs) - (inst fld (make-ea :dword :base esp-tn)) - (inst fcompp) - (inst add esp-tn 4) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x45) - (inst jmp :z WITHIN-RANGE) - ;; Out of range for fyl2xp1. - (inst fld1) - (inst faddd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg *backend*) - :offset (- (tn-offset x) 1))) - (inst fldln2) - (inst fxch fr1) - (inst fyl2x) - (inst jmp DONE) - - WITHIN-RANGE - (inst fldln2) - (inst fldd (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg *backend*) - :offset (- (tn-offset x) 1))) - (inst fyl2xp1) - DONE - (inst fld fr0) - (case (tn-offset y) - ((0 1)) - (t (inst fstd y))))) - ;;; The Pentium has a less restricted implementation of the fyl2xp1 ;;; instruction and a range check can be avoided. (define-vop (flog1p-pentium) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/float.lisp | 53 ------------------------------------------- 1 files changed, 0 insertions(+), 53 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-14-gba036ec
by Raymond Toy 23 Feb '13

23 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via ba036ec2f58f8bdd49a3807e32e9f48f72afb133 (commit) from 6e4b411893ce81fd30f053f12474c2eeb986e5fa (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ba036ec2f58f8bdd49a3807e32e9f48f72afb133 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Feb 23 07:38:18 2013 -0800 Remove :PENTIUM from *FEATURES* code/misc.lisp:: * Don't register :PENTIUM feature. code/time.lisp:: * Replace :pentium with :x86; we assume all x86's have the rdtsc instruction. compiler/x86/float.lisp:: compiler/x86/system.lisp:: * Remove the vop guard on :pentium; assume we're always running on a pentium or better. diff --git a/src/code/misc.lisp b/src/code/misc.lisp index 50639d2..788a912 100644 --- a/src/code/misc.lisp +++ b/src/code/misc.lisp @@ -134,9 +134,6 @@ ;;; Register various Lisp features -#+pentium -(sys:register-lisp-runtime-feature :pentium) - #+sparc-v7 (sys:register-lisp-runtime-feature :sparc-v7) diff --git a/src/code/time.lisp b/src/code/time.lisp index 999610a..e6fb0c0 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -283,11 +283,12 @@ (system:get-system-info) (values user sys faults (get-bytes-consed)))) -#+(or pentium sparc-v9) +#+(or x86 sparc-v9) (defun cycle-count/float () (multiple-value-bind (lo hi) (vm::read-cycle-counter) (+ (* hi (expt 2.0d0 32)) lo))) + #+ppc (progn (alien:def-alien-variable cycles-per-tick c-call:int) @@ -300,7 +301,7 @@ (* cycles-per-tick (+ (* hi (expt 2.0d0 32)) lo)))) ) -#-(or pentium sparc-v9 ppc) +#-(or x86 sparc-v9 ppc) (defun cycle-count/float () 0.0) (defvar *time-consing* nil) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index e4d5952..4d2ea5e 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -3302,8 +3302,7 @@ (:arg-types double-float) (:result-types double-float) (:policy :fast-safe) - (:guard (or (not (backend-featurep :pentium)) - (not (backend-featurep :sse2)))) + (:guard (not (backend-featurep :sse2))) (:note _N"inline log1p function") (:ignore temp) (:generator 5 @@ -3357,8 +3356,7 @@ (:arg-types double-float) (:result-types double-float) (:policy :fast-safe) - (:guard (and (backend-featurep :pentium) - (not (backend-featurep :sse2)))) + (:guard (and (not (backend-featurep :sse2)))) (:note _N"inline log1p with limited x range function") (:vop-var vop) (:save-p :compute-only) diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index 93519d8..71f7bb2 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -590,7 +590,6 @@ (define-vop (read-cycle-counter) (:translate read-cycle-counter) - (:guard (backend-featurep :pentium)) (:args ) (:policy :fast-safe) (:results (lo :scs (unsigned-reg)) @@ -614,7 +613,6 @@ (move hi edx) (move lo eax))) -#+pentium (defun read-cycle-counter () (read-cycle-counter)) ----------------------------------------------------------------------- Summary of changes: src/code/misc.lisp | 3 --- src/code/time.lisp | 5 +++-- src/compiler/x86/float.lisp | 6 ++---- src/compiler/x86/system.lisp | 2 -- 4 files changed, 5 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-13-g6e4b411
by Raymond Toy 22 Feb '13

22 Feb '13

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 6e4b411893ce81fd30f053f12474c2eeb986e5fa (commit) from 6a9fd11d55bd794a02ec3686f3811d794aa8ac6d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 6e4b411893ce81fd30f053f12474c2eeb986e5fa Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Feb 21 22:21:10 2013 -0800 Remove the :i486 feature. code/misc.lisp:: * Remove :i486 from *features* code/multi-proc.lisp:: * Change :i486 to :x86 on the off chance that multi-proc will be ported to other archs. compiler/x86/cell.lisp:: compiler/x86/macros.lisp:: compiler/x86/memory.lisp:: * Remove guard on backend-featurep :i486 since we got rid of :i486 and have it always enabled now. diff --git a/src/code/misc.lisp b/src/code/misc.lisp index 7c83587..50639d2 100644 --- a/src/code/misc.lisp +++ b/src/code/misc.lisp @@ -134,9 +134,6 @@ ;;; Register various Lisp features -#+i486 -(sys:register-lisp-runtime-feature :i486) - #+pentium (sys:register-lisp-runtime-feature :pentium) diff --git a/src/code/multi-proc.lisp b/src/code/multi-proc.lisp index 2aed7a3..8b2df04 100644 --- a/src/code/multi-proc.lisp +++ b/src/code/multi-proc.lisp @@ -1886,10 +1886,10 @@ (process-wait whostate #'(lambda () (declare (optimize (speed 3))) - #-i486 + #-x86 (unless (lock-process lock) (setf (lock-process lock) *current-process*)) - #+i486 + #+x86 (null (kernel:%instance-set-conditional lock 2 nil *current-process*))))) @@ -1904,10 +1904,10 @@ whostate timeout #'(lambda () (declare (optimize (speed 3))) - #-i486 + #-x86 (unless (lock-process lock) (setf (lock-process lock) *current-process*)) - #+i486 + #+x86 (null (kernel:%instance-set-conditional lock 2 nil *current-process*))))) @@ -1915,7 +1915,7 @@ ;;; ;;; Atomically seize a lock if it's free. ;;; -#-i486 +#-x86 (defun seize-lock (lock) (declare (type lock lock) (optimize (speed 3))) @@ -1943,9 +1943,9 @@ (when (and (error-check-lock-p ,lock) ,have-lock) (error "Dead lock")) (when (or ,have-lock - #+i486 (null (kernel:%instance-set-conditional + #+x86 (null (kernel:%instance-set-conditional ,lock 2 nil *current-process*)) - #-i486 (seize-lock ,lock) + #-x86 (seize-lock ,lock) (if ,timeout (lock-wait-with-timeout ,lock ,whostate ,timeout) @@ -1956,19 +1956,19 @@ (when (and (error-check-lock-p ,lock) ,have-lock) (error "Dead lock")) (unless (or ,have-lock - #+i486 (null (kernel:%instance-set-conditional + #+x86 (null (kernel:%instance-set-conditional ,lock 2 nil *current-process*)) - #-i486 (seize-lock ,lock)) + #-x86 (seize-lock ,lock)) (lock-wait ,lock ,whostate)) ,@body)) (t `(when (or (and (recursive-lock-p ,lock) ,have-lock) - #+i486 (null (kernel:%instance-set-conditional + #+x86 (null (kernel:%instance-set-conditional ,lock 2 nil *current-process*)) - #-i486 (seize-lock ,lock)) + #-x86 (seize-lock ,lock)) ,@body))) (unless ,have-lock - #+i486 (kernel:%instance-set-conditional + #+x86 (kernel:%instance-set-conditional ,lock 2 *current-process* nil) - #-i486 (when (eq (lock-process ,lock) *current-process*) + #-x86 (when (eq (lock-process ,lock) *current-process*) (setf (lock-process ,lock) nil))))))) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 2487149..9283a78 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -383,7 +383,6 @@ (:temporary (:sc descriptor-reg :offset eax-offset :from (:argument 2) :to :result :target result) eax) (:results (result :scs (descriptor-reg any-reg))) - (:guard (backend-featurep :i486)) (:policy :fast-safe) (:generator 5 (move eax old-value) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index ca2c267..d4659c2 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -517,7 +517,6 @@ :from (:argument 2) :to :result :target result) eax) (:results (result :scs ,scs)) (:result-types ,el-type) - (:guard (backend-featurep :i486)) (:generator 5 (move eax old-value) (inst cmpxchg (make-ea :dword :base object :index index :scale 1 @@ -537,7 +536,6 @@ :from (:argument 1) :to :result :target result) eax) (:results (result :scs ,scs)) (:result-types ,el-type) - (:guard (backend-featurep :i486)) (:generator 4 (move eax old-value) (inst cmpxchg (make-ea :dword :base object diff --git a/src/compiler/x86/memory.lisp b/src/compiler/x86/memory.lisp index 18d5f37..7fc1a10 100644 --- a/src/compiler/x86/memory.lisp +++ b/src/compiler/x86/memory.lisp @@ -93,7 +93,6 @@ :from (:argument 1) :to :result :target result) eax) (:variant-vars offset lowtag) (:results (result :scs (descriptor-reg any-reg))) - (:guard (backend-featurep :i486)) (:generator 4 (move eax old-value) (inst cmpxchg (make-ea :dword :base object @@ -163,7 +162,6 @@ (:variant-vars base lowtag) (:results (result :scs (descriptor-reg any-reg))) (:info offset) - (:guard (backend-featurep :i486)) (:generator 4 (move eax old-value) (inst cmpxchg (make-ea :dword :base object ----------------------------------------------------------------------- Summary of changes: src/code/misc.lisp | 3 --- src/code/multi-proc.lisp | 26 +++++++++++++------------- src/compiler/x86/cell.lisp | 1 - src/compiler/x86/macros.lisp | 2 -- src/compiler/x86/memory.lisp | 2 -- 5 files changed, 13 insertions(+), 21 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs February 2013