You can subscribe to this list here.
2002 |
Jan
|
Feb
|
Mar
(23) |
Apr
(68) |
May
(99) |
Jun
(109) |
Jul
(112) |
Aug
(104) |
Sep
(177) |
Oct
(211) |
Nov
(162) |
Dec
(135) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2003 |
Jan
(126) |
Feb
(228) |
Mar
(238) |
Apr
(299) |
May
(257) |
Jun
(283) |
Jul
(192) |
Aug
(227) |
Sep
(295) |
Oct
(202) |
Nov
(180) |
Dec
(70) |
2004 |
Jan
(88) |
Feb
(73) |
Mar
(133) |
Apr
(141) |
May
(205) |
Jun
(130) |
Jul
(148) |
Aug
(247) |
Sep
(228) |
Oct
(175) |
Nov
(158) |
Dec
(222) |
2005 |
Jan
(159) |
Feb
(96) |
Mar
(145) |
Apr
(192) |
May
(132) |
Jun
(190) |
Jul
(194) |
Aug
(280) |
Sep
(195) |
Oct
(207) |
Nov
(154) |
Dec
(101) |
2006 |
Jan
(156) |
Feb
(110) |
Mar
(261) |
Apr
(183) |
May
(148) |
Jun
(133) |
Jul
(94) |
Aug
(141) |
Sep
(137) |
Oct
(111) |
Nov
(172) |
Dec
(124) |
2007 |
Jan
(111) |
Feb
(72) |
Mar
(155) |
Apr
(286) |
May
(138) |
Jun
(170) |
Jul
(129) |
Aug
(156) |
Sep
(170) |
Oct
(90) |
Nov
(119) |
Dec
(112) |
2008 |
Jan
(135) |
Feb
(102) |
Mar
(115) |
Apr
(42) |
May
(132) |
Jun
(106) |
Jul
(94) |
Aug
(67) |
Sep
(33) |
Oct
(123) |
Nov
(54) |
Dec
(219) |
2009 |
Jan
(143) |
Feb
(168) |
Mar
(68) |
Apr
(142) |
May
(224) |
Jun
(202) |
Jul
(83) |
Aug
(86) |
Sep
(68) |
Oct
(37) |
Nov
(93) |
Dec
(80) |
2010 |
Jan
(39) |
Feb
(76) |
Mar
(144) |
Apr
(141) |
May
(27) |
Jun
(70) |
Jul
(23) |
Aug
(155) |
Sep
(152) |
Oct
(167) |
Nov
(87) |
Dec
(12) |
2011 |
Jan
(18) |
Feb
(39) |
Mar
(18) |
Apr
(27) |
May
(45) |
Jun
(135) |
Jul
(31) |
Aug
(82) |
Sep
(14) |
Oct
(60) |
Nov
(112) |
Dec
(117) |
2012 |
Jan
(15) |
Feb
(4) |
Mar
(30) |
Apr
(62) |
May
(45) |
Jun
(30) |
Jul
(9) |
Aug
(23) |
Sep
(41) |
Oct
(56) |
Nov
(35) |
Dec
(43) |
2013 |
Jan
(19) |
Feb
(41) |
Mar
(31) |
Apr
(28) |
May
(109) |
Jun
(90) |
Jul
(24) |
Aug
(37) |
Sep
(52) |
Oct
(45) |
Nov
(58) |
Dec
(35) |
2014 |
Jan
(24) |
Feb
(48) |
Mar
(93) |
Apr
(100) |
May
(204) |
Jun
(107) |
Jul
(85) |
Aug
(89) |
Sep
(79) |
Oct
(70) |
Nov
(92) |
Dec
(54) |
2015 |
Jan
(100) |
Feb
(103) |
Mar
(94) |
Apr
(77) |
May
(96) |
Jun
(63) |
Jul
(116) |
Aug
(76) |
Sep
(81) |
Oct
(269) |
Nov
(253) |
Dec
(143) |
2016 |
Jan
(78) |
Feb
(150) |
Mar
(151) |
Apr
(107) |
May
(52) |
Jun
(49) |
Jul
(71) |
Aug
(68) |
Sep
(127) |
Oct
(95) |
Nov
(73) |
Dec
(106) |
2017 |
Jan
(224) |
Feb
(144) |
Mar
(144) |
Apr
(99) |
May
(84) |
Jun
(112) |
Jul
(136) |
Aug
(200) |
Sep
(206) |
Oct
(255) |
Nov
(210) |
Dec
(324) |
2018 |
Jan
(289) |
Feb
(140) |
Mar
(223) |
Apr
(171) |
May
(174) |
Jun
(131) |
Jul
(108) |
Aug
(139) |
Sep
(126) |
Oct
(142) |
Nov
(109) |
Dec
(195) |
2019 |
Jan
(129) |
Feb
(102) |
Mar
(120) |
Apr
(157) |
May
(126) |
Jun
(99) |
Jul
(102) |
Aug
(117) |
Sep
(128) |
Oct
(143) |
Nov
(153) |
Dec
(156) |
2020 |
Jan
(139) |
Feb
(149) |
Mar
(251) |
Apr
(175) |
May
(140) |
Jun
(117) |
Jul
(140) |
Aug
(209) |
Sep
(194) |
Oct
(160) |
Nov
(177) |
Dec
(170) |
2021 |
Jan
(41) |
Feb
(126) |
Mar
(155) |
Apr
(152) |
May
(150) |
Jun
(116) |
Jul
(54) |
Aug
(151) |
Sep
(102) |
Oct
(182) |
Nov
(230) |
Dec
(161) |
2022 |
Jan
(213) |
Feb
(164) |
Mar
(206) |
Apr
(232) |
May
(219) |
Jun
(196) |
Jul
(177) |
Aug
(142) |
Sep
(179) |
Oct
(161) |
Nov
(165) |
Dec
(212) |
2023 |
Jan
(265) |
Feb
(98) |
Mar
(149) |
Apr
(87) |
May
(110) |
Jun
(207) |
Jul
(176) |
Aug
(223) |
Sep
(136) |
Oct
(117) |
Nov
(202) |
Dec
(217) |
2024 |
Jan
(228) |
Feb
(246) |
Mar
(291) |
Apr
(215) |
May
(145) |
Jun
(128) |
Jul
(164) |
Aug
(143) |
Sep
(122) |
Oct
|
Nov
|
Dec
|
From: Douglas K. <sn...@us...> - 2014-06-03 01:43:25
|
The branch "master" has been updated in SBCL: via 138365e59075c92f57b4fe4abff31a04dc8134a5 (commit) from 415665ff54247d263a8ebd99ce60eeda03bf1896 (commit) - Log ----------------------------------------------------------------- commit 138365e59075c92f57b4fe4abff31a04dc8134a5 Author: Douglas Katzman <do...@go...> Date: Mon Jun 2 19:33:37 2014 -0400 Change some more uses of INCH-READ-BUFFER to TOKEN-BUF-GETCHAR. Also delete READ-UNWIND-READ-BUFFER which seemed to confuse rewinding with unwinding - I would think that an unwound tape couldn't be read again but a rewound one could. --- src/code/reader.lisp | 45 +++++++++++++++++++++------------------------ 1 files changed, 21 insertions(+), 24 deletions(-) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 77ee96c..7b010e1 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -587,11 +587,6 @@ standard Lisp readtable when NIL." (prog1 (elt (token-buf-string b) i) (setf (token-buf-inch-ptr b) (1+ i)))))) -(declaim (inline read-unwind-read-buffer)) -(defun read-unwind-read-buffer () - ;; Keep contents, but make next (INCH..) return first character. - (setf (token-buf-inch-ptr *read-buffer*) 0)) - ;; Grab a buffer off the token-buf pool if there is one, or else make one. ;; This does not need to be protected against other threads because the ;; pool is thread-local, or against async interrupts. An async signal @@ -1590,7 +1585,7 @@ extended <package-name>::<form-in-package> syntax." (defun make-float (stream) ;; Assume that the contents of *read-buffer* are a legal float, with nothing ;; else after it. - (read-unwind-read-buffer) + (setf (token-buf-inch-ptr *read-buffer*) 0) (let ((negative-fraction nil) (number 0) (divisor 1) @@ -1666,34 +1661,36 @@ extended <package-name>::<form-in-package> syntax." (defun make-ratio (stream) ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from ;; the string. + ;; This code is inferior to that of MAKE-INTEGER because it makes no + ;; attempt to perform as few bignum multiplies as possible. + ;; Not to mention it repeats the leading sign check code exactly. ;; - ;; Look for optional "+" or "-". - (let ((numerator 0) (denominator 0) (char ()) (negative-number nil)) - (read-unwind-read-buffer) - (setq char (inch-read-buffer)) - (cond ((char= char #\+) - (setq char (inch-read-buffer))) - ((char= char #\-) - (setq char (inch-read-buffer)) - (setq negative-number t))) + (let ((numerator 0) (denominator 0) (negativep nil) + (base *read-base*) (buf *read-buffer*)) + ;; Look for optional "+" or "-". + ;; guaranteed to have at least one character in buffer + (setf (token-buf-inch-ptr buf) + (case (elt (token-buf-string buf) 0) + (#\- (setq negativep t) 1) + (#\+ 1) + (t 0))) ;; Get numerator. - (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch *read-base*) - (digit-char-p ch *read-base*))) - ((not dig)) - (setq numerator (+ (* numerator *read-base*) dig))) + (loop (let ((dig (digit-char-p (token-buf-getchar buf) base))) + (if dig + (setq numerator (+ (* numerator base) dig)) + (return)))) ;; Get denominator. - (do* ((ch (inch-read-buffer) (inch-read-buffer)) + (do* ((ch (token-buf-getchar buf) (token-buf-getchar buf)) (dig ())) - ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) - (setq denominator (+ (* denominator *read-base*) dig))) + ((or (null ch) (not (setq dig (digit-char-p ch base))))) + (setq denominator (+ (* denominator base) dig))) (let ((num (handler-case (/ numerator denominator) (arithmetic-error (c) (error 'reader-impossible-number-error :error c :stream stream :format-control "failed to build ratio"))))) - (if negative-number (- num) num)))) + (if negativep (- num) num)))) ;;;; General reader for dispatch macros ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-03 00:44:10
|
The branch "master" has been updated in SBCL: via 415665ff54247d263a8ebd99ce60eeda03bf1896 (commit) from e5d8ddc36f2c10a8c89b2587d31f2e5340039a6f (commit) - Log ----------------------------------------------------------------- commit 415665ff54247d263a8ebd99ce60eeda03bf1896 Author: Stas Boukarev <sta...@gm...> Date: Tue Jun 3 04:36:07 2014 +0400 LOOP: produce warnings for empty types. Jan Moringen reported that the test (typep (loop with a of-type extended-char return a) 'extended-char) failed on #-sb-unicode. It returned 0.0 and didn't produce a warning during compilation, since extended-char is an empty type on #-sb-unicode. Catch empty types and don't produce default values for them. --- src/code/loop.lisp | 107 ++++++++++++++++++++++++++++---------------------- tests/loop.pure.lisp | 11 +++++ 2 files changed, 71 insertions(+), 47 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index f06750d..466b8c7 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -717,38 +717,42 @@ code to be loaded. ;;;; loop types (defun loop-typed-init (data-type &optional step-var-p) - (cond ((null data-type) - nil) - ((sb!xc:subtypep data-type 'number) - (let ((init (if step-var-p 1 0))) - (flet ((like (&rest types) - (coerce init (find-if (lambda (type) - (sb!xc:subtypep data-type type)) - types)))) - (cond ((sb!xc:subtypep data-type 'float) - (like 'single-float 'double-float - 'short-float 'long-float 'float)) - ((sb!xc:subtypep data-type '(complex float)) - (like '(complex single-float) - '(complex double-float) - '(complex short-float) - '(complex long-float) - '(complex float))) - (t - init))))) - ((sb!xc:subtypep data-type 'vector) - (let ((ctype (sb!kernel:specifier-type data-type))) - (when (sb!kernel:array-type-p ctype) - (let ((etype (sb!kernel:type-*-to-t - (sb!kernel:array-type-specialized-element-type ctype)))) - (make-array 0 :element-type (sb!kernel:type-specifier etype)))))) - #!+sb-unicode - ((sb!xc:subtypep data-type 'extended-char) - (code-char sb!int:base-char-code-limit)) - ((sb!xc:subtypep data-type 'character) - #\x) - (t - nil))) + ;; FIXME: can't tell if unsupplied or NIL, but it has to be rare. + (when data-type + (let ((ctype (sb!kernel:specifier-type data-type))) + ;; FIXME: use the ctype for the rest of the type operations, now + ;; that it's parsed. + (cond ((eql ctype sb!kernel:*empty-type*) + (values nil t)) + ((sb!xc:subtypep data-type 'number) + (let ((init (if step-var-p 1 0))) + (flet ((like (&rest types) + (coerce init (find-if (lambda (type) + (sb!xc:subtypep data-type type)) + types)))) + (cond ((sb!xc:subtypep data-type 'float) + (like 'single-float 'double-float + 'short-float 'long-float 'float)) + ((sb!xc:subtypep data-type '(complex float)) + (like '(complex single-float) + '(complex double-float) + '(complex short-float) + '(complex long-float) + '(complex float))) + (t + init))))) + ((sb!xc:subtypep data-type 'vector) + (when (sb!kernel:array-type-p ctype) + (let ((etype (sb!kernel:type-*-to-t + (sb!kernel:array-type-specialized-element-type ctype)))) + (make-array 0 :element-type (sb!kernel:type-specifier etype))))) + #!+sb-unicode + ((sb!xc:subtypep data-type 'extended-char) + (code-char sb!int:base-char-code-limit)) + ((sb!xc:subtypep data-type 'character) + #\x) + (t + nil))))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. @@ -911,6 +915,22 @@ code to be loaded. (loop-make-var (cdr name) nil tcdr))))) name) +;;; Find a suitable type for default initialization +(defun type-for-default-init (type &optional step-var-p) + (multiple-value-bind (init empty-type) + (loop-typed-init type step-var-p) + (values + (cond (empty-type + ;; Don't wrap empty types `(or ...), otherwise the will no + ;; longer be empty and the compiler won't produce + ;; warnings. + type) + ((sb!xc:typep init type) + type) + (t + `(or ,(type-of init) ,type))) + init))) + (defun loop-declare-var (name dtype &key step-var-p initialization desetq) (cond ((or (null name) (null dtype) (eq dtype t)) nil) @@ -920,10 +940,7 @@ code to be loaded. (eq :special (sb!int:info :variable :kind name)))) (let ((dtype `(type ,(if initialization dtype - (let ((init (loop-typed-init dtype step-var-p))) - (if (sb!xc:typep init dtype) - dtype - `(or ,(type-of init) ,dtype)))) + (type-for-default-init dtype step-var-p)) ,name))) (if desetq (push dtype *loop-desetq-declarations*) @@ -1033,14 +1050,12 @@ code to be loaded. (sb!int:defmacro-mundanely with-sum-count (lc &body body) (let* ((type (loop-collector-dtype lc)) - (temp-var (car (loop-collector-tempvars lc))) - (init (loop-typed-init type))) - `(let ((,temp-var ,init)) - (declare (type ,(if (sb!xc:typep init type) - type - `(or ,(type-of init) ,type)) - ,temp-var)) - ,@body))) + (temp-var (car (loop-collector-tempvars lc)))) + (multiple-value-bind (type init) + (type-for-default-init type) + `(let ((,temp-var ,init)) + (declare (type ,type ,temp-var)) + ,@body)))) (defun loop-get-collection-info (collector class default-type) (let ((form (loop-get-form)) @@ -1187,9 +1202,7 @@ code to be loaded. ((plusp form) `(mod ,(1+ (ceiling form)))) (t - `(integer ,(ceiling form) )) - - 'integer))) + `(integer ,(ceiling form)))))) (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type))) (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*) (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 44a7a6e..c467774 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -381,7 +381,18 @@ (with-test (:name :of-type-character) (assert (null (loop with a t return a))) + #-sb-unicode (assert (typep (loop with a of-type extended-char return a) 'extended-char)) (assert (typep (loop with a of-type character return a) 'character)) (assert (typep (loop with a of-type base-char return a) 'base-char)) (assert (typep (loop with a of-type standard-char return a) 'standard-char))) + +(with-test (:name :empty-type) + (assert-signal + (compile nil `(lambda () + (loop with a of-type (and fixnum string) return a))) + warning) + (assert-signal + (compile nil `(lambda () + (loop for i to 10 sum i of-type (and fixnum string)))) + warning)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-02 23:14:54
|
The branch "master" has been updated in SBCL: via e5d8ddc36f2c10a8c89b2587d31f2e5340039a6f (commit) from b6cc67e9bc77713a2fa5715d024d152ba2977f7e (commit) - Log ----------------------------------------------------------------- commit e5d8ddc36f2c10a8c89b2587d31f2e5340039a6f Author: Douglas Katzman <do...@go...> Date: Mon Jun 2 14:12:42 2014 -0400 Compute MAKE-INTEGER's magic constants for any n-fixnum-bits. Also rename token-buf's OUCH-PTR to FILL-PTR. --- src/code/cross-type.lisp | 3 + src/code/reader.lisp | 175 +++++++++++++++++++++++---------------------- 2 files changed, 92 insertions(+), 86 deletions(-) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 3eecd89..9426640 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -252,6 +252,9 @@ (values (typep host-object 'classoid) t)) ((target-type-is-in '(fixnum)) (values (fixnump host-object) t)) + ((target-type-is-in '(bignum)) + (values (and (integerp host-object) (not (fixnump host-object))) + t)) ;; Some types are too hard to handle in the positive ;; case, but at least we can be confident in a large ;; fraction of the negative cases.. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index a1a466a..77ee96c 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -511,7 +511,7 @@ standard Lisp readtable when NIL." ;; Always starts out EQ to 'initial-string'. (string nil :type (simple-array character (*))) ;; Counter advanced as characters are placed into 'string' - (ouch-ptr 0 :type index) + (fill-ptr 0 :type index) ;; Counter advanced as characters are consumed from 'string' on re-scan ;; by auxilliary functions MAKE-{INTEGER,FLOAT,RATIONAL} etc. (inch-ptr 0 :type index) @@ -523,6 +523,7 @@ standard Lisp readtable when NIL." :read-only t) ;; Link to next TOKEN-BUF, to chain the *TOKEN-BUF-POOL* together. (next nil :type (or null token-buf))) +(declaim (freeze-type token-buf)) (def!method print-object ((self token-buf) stream) (print-unreadable-object (self stream :identity t :type t) @@ -542,7 +543,7 @@ standard Lisp readtable when NIL." (declaim (inline reset-read-buffer)) (defun reset-read-buffer (&optional (b *read-buffer*)) ;; Turn *READ-BUFFER* into an empty read buffer. - (setf (token-buf-ouch-ptr b) 0) + (setf (token-buf-fill-ptr b) 0) (setf (token-buf-inch-ptr b) 0)) ;; "Output" a character into the reader's buffer. @@ -551,14 +552,14 @@ standard Lisp readtable when NIL." (declaim (inline ouch-read-buffer)) (defun ouch-read-buffer (char &optional (b *read-buffer*)) ;; When buffer overflow - (let ((op (token-buf-ouch-ptr b))) + (let ((op (token-buf-fill-ptr b))) (declare (optimize (sb!c::insert-array-bounds-checks 0))) (when (>= op (length (token-buf-string b))) ;; an out-of-line call for the uncommon case avoids bloat. ;; Size should be doubled. (grow-read-buffer)) (setf (elt (token-buf-string b) op) char) - (setf (token-buf-ouch-ptr b) (1+ op)))) + (setf (token-buf-fill-ptr b) (1+ op)))) (defun grow-read-buffer () (let* ((b *read-buffer*) @@ -568,7 +569,7 @@ standard Lisp readtable when NIL." (defun inch-read-buffer () (let ((b *read-buffer*)) - (if (>= (token-buf-inch-ptr b) (token-buf-ouch-ptr b)) + (if (>= (token-buf-inch-ptr b) (token-buf-fill-ptr b)) ;; this is inefficient. *eof-object* makes sense returned from READ, ;; but character input doesn't need it. This isn't even a stream ;; in the technical sense by the time we get to re-scanning the @@ -578,9 +579,13 @@ standard Lisp readtable when NIL." (elt (token-buf-string b) (token-buf-inch-ptr b)) (incf (token-buf-inch-ptr b)))))) -(declaim (inline unread-buffer)) -(defun unread-buffer () - (decf (token-buf-inch-ptr *read-buffer*))) +;; Exactly the same as above but with a convenient NIL=EOF convention +(defun token-buf-getchar (b) + (declare (optimize (sb!c::insert-array-bounds-checks 0))) + (let ((i (token-buf-inch-ptr b))) + (and (< i (token-buf-fill-ptr b)) + (prog1 (elt (token-buf-string b) i) + (setf (token-buf-inch-ptr b) (1+ i)))))) (declaim (inline read-unwind-read-buffer)) (defun read-unwind-read-buffer () @@ -621,7 +626,7 @@ standard Lisp readtable when NIL." ;; Return a fresh copy of *READ-BUFFER*'s string (defun copy-token-buf-string () (let ((b *read-buffer*)) - (subseq (token-buf-string b) 0 (token-buf-ouch-ptr b)))) + (subseq (token-buf-string b) 0 (token-buf-fill-ptr b)))) ;; Return a string displaced to *READ-BUFFER*'s string. Also get a ;; new token-buf which becomes the value of *READ-BUFFER*, @@ -642,10 +647,10 @@ standard Lisp readtable when NIL." (set-array-header (token-buf-adjustable-string buffer) ; the array (token-buf-string buffer) ; the underlying data - (token-buf-ouch-ptr buffer) ; total size + (token-buf-fill-ptr buffer) ; total size nil ; fill-pointer 0 ; displacement - (token-buf-ouch-ptr buffer) ; dimension 0 + (token-buf-fill-ptr buffer) ; dimension 0 t nil))) ; displacedp / newp ;; Acquire a TOKEN-BUF from the pool and execute the body, returning only @@ -884,7 +889,7 @@ standard Lisp readtable when NIL." (reset-read-buffer read-buffer) (let ((escapes '())) (when escape-firstchar - (push (token-buf-ouch-ptr read-buffer) escapes) + (push (token-buf-fill-ptr read-buffer) escapes) (ouch-read-buffer firstchar) (setq firstchar (read-char stream nil *eof-object*))) (do ((char firstchar (read-char stream nil *eof-object*)) @@ -898,7 +903,7 @@ standard Lisp readtable when NIL." (cond ((single-escape-p char) ;; It can't be a number, even if it's 1\23. ;; Read next char here, so it won't be casified. - (push (token-buf-ouch-ptr read-buffer) escapes) + (push (token-buf-fill-ptr read-buffer) escapes) (let ((nextchar (read-char stream nil *eof-object*))) (if (eofp nextchar) (reader-eof-error stream "after escape character") @@ -917,17 +922,17 @@ standard Lisp readtable when NIL." (cond ((eofp nextchar) (reader-eof-error stream "after escape character")) (t - (push (token-buf-ouch-ptr read-buffer) escapes) + (push (token-buf-fill-ptr read-buffer) escapes) (ouch-read-buffer nextchar))))) (t - (push (token-buf-ouch-ptr read-buffer) escapes) + (push (token-buf-fill-ptr read-buffer) escapes) (ouch-read-buffer ch)))))) (t (when (and (constituentp char) (eql (get-constituent-trait char) +char-attr-package-delimiter+) (not colon)) - (setq colon (token-buf-ouch-ptr read-buffer))) + (setq colon (token-buf-fill-ptr read-buffer))) (ouch-read-buffer char)))))) ;;;; character classes @@ -1018,13 +1023,13 @@ standard Lisp readtable when NIL." (cond ((and (null escapes) (eq case :upcase)) (let ((buffer (token-buf-string token-buf))) - (dotimes (i (token-buf-ouch-ptr token-buf)) + (dotimes (i (token-buf-fill-ptr token-buf)) (declare (optimize (sb!c::insert-array-bounds-checks 0))) (setf (schar buffer i) (char-upcase (schar buffer i)))))) ((eq case :preserve)) (t (macrolet ((skip-esc (&body body) - `(do ((i (1- (token-buf-ouch-ptr token-buf)) (1- i)) + `(do ((i (1- (token-buf-fill-ptr token-buf)) (1- i)) (buffer (token-buf-string token-buf)) (escapes escapes)) ((minusp i)) @@ -1207,15 +1212,13 @@ extended <package-name>::<form-in-package> syntax." MIDDLEDOT ; saw "[sign] {digit}+ dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (let ((*read-base* 10)) - (make-integer)))) + (unless char (return (make-integer 10))) (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-expt+ (go EXPONENT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (let ((*read-base* 10)) - (make-integer)))) + (return (make-integer 10))) (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -1370,7 +1373,7 @@ extended <package-name>::<form-in-package> syntax." (let ((nextchar (read-char stream nil nil))) (unless nextchar (reader-eof-error stream "after single-escape character")) - (push (token-buf-ouch-ptr *read-buffer*) escapes) + (push (token-buf-fill-ptr *read-buffer*) escapes) (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -1385,7 +1388,7 @@ extended <package-name>::<form-in-package> syntax." (do ((char (read-char stream t) (read-char stream t))) ((multiple-escape-p char)) (if (single-escape-p char) (setq char (read-char stream t))) - (push (token-buf-ouch-ptr *read-buffer*) escapes) + (push (token-buf-fill-ptr *read-buffer*) escapes) (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -1403,7 +1406,7 @@ extended <package-name>::<form-in-package> syntax." (copy-token-buf-string))) (setq colons 1) (setq package-designator - (if (or (plusp (token-buf-ouch-ptr *read-buffer*)) + (if (or (plusp (token-buf-fill-ptr *read-buffer*)) seen-multiple-escapes) (share-token-buf-string) *keyword-package*)) @@ -1450,10 +1453,10 @@ extended <package-name>::<form-in-package> syntax." (or *reader-package* (sane-package)))) (buf *read-buffer*)) (if (or (zerop colons) (= colons 2) (eq pkg *keyword-package*)) - (return (intern* (token-buf-string buf) (token-buf-ouch-ptr buf) + (return (intern* (token-buf-string buf) (token-buf-fill-ptr buf) pkg)) (multiple-value-bind (symbol accessibility) - (find-symbol* (token-buf-string buf) (token-buf-ouch-ptr buf) + (find-symbol* (token-buf-string buf) (token-buf-fill-ptr buf) pkg) (when (eq accessibility :external) (return symbol)) (let ((name (copy-token-buf-string))) @@ -1498,72 +1501,72 @@ extended <package-name>::<form-in-package> syntax." ;;;; number-reading functions -;;; FIXME: It would be cleaner to have these generated automatically -;;; by compile-time code instead of having them hand-created like -;;; this. The !COLD-INIT-INTEGER-READER code below should be resurrected -;;; and tested. -(defvar *integer-reader-safe-digits* - #(nil nil - 26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5) - #!+sb-doc - "the mapping of base to 'safe' number of digits to read for a fixnum") -(defvar *integer-reader-base-power* - #(nil nil - 67108864 129140163 67108864 48828125 60466176 40353607 - 16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625 - 16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343 - 7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151 - 33554432 39135393 45435424 52521875 60466176) - #!+sb-doc - "the largest fixnum power of the base for MAKE-INTEGER") -(declaim (simple-vector *integer-reader-safe-digits* - *integer-reader-base-power*)) -#| -(defun !cold-init-integer-reader () - (do ((base 2 (1+ base))) +;; Mapping of read-base to the max input characters in a positive fixnum. +(eval-when (:compile-toplevel :execute) + (defun integer-reader-safe-digits () + (do ((a (make-array 35 :element-type '(unsigned-byte 8))) + (base 2 (1+ base))) + ((> base 36) a) + (do ((total (1- base) (+ (* total base) (1- base))) + (n-digits 0 (1+ n-digits))) + ((sb!xc:typep total 'bignum) + (setf (aref a (- base 2)) n-digits)) + ;; empty DO body + ))) + + ;; self-test + (do ((maxdigits (integer-reader-safe-digits)) + (base 2 (1+ base))) ((> base 36)) - (let ((digits - (do ((fix (truncate most-positive-fixnum base) - (truncate fix base)) - (digits 0 (1+ digits))) - ((zerop fix) digits)))) - (setf (aref *integer-reader-safe-digits* base) - digits - (aref *integer-reader-base-power* base) - (expt base digits))))) -|# + (let* ((n-digits (aref maxdigits (- base 2))) + (d (char (write-to-string (1- base) :base base) 0)) + (string (make-string (1+ n-digits) :initial-element d))) ; 1 extra + (assert (not (typep (parse-integer string :radix base) + `(unsigned-byte ,sb!vm:n-positive-fixnum-bits)))) + (assert (typep (parse-integer string :end n-digits :radix base) + `(unsigned-byte ,sb!vm:n-positive-fixnum-bits)))))) -(defun make-integer () +(defun make-integer (&optional (base *read-base*)) #!+sb-doc "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, then multiplying by a power of the base and adding." - (let* ((base *read-base*) - (digits-per (aref *integer-reader-safe-digits* base)) - (base-power (aref *integer-reader-base-power* base)) + (declare ((integer 2 36) base)) + (let* ((fixnum-max-digits + (macrolet ((maxdigits () (integer-reader-safe-digits))) + (aref (maxdigits) (- base 2)))) + (base-power + (macrolet ((base-powers () + (do ((maxdigits (integer-reader-safe-digits)) + (a (make-array 35)) + (base 2 (1+ base))) + ((> base 36) a) + (setf (aref a (- base 2)) + (expt base (aref maxdigits (- base 2))))))) + (truly-the integer (aref (base-powers) (- base 2))))) (negativep nil) - (number 0)) - (declare (type index digits-per base-power)) - (read-unwind-read-buffer) - (let ((char (inch-read-buffer))) - (cond ((char= char #\-) - (setq negativep t)) - ((char= char #\+)) - (t (unread-buffer)))) + (result 0) + (buf *read-buffer*)) + ;; guaranteed to have at least one character in buffer + (setf (token-buf-inch-ptr buf) + (case (elt (token-buf-string buf) 0) + (#\- (setq negativep t) 1) + (#\+ 1) + (t 0))) (loop - (let ((num 0)) - (declare (type index num)) - (dotimes (digit digits-per) - (let* ((ch (inch-read-buffer))) - (cond ((or (eofp ch) (char= ch #\.)) - (return-from make-integer - (let ((res - (if (zerop number) num - (+ num (* number - (expt base digit)))))) - (if negativep (- res) res)))) - (t (setq num (+ (digit-char-p ch base) - (the index (* num base)))))))) - (setq number (+ num (* number base-power))))))) + (let ((acc 0)) + (declare (type (and fixnum unsigned-byte) acc)) + (dotimes (digit-count fixnum-max-digits) + (let ((ch (token-buf-getchar buf))) + (if (or (not ch) (eql ch #\.)) + (return-from make-integer + (let ((result + (if (zerop result) acc + (+ (* result (expt base digit-count)) acc)))) + (if negativep (- result) result))) + (setq acc (truly-the fixnum + (+ (digit-char-p ch base) + (truly-the fixnum (* acc base)))))))) + (setq result (+ (* result base-power) acc)))))) (defun truncate-exponent (exponent number divisor) #!+sb-doc ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-02 17:18:57
|
The branch "master" has been updated in SBCL: via b6cc67e9bc77713a2fa5715d024d152ba2977f7e (commit) from 52c9799533597c4ef1f2e5c2387107fefca9c00f (commit) - Log ----------------------------------------------------------------- commit b6cc67e9bc77713a2fa5715d024d152ba2977f7e Author: Douglas Katzman <do...@go...> Date: Mon Jun 2 13:15:19 2014 -0400 Use a consistent message string when signaling reader package errors. Also improve some nondescript variable names, and a stealth bugfix. --- src/code/reader.lisp | 68 +++++++++++++++++++++++++---------------------- tests/reader.pure.lisp | 6 ++++ 2 files changed, 42 insertions(+), 32 deletions(-) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 18fc79e..a1a466a 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -648,12 +648,6 @@ standard Lisp readtable when NIL." (token-buf-ouch-ptr buffer) ; dimension 0 t nil))) ; displacedp / newp -;; Release the token-buf that was used for a package prefix. -(defun release-extra-token-buf () - (let ((extra-buf (token-buf-next *read-buffer*))) - (setf (token-buf-next *read-buffer*) nil) - (release-token-buf extra-buf))) - ;; Acquire a TOKEN-BUF from the pool and execute the body, returning only ;; the primary value therefrom. Recycle the buffer when done. ;; No UNWIND-PROTECT - recycling is designed to help with the common case @@ -1064,7 +1058,25 @@ standard Lisp readtable when NIL." (cond (all-lower (raise-em)) (all-upper (lower-em)))))))))))) -(defvar *reader-package* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *reader-package* nil)) +(declaim (type (or null package) *reader-package*) + (always-bound *reader-package*)) + +(defun reader-find-package (package-designator stream) + (if (%instancep package-designator) + package-designator + (let ((package (find-package package-designator))) + (cond (package + ;; Release the token-buf that was used for the designator + (release-token-buf (shiftf (token-buf-next *read-buffer*) nil)) + package) + (t + (error 'simple-reader-package-error + :package package-designator + :stream stream + :format-control "Package ~A does not exist." + :format-arguments (list package-designator))))))) (defun read-token (stream firstchar) #!+sb-doc @@ -1418,8 +1430,8 @@ extended <package-name>::<form-in-package> syntax." (#.+char-attr-delimiter+ (unread-char char stream) (if package-designator - (let* ((*reader-package* (%find-package-or-lose package-designator))) - (release-extra-token-buf) + (let* ((*reader-package* + (reader-find-package package-designator stream))) (return (read stream t nil t))) (simple-reader-error stream "illegal terminating character after a double-colon: ~S" @@ -1433,36 +1445,28 @@ extended <package-name>::<form-in-package> syntax." (t (go SYMBOL))) RETURN-SYMBOL (casify-read-buffer escapes) - (let ((found (if package-designator - (or (find-package package-designator) - (error 'simple-reader-package-error - :package package-designator - :stream stream - :format-control "Package ~A does not exist." - :format-arguments (list package-designator))) - (or *reader-package* (sane-package))))) - (when (stringp package-designator) - (release-extra-token-buf)) - (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) - (let ((b *read-buffer*)) - (return (intern* (token-buf-string b) (token-buf-ouch-ptr b) - found))) - (multiple-value-bind (symbol test) - (let ((b *read-buffer*)) - (find-symbol* (token-buf-string b) (token-buf-ouch-ptr b) - found)) - (when (eq test :external) (return symbol)) + (let ((pkg (if package-designator + (reader-find-package package-designator stream) + (or *reader-package* (sane-package)))) + (buf *read-buffer*)) + (if (or (zerop colons) (= colons 2) (eq pkg *keyword-package*)) + (return (intern* (token-buf-string buf) (token-buf-ouch-ptr buf) + pkg)) + (multiple-value-bind (symbol accessibility) + (find-symbol* (token-buf-string buf) (token-buf-ouch-ptr buf) + pkg) + (when (eq accessibility :external) (return symbol)) (let ((name (copy-token-buf-string))) (with-simple-restart (continue "Use symbol anyway.") (error 'simple-reader-package-error - :package found + :package pkg :stream stream - :format-arguments (list name (package-name found)) + :format-arguments (list name (package-name pkg)) :format-control - (if test + (if accessibility "The symbol ~S is not external in the ~A package." "Symbol ~S not found in the ~A package."))) - (return (intern name found))))))))) + (return (intern name pkg))))))))) ;;; for semi-external use: ;;; diff --git a/tests/reader.pure.lisp b/tests/reader.pure.lisp index c0b7f20..5d9fb97 100644 --- a/tests/reader.pure.lisp +++ b/tests/reader.pure.lisp @@ -296,6 +296,12 @@ (with-test (:name :bug-1095918) (assert (= (length `#3(1)) 3))) +(with-test (:name :obscure-reader-package-usage) + ;; commit 8fd604 cause a bug in reading "::(foo bar)" which tried + ;; to treat the package-designator as a string, but in this case + ;; it is hardcoded to *keyword-package*. + (assert (equal (read-from-string "::(foo bar)") '(:foo :bar)))) + #+x86-64 ;; I do not know the complete list of platforms for which this test ;; will not cons, but there were four different heap allocations ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-02 13:35:08
|
The branch "master" has been updated in SBCL: via 52c9799533597c4ef1f2e5c2387107fefca9c00f (commit) from 8fd60477c30df95b9b6bfd71eafe49e66f3cfa3e (commit) - Log ----------------------------------------------------------------- commit 52c9799533597c4ef1f2e5c2387107fefca9c00f Author: Stas Boukarev <sta...@gm...> Date: Mon Jun 2 17:19:01 2014 +0400 Implement SOFTWARE-VERSION for Android. Using uname(2) instead of run-program "uname", which is missing. --- src/code/android-os.lisp | 13 ++++++++++++- src/runtime/android-os.c | 10 ++++++++++ 2 files changed, 22 insertions(+), 1 deletions(-) diff --git a/src/code/android-os.lisp b/src/code/android-os.lisp index 1c5b4d2..b033bc1 100644 --- a/src/code/android-os.lisp +++ b/src/code/android-os.lisp @@ -26,7 +26,18 @@ #!+sb-doc "Return a string describing version of the supporting software, or NIL if not available." - NIL) + (or *software-version* + (setf *software-version* + (sb!alien:with-alien + ((ptr (* char) + (sb!alien:alien-funcall + (sb!alien:extern-alien "software_version" + (function (* sb!alien:char)))))) + (and (not (sb!alien:null-alien ptr)) + (unwind-protect + (sb!alien:with-alien ((c-string sb!alien:c-string ptr)) + c-string) + (sb!alien:free-alien ptr))))))) ;;; Return user time, system time, and number of page faults. (defun get-system-info () diff --git a/src/runtime/android-os.c b/src/runtime/android-os.c index 5e91129..c94e275 100644 --- a/src/runtime/android-os.c +++ b/src/runtime/android-os.c @@ -9,3 +9,13 @@ * places). For some operating systems, a subset of these functions * will have to be emulated. */ + +#include <sys/utsname.h> + +extern char * software_version () { + struct utsname u; + int result = uname(&u); + if (result < 0) + return 0; + return strdup(u.release); +} ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-02 06:11:05
|
The branch "master" has been updated in SBCL: via 8fd60477c30df95b9b6bfd71eafe49e66f3cfa3e (commit) from 95dab9c49b6b72548d79fa1728b07273a8e52fbd (commit) - Log ----------------------------------------------------------------- commit 8fd60477c30df95b9b6bfd71eafe49e66f3cfa3e Author: Douglas Katzman <do...@go...> Date: Mon Jun 2 01:36:24 2014 -0400 Improve the reader's token buffer mechanism. - fewer special variables. Instead of *INCH-PTR* and *OUCH-PTR* there is just *READ-BUFFER* which is a struct, so among the simplifications, checking whether a recursive read is in progress is just one BOUNDP call. - less consing through use of a pool of strings into which to read. Reading single-floats (on 64-bit) and fixnums should never cons, aside from making a new buffer one time. Slurping in the contents of enc-jpn-tbl.lisp is about 10% faster and conses 1/3rd as much. --- src/code/backq.lisp | 3 +- src/code/reader.lisp | 282 ++++++++++++++++++++++++++++++------------- src/code/sysmacs.lisp | 35 +++-- src/code/target-thread.lisp | 2 + tests/reader.pure.lisp | 21 +++ 5 files changed, 245 insertions(+), 98 deletions(-) diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 51bdadf..580753f 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -91,7 +91,8 @@ (*backquote-count* (1- *backquote-count*))) (flet ((check (what) (let ((x (peek-char t stream t nil t))) - (when (and (char= x #\)) (eq #'read-right-paren (get-macro-character #\)))) + (when (and (char= x #\)) + (eq 'read-right-paren (get-macro-character #\)))) ;; Easier to figure out than an "unmatched parenthesis". (simple-reader-error stream "Trailing ~A in backquoted expression." what))))) (cond ((char= c #\@) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index e89d459..18fc79e 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -136,12 +136,14 @@ ;;; default behavior. (defmacro with-char-macro-result ((result-var supplied-p-var) (stream char) &body body) - `(multiple-value-call (lambda (&optional (,result-var nil ,supplied-p-var) - &rest junk) - (declare (ignore junk)) ; is this ANSI-specified? - ,@body) - (let ((entry (get-raw-cmt-entry ,char *readtable*))) - (funcall (!cmt-entry-to-function entry #'read-token) ,stream ,char)))) + (with-unique-names (proc) + `(dx-flet ((,proc (&optional (,result-var nil ,supplied-p-var) &rest junk) + (declare (ignore junk)) ; is this ANSI-specified? + ,@body)) + (multiple-value-call #',proc + (let ((entry (get-raw-cmt-entry ,char *readtable*))) + (funcall (!cmt-entry-to-function entry #'read-token) + ,stream ,char)))))) (defun undefined-macro-char (stream char) (unless *read-suppress* @@ -474,8 +476,10 @@ standard Lisp readtable when NIL." ;; Easy macro-character definitions are in this source file. (set-macro-character #\" #'read-string) (set-macro-character #\' #'read-quote) - (set-macro-character #\( #'read-list) - (set-macro-character #\) #'read-right-paren) + ;; Using symbols makes these traceable and redefineable with ease, + ;; as well as avoids a forward-referenced function (from "backq") + (set-macro-character #\( 'read-list) + (set-macro-character #\) 'read-right-paren) (set-macro-character #\; #'read-comment) ;; (The hairier macro-character definitions, for #\# and #\`, are ;; defined elsewhere, in their own source files.) @@ -492,70 +496,176 @@ standard Lisp readtable when NIL." ;;;; implementation of the read buffer +(defstruct (token-buf (:predicate nil) (:copier nil) + (:constructor + make-token-buf + (&aux + (initial-string (make-string 128)) + (string initial-string) + (adjustable-string + (make-array 0 + :element-type 'character + :fill-pointer nil + :displaced-to string))))) + ;; The string accumulated during reading of tokens. + ;; Always starts out EQ to 'initial-string'. + (string nil :type (simple-array character (*))) + ;; Counter advanced as characters are placed into 'string' + (ouch-ptr 0 :type index) + ;; Counter advanced as characters are consumed from 'string' on re-scan + ;; by auxilliary functions MAKE-{INTEGER,FLOAT,RATIONAL} etc. + (inch-ptr 0 :type index) + ;; A string used only for FIND-PACKAGE calls in package-qualified + ;; symbols so that we don't need to call SUBSEQ on the 'string'. + (adjustable-string nil :type (and (array character (*)) (not simple-array))) + ;; A small string that is permanently assigned into this token-buf. + (initial-string nil :type (simple-array character (128)) + :read-only t) + ;; Link to next TOKEN-BUF, to chain the *TOKEN-BUF-POOL* together. + (next nil :type (or null token-buf))) + +(def!method print-object ((self token-buf) stream) + (print-unreadable-object (self stream :identity t :type t) + (format stream "~@[next=~S~]" (token-buf-next self)))) + +;; The current TOKEN-BUF +(declaim (type token-buf *read-buffer*)) (defvar *read-buffer*) -(defvar *inch-ptr*) ; *OUCH-PTR* always points to next char to write. -(defvar *ouch-ptr*) ; *INCH-PTR* always points to next char to read. - -(declaim (type index *inch-ptr* *ouch-ptr*)) -(declaim (type (simple-array character (*)) *read-buffer*)) +;; A list of available TOKEN-BUFs +;; Should need no toplevel binding if multi-threaded, +;; but doesn't really matter, as INITIAL-THREAD-FUNCTION-TRAMPOLINE +;; rebinds to NIL. +(declaim (type (or null token-buf) *token-buf-pool*)) +(defvar *token-buf-pool* nil) (declaim (inline reset-read-buffer)) -(defun reset-read-buffer () +(defun reset-read-buffer (&optional (b *read-buffer*)) ;; Turn *READ-BUFFER* into an empty read buffer. - (setq *ouch-ptr* 0) - (setq *inch-ptr* 0)) + (setf (token-buf-ouch-ptr b) 0) + (setf (token-buf-inch-ptr b) 0)) +;; "Output" a character into the reader's buffer. +;; FIXME: Most code still does not specify the optional argument. +;; It is more efficient to do so than not. (declaim (inline ouch-read-buffer)) -(defun ouch-read-buffer (char) +(defun ouch-read-buffer (char &optional (b *read-buffer*)) ;; When buffer overflow - (let ((op *ouch-ptr*)) + (let ((op (token-buf-ouch-ptr b))) (declare (optimize (sb!c::insert-array-bounds-checks 0))) - (when (>= op (length *read-buffer*)) + (when (>= op (length (token-buf-string b))) + ;; an out-of-line call for the uncommon case avoids bloat. ;; Size should be doubled. (grow-read-buffer)) - (setf (elt *read-buffer* op) char) - (setq *ouch-ptr* (1+ op)))) + (setf (elt (token-buf-string b) op) char) + (setf (token-buf-ouch-ptr b) (1+ op)))) (defun grow-read-buffer () - (let* ((rbl (length *read-buffer*)) - (new-length (* 2 rbl)) - (new-buffer (make-string new-length))) - (setq *read-buffer* (replace new-buffer *read-buffer*)))) + (let* ((b *read-buffer*) + (string (token-buf-string b))) + (setf (token-buf-string b) + (replace (make-string (* 2 (length string))) string)))) (defun inch-read-buffer () - (if (>= *inch-ptr* *ouch-ptr*) - *eof-object* + (let ((b *read-buffer*)) + (if (>= (token-buf-inch-ptr b) (token-buf-ouch-ptr b)) + ;; this is inefficient. *eof-object* makes sense returned from READ, + ;; but character input doesn't need it. This isn't even a stream + ;; in the technical sense by the time we get to re-scanning the + ;; token-buf. We should just use the obvious choice: NIL. + *eof-object* (prog1 - (elt *read-buffer* *inch-ptr*) - (incf *inch-ptr*)))) + (elt (token-buf-string b) (token-buf-inch-ptr b)) + (incf (token-buf-inch-ptr b)))))) (declaim (inline unread-buffer)) (defun unread-buffer () - (decf *inch-ptr*)) + (decf (token-buf-inch-ptr *read-buffer*))) (declaim (inline read-unwind-read-buffer)) (defun read-unwind-read-buffer () ;; Keep contents, but make next (INCH..) return first character. - (setq *inch-ptr* 0)) + (setf (token-buf-inch-ptr *read-buffer*) 0)) -(defun read-buffer-to-string () - (subseq *read-buffer* 0 *ouch-ptr*)) +;; Grab a buffer off the token-buf pool if there is one, or else make one. +;; This does not need to be protected against other threads because the +;; pool is thread-local, or against async interrupts. An async signal +;; delivered anywhere in the midst of the code sequence below can not +;; corrupt the buffer given to the caller of ACQUIRE-TOKEN-BUF. +;; Additionally the cleanup is on a "best effort" basis. Async unwinds +;; through WITH-READ-BUFFER fail to recycle token-bufs, but that's ok. +(defun acquire-token-buf () + (let ((this-buffer *token-buf-pool*)) + (cond (this-buffer + (shiftf *token-buf-pool* (token-buf-next this-buffer) nil) + this-buffer) + (t + (make-token-buf))))) +(defun release-token-buf (chain) + (named-let free ((buffer chain)) + ;; If 'adjustable-string' was displaced to 'string', + ;; adjust it back down to allow GC of the abnormally large string. + (unless (eq (%array-data-vector (token-buf-adjustable-string buffer)) + (token-buf-initial-string buffer)) + (adjust-array (token-buf-adjustable-string buffer) '(0) + :displaced-to (token-buf-initial-string buffer))) + ;; 'initial-string' is assigned into 'string' + ;; so not to preserve huge buffers in the pool indefinitely. + (setf (token-buf-string buffer) (token-buf-initial-string buffer)) + (if (token-buf-next buffer) + (free (token-buf-next buffer)) + (setf (token-buf-next buffer) *token-buf-pool*))) + (setf *token-buf-pool* chain)) + +;; Return a fresh copy of *READ-BUFFER*'s string +(defun copy-token-buf-string () + (let ((b *read-buffer*)) + (subseq (token-buf-string b) 0 (token-buf-ouch-ptr b)))) + +;; Return a string displaced to *READ-BUFFER*'s string. Also get a +;; new token-buf which becomes the value of *READ-BUFFER*, +;; with its 'next' slot pointing to the old one. +(defun share-token-buf-string () + (let ((new-buffer (acquire-token-buf)) + (buffer *read-buffer*)) + (setf (token-buf-next new-buffer) buffer + *read-buffer* new-buffer) + ;; It would in theory be faster to make the adjustable array have + ;; a fill-pointer, and just set that most of the time. Except we still + ;; need the ability to displace to a different string if a package name + ;; has >128 characters, so then there'd be two modes of sharing, one of + ;; which is rarely exercised and most likely to be subtly wrong. + ;; At any rate, SET-ARRAY-HEADER is faster than ADJUST-ARRAY. + ;; TODO: find evidence that it is/is-not worth having complicated + ;; mechanism involving a fill-pointer or not. + (set-array-header + (token-buf-adjustable-string buffer) ; the array + (token-buf-string buffer) ; the underlying data + (token-buf-ouch-ptr buffer) ; total size + nil ; fill-pointer + 0 ; displacement + (token-buf-ouch-ptr buffer) ; dimension 0 + t nil))) ; displacedp / newp + +;; Release the token-buf that was used for a package prefix. +(defun release-extra-token-buf () + (let ((extra-buf (token-buf-next *read-buffer*))) + (setf (token-buf-next *read-buffer*) nil) + (release-token-buf extra-buf))) + +;; Acquire a TOKEN-BUF from the pool and execute the body, returning only +;; the primary value therefrom. Recycle the buffer when done. +;; No UNWIND-PROTECT - recycling is designed to help with the common case +;; of normal return and is not intended to be resilient against nonlocal exit. (defmacro with-read-buffer (() &body body) - `(let* ((*read-buffer* (make-string 128)) - (*ouch-ptr* 0) - (*inch-ptr* 0)) - ,@body)) - -(declaim (inline read-buffer-boundp)) -(defun read-buffer-boundp () - (and (boundp '*read-buffer*) - (boundp '*ouch-ptr*) - (boundp '*inch-ptr*))) + `(let* ((*read-buffer* (acquire-token-buf)) + (result (progn ,@body))) + (release-token-buf *read-buffer*) + result)) (defun check-for-recursive-read (stream recursive-p operator-name) - (when (and recursive-p (not (read-buffer-boundp))) + (when (and recursive-p (not (boundp '*read-buffer*))) (simple-reader-error stream "~A was invoked with RECURSIVE-P being true outside ~ @@ -579,6 +689,7 @@ standard Lisp readtable when NIL." ;;; Like READ-PRESERVING-WHITESPACE, but doesn't check the read buffer ;;; for being set up properly. (defun %read-preserving-whitespace (stream eof-error-p eof-value recursive-p) + (declare (optimize (sb!c::check-tag-existence 0))) (if recursive-p ;; a loop for repeating when a macro returns nothing (loop @@ -692,6 +803,7 @@ standard Lisp readtable when NIL." (declare (ignore ignore)) (let* ((thelist (list nil)) (listtail thelist)) + (declare (dynamic-extent thelist)) (do ((firstchar (flush-whitespace stream) (flush-whitespace stream))) ((char= firstchar #\) ) (cdr thelist)) (when (char= firstchar #\.) @@ -742,26 +854,28 @@ standard Lisp readtable when NIL." (defun read-string (stream closech) ;; This accumulates chars until it sees same char that invoked it. ;; For a very long string, this could end up bloating the read buffer. - (reset-read-buffer) - (let ((stream (in-synonym-of stream))) + (let ((stream (in-synonym-of stream)) + (buf *read-buffer*) + (rt *readtable*)) + (reset-read-buffer buf) (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech) (done-with-fast-read-char)) - (if (single-escape-p char) (setq char (fast-read-char t))) - (ouch-read-buffer char))) + (if (single-escape-p char rt) (setq char (fast-read-char t))) + (ouch-read-buffer char buf))) ;; CLOS stream (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char closech)) (if (eq char :eof) (error 'end-of-file :stream stream))) - (when (single-escape-p char) + (when (single-escape-p char rt) (setq char (read-char stream nil :eof)) (if (eq char :eof) (error 'end-of-file :stream stream))) - (ouch-read-buffer char)))) - (read-buffer-to-string)) + (ouch-read-buffer char buf)))) + (copy-token-buf-string)) (defun read-right-paren (stream ignore) (declare (ignore ignore)) @@ -771,11 +885,12 @@ standard Lisp readtable when NIL." ;;; token in *READ-BUFFER*, and return two values: ;;; -- a list of the escaped character positions, and ;;; -- The position of the first package delimiter (or NIL). -(defun internal-read-extended-token (stream firstchar escape-firstchar) - (reset-read-buffer) +(defun internal-read-extended-token (stream firstchar escape-firstchar + &aux (read-buffer *read-buffer*)) + (reset-read-buffer read-buffer) (let ((escapes '())) (when escape-firstchar - (push *ouch-ptr* escapes) + (push (token-buf-ouch-ptr read-buffer) escapes) (ouch-read-buffer firstchar) (setq firstchar (read-char stream nil *eof-object*))) (do ((char firstchar (read-char stream nil *eof-object*)) @@ -789,7 +904,7 @@ standard Lisp readtable when NIL." (cond ((single-escape-p char) ;; It can't be a number, even if it's 1\23. ;; Read next char here, so it won't be casified. - (push *ouch-ptr* escapes) + (push (token-buf-ouch-ptr read-buffer) escapes) (let ((nextchar (read-char stream nil *eof-object*))) (if (eofp nextchar) (reader-eof-error stream "after escape character") @@ -808,17 +923,17 @@ standard Lisp readtable when NIL." (cond ((eofp nextchar) (reader-eof-error stream "after escape character")) (t - (push *ouch-ptr* escapes) + (push (token-buf-ouch-ptr read-buffer) escapes) (ouch-read-buffer nextchar))))) (t - (push *ouch-ptr* escapes) + (push (token-buf-ouch-ptr read-buffer) escapes) (ouch-read-buffer ch)))))) (t (when (and (constituentp char) (eql (get-constituent-trait char) +char-attr-package-delimiter+) (not colon)) - (setq colon *ouch-ptr*)) + (setq colon (token-buf-ouch-ptr read-buffer))) (ouch-read-buffer char)))))) ;;;; character classes @@ -904,19 +1019,19 @@ standard Lisp readtable when NIL." ;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse ;;; order. (defun casify-read-buffer (escapes) - (let ((case (readtable-case *readtable*))) + (let ((case (readtable-case *readtable*)) + (token-buf *read-buffer*)) (cond ((and (null escapes) (eq case :upcase)) - ;; Pull the special variable access out of the loop. - (let ((buffer *read-buffer*)) - (dotimes (i *ouch-ptr*) + (let ((buffer (token-buf-string token-buf))) + (dotimes (i (token-buf-ouch-ptr token-buf)) (declare (optimize (sb!c::insert-array-bounds-checks 0))) (setf (schar buffer i) (char-upcase (schar buffer i)))))) ((eq case :preserve)) (t (macrolet ((skip-esc (&body body) - `(do ((i (1- *ouch-ptr*) (1- i)) - (buffer *read-buffer*) + `(do ((i (1- (token-buf-ouch-ptr token-buf)) (1- i)) + (buffer (token-buf-string token-buf)) (escapes escapes)) ((minusp i)) (declare (fixnum i) @@ -1243,7 +1358,7 @@ extended <package-name>::<form-in-package> syntax." (let ((nextchar (read-char stream nil nil))) (unless nextchar (reader-eof-error stream "after single-escape character")) - (push *ouch-ptr* escapes) + (push (token-buf-ouch-ptr *read-buffer*) escapes) (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -1258,7 +1373,7 @@ extended <package-name>::<form-in-package> syntax." (do ((char (read-char stream t) (read-char stream t))) ((multiple-escape-p char)) (if (single-escape-p char) (setq char (read-char stream t))) - (push *ouch-ptr* escapes) + (push (token-buf-ouch-ptr *read-buffer*) escapes) (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -1273,19 +1388,13 @@ extended <package-name>::<form-in-package> syntax." (unless (zerop colons) (simple-reader-error stream "too many colons in ~S" - (read-buffer-to-string))) + (copy-token-buf-string))) (setq colons 1) (setq package-designator - (if (plusp *ouch-ptr*) - ;; FIXME: It seems inefficient to cons up a package - ;; designator string every time we read a symbol with an - ;; explicit package prefix. Perhaps we could implement - ;; a FIND-PACKAGE* function analogous to INTERN* - ;; and friends? - (read-buffer-to-string) - (if seen-multiple-escapes - (read-buffer-to-string) - *keyword-package*))) + (if (or (plusp (token-buf-ouch-ptr *read-buffer*)) + seen-multiple-escapes) + (share-token-buf-string) + *keyword-package*)) (reset-read-buffer) (setq escapes ()) (setq char (read-char stream nil nil)) @@ -1310,6 +1419,7 @@ extended <package-name>::<form-in-package> syntax." (unread-char char stream) (if package-designator (let* ((*reader-package* (%find-package-or-lose package-designator))) + (release-extra-token-buf) (return (read stream t nil t))) (simple-reader-error stream "illegal terminating character after a double-colon: ~S" @@ -1331,12 +1441,18 @@ extended <package-name>::<form-in-package> syntax." :format-control "Package ~A does not exist." :format-arguments (list package-designator))) (or *reader-package* (sane-package))))) + (when (stringp package-designator) + (release-extra-token-buf)) (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) - (return (intern* *read-buffer* *ouch-ptr* found)) + (let ((b *read-buffer*)) + (return (intern* (token-buf-string b) (token-buf-ouch-ptr b) + found))) (multiple-value-bind (symbol test) - (find-symbol* *read-buffer* *ouch-ptr* found) + (let ((b *read-buffer*)) + (find-symbol* (token-buf-string b) (token-buf-ouch-ptr b) + found)) (when (eq test :external) (return symbol)) - (let ((name (read-buffer-to-string))) + (let ((name (copy-token-buf-string))) (with-simple-restart (continue "Use symbol anyway.") (error 'simple-reader-package-error :package found @@ -1359,7 +1475,7 @@ extended <package-name>::<form-in-package> syntax." (multiple-value-bind (escapes colon) (internal-read-extended-token stream first-char nil) (casify-read-buffer escapes) - (values (read-buffer-to-string) (not (null escapes)) colon))) + (values (copy-token-buf-string) (not (null escapes)) colon))) (t (values "" nil nil))))) @@ -1372,7 +1488,7 @@ extended <package-name>::<form-in-package> syntax." (cond (first-char (let ((escapes (internal-read-extended-token stream first-char t))) (casify-read-buffer escapes) - (read-buffer-to-string))) + (copy-token-buf-string))) (t (reader-eof-error stream "after escape"))))) @@ -1538,7 +1654,7 @@ extended <package-name>::<form-in-package> syntax." (error 'reader-impossible-number-error :error c :stream stream :format-control "failed to build float from ~a" - :format-arguments (list (read-buffer-to-string)))))) + :format-arguments (list (copy-token-buf-string)))))) (defun make-ratio (stream) ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 8a0718d..940c862 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -163,21 +163,28 @@ maintained." ;;; a macro with the same calling convention as READ-CHAR, to be used ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR. +;;; If EOF-ERROR-P is statically T (not any random expression evaluating +;;; to T) then wrap the whole thing in (TRULY-THE CHARACTER ...) +;;; because it's either going to yield a character or signal EOF. (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ())) - `(cond - ((not %frc-buffer%) - (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value)) - ((= %frc-index% +ansi-stream-in-buffer-length+) - (multiple-value-bind (eof-p index-or-value) - (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value) - (if eof-p - index-or-value - (progn - (setq %frc-index% (1+ (truly-the index index-or-value))) - (aref %frc-buffer% index-or-value))))) - (t - (prog1 (aref %frc-buffer% %frc-index%) - (incf %frc-index%))))) + (let ((result + `(cond + ((not %frc-buffer%) + (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value)) + ((= %frc-index% +ansi-stream-in-buffer-length+) + (multiple-value-bind (eof-p index-or-value) + (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value) + (if eof-p + index-or-value + (progn + (setq %frc-index% (1+ (truly-the index index-or-value))) + (aref %frc-buffer% index-or-value))))) + (t + (prog1 (aref %frc-buffer% %frc-index%) + (incf %frc-index%)))))) + (if (eq eof-error-p 't) + `(truly-the character ,result) + result))) ;;;; And these for the fasloader... diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 8c0c4fa..0b322fa 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1404,6 +1404,8 @@ session." (sb!impl::*deadline* nil) (sb!impl::*deadline-seconds* nil) (sb!impl::*step-out* nil) + ;; internal reader variables + (sb!impl::*token-buf-pool* nil) ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) diff --git a/tests/reader.pure.lisp b/tests/reader.pure.lisp index 1a1164e..c0b7f20 100644 --- a/tests/reader.pure.lisp +++ b/tests/reader.pure.lisp @@ -13,6 +13,8 @@ (in-package "CL-USER") +(load "compiler-test-util.lisp") + (assert (equal (symbol-name '#:|fd\sA|) "fdsA")) ;;; Prior to sbcl-0.7.2.10, SBCL disobeyed the ANSI requirements on @@ -293,3 +295,22 @@ (with-test (:name :bug-1095918) (assert (= (length `#3(1)) 3))) + +#+x86-64 +;; I do not know the complete list of platforms for which this test +;; will not cons, but there were four different heap allocations +;; instead of using dx allocation or a recyclable resource: +;; - most obviously, a 128-character buffer per invocation of READ +;; - calling SUBSEQ for package names +;; - multiple-value-call in WITH-CHAR-MACRO-RESULT +;; - the initial cons cell in READ-LIST +(with-test (:name :read-does-not-cons-per-se) + (flet ((test-reading (string) + (let ((s (make-string-input-stream string))) + (ctu:assert-no-consing + (progn (file-position s 0) + (read s)))))) + ;; These each used to produce at least 5 MB of garbage + (test-reading "4.0s0") + (test-reading "COMMON-LISP-USER::A-SYMBOL") + (test-reading "()"))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 19:30:32
|
The branch "master" has been updated in SBCL: via 95dab9c49b6b72548d79fa1728b07273a8e52fbd (commit) from 6cba9a90c0c4a453f688f0bb6a6d57ffffdf9c0d (commit) - Log ----------------------------------------------------------------- commit 95dab9c49b6b72548d79fa1728b07273a8e52fbd Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 23:30:09 2014 +0400 Better undefined-alien-error support on ARM. Like on x86-64, report the name of the function being missing. call_into_c always uses R8, so use it to look up the linkage table. --- src/code/interr.lisp | 4 ++-- src/compiler/generic/interr.lisp | 2 +- src/compiler/generic/parms.lisp | 4 ++-- src/runtime/arm-assem.S | 28 ++++++++++++++++++++++++++++ src/runtime/interrupt.c | 4 ++-- tools-for-build/grovel-headers.c | 1 + 6 files changed, 36 insertions(+), 7 deletions(-) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index f1cdc49..48c5395 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -36,14 +36,14 @@ (symbol fdefn-or-symbol) (fdefn (fdefn-name fdefn-or-symbol))))) -#!+x86-64 +#!+(or arm x86-64) (deferr undefined-alien-fun-error (address) (error 'undefined-alien-function-error :name (and (integerp address) (sap-foreign-symbol (int-sap address))))) -#!-x86-64 +#!-(or arm x86-64) (defun undefined-alien-fun-error () (error 'undefined-alien-function-error)) diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp index 2a8a184..deadd58 100644 --- a/src/compiler/generic/interr.lisp +++ b/src/compiler/generic/interr.lisp @@ -71,7 +71,7 @@ ;; FIXME: Isn't this used for calls to unbound (SETF FOO) too? If so, revise ;; the name. "An attempt was made to use an undefined FDEFINITION.") - #!+x86-64 + #!+(or arm x86-64) (undefined-alien-fun "An attempt was made to use an undefined alien function") (invalid-arg-count "invalid argument count") diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index e085824..4a681c1 100644 --- a/src/compiler/generic/parms.lisp +++ b/src/compiler/generic/parms.lisp @@ -118,8 +118,8 @@ sb!kernel::undefined-alien-variable-error sb!kernel::memory-fault-error sb!kernel::unhandled-trap-error - ;; On x86-64 it's called through the internal errors mechanism - #!-x86-64 undefined-alien-fun-error + ;; On these it's called through the internal errors mechanism + #!-(or arm x86-64) undefined-alien-fun-error sb!di::handle-breakpoint sb!di::handle-single-step-trap #!+win32 sb!kernel::handle-win32-exception diff --git a/src/runtime/arm-assem.S b/src/runtime/arm-assem.S index f7d57a6..4bbb47b 100644 --- a/src/runtime/arm-assem.S +++ b/src/runtime/arm-assem.S @@ -232,6 +232,8 @@ call_into_c: @@ here because we have to be able to pass the function @@ pointer in a boxed register, but the linkage-table is quite @@ capable of doing a tail-call to a Thumb routine. + @@ + @@ R8 is important for undefined_alien_function. blx reg_R8 @@ We're back. Our main tasks are to move the C return value @@ -332,7 +334,33 @@ call_into_c: @@ offset of 7, not the 3 that we use for LEXENV. .byte sc_DescriptorReg + (0x40 * 3) .error_args_end: + + .align 3 + .global undefined_alien_function + .type undefined_alien_function, %object + .word SIMPLE_FUN_HEADER_WIDETAG + .equ undefined_alien_function, .+1 + .word undefined_alien_function + .word NIL + .word NIL + .word NIL + .word NIL + .word NIL +undefined_alien_function: + ldr reg_CODE, = undefined_alien_function + @@ The magic (undefined) "BREAK_POINT" instruction. + .word 0xe7f001f0 + + @@ Error arguments for an undefined function. + .byte trap_Error + .byte 4 + .byte UNDEFINED_ALIEN_FUN_ERROR + @@ Encode unsigned R8, which comes from call_into_c + .byte 0xFE + .byte 0x11 + .byte 0x02 + .align 3 .global closure_tramp .type closure_tramp, %object diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 950cc41..14c0129 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -1603,8 +1603,8 @@ arrange_return_to_lisp_function(os_context_t *context, lispobj function) #endif } -// x86-64 has an undefined_alien_function tramp in x86-64-assem.S -#ifndef LISP_FEATURE_X86_64 +// These have undefined_alien_function tramp in x-assem.S +#if !(defined(LISP_FEATURE_X86_64) || defined(LISP_FEATURE_ARM)) /* KLUDGE: Theoretically the approach we use for undefined alien * variables should work for functions as well, but on PPC/Darwin * we get bus error at bogus addresses instead, hence this workaround, diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 7801ba8..5c8857a 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -302,6 +302,7 @@ main(int argc, char *argv[]) DEFTYPE("mode-t", mode_t); DEFTYPE("wst-dev-t", wst_dev_t); + DEFTYPE("wst-ino-t", wst_ino_t); DEFTYPE("wst-off-t", wst_off_t); DEFTYPE("wst-blksize-t", wst_blksize_t); DEFTYPE("wst-blkcnt-t", wst_blkcnt_t); ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 19:30:29
|
The branch "master" has been updated in SBCL: via 6cba9a90c0c4a453f688f0bb6a6d57ffffdf9c0d (commit) from 30d48e68d8d554e60a89bc8fab87bb9eeea65b80 (commit) - Log ----------------------------------------------------------------- commit 6cba9a90c0c4a453f688f0bb6a6d57ffffdf9c0d Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 23:13:48 2014 +0400 Avoid circularity in ENSURE-DYNAMIC-FOREIGN-SYMBOL-ADDRESS. Use FIND-FOREIGN-SYMBOL-ADDRESS instead of FOREIGN-SYMBOL-ADDRESS, which calls ENSURE-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, for finding "undefined_alien_function", otherwise in case undefined_alien_function is missing for some reason, this will enter endless recursion. --- src/code/foreign-load.lisp | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 7778653..0ad1f24 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -194,7 +194,7 @@ is never in the linkage-table." (remhash symbol symbols) (if datap undefined-alien-address - (foreign-symbol-address "undefined_alien_function"))) + (find-foreign-symbol-address "undefined_alien_function"))) (addr (setf (gethash symbol symbols) t) (remhash symbol undefineds) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 07:11:39
|
The branch "master" has been updated in SBCL: via 30d48e68d8d554e60a89bc8fab87bb9eeea65b80 (commit) from e55432f31f7ca3e342b4fd94dcb632ce77b1ba93 (commit) - Log ----------------------------------------------------------------- commit 30d48e68d8d554e60a89bc8fab87bb9eeea65b80 Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 10:59:32 2014 +0400 Resolve android C type problems. Android doesn't use off_t where SBCL expects to find it, declare things appropriately in struct stat, struct dirent. --- contrib/sb-posix/constants.lisp | 21 +++++++++++++++------ src/code/unix.lisp | 2 +- src/runtime/wrap.h | 13 +++++++++++-- tools-for-build/grovel-headers.c | 1 + 4 files changed, 28 insertions(+), 9 deletions(-) diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 11538da..3c36cf0 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -271,7 +271,8 @@ (:structure dirent (#+(and linux largefile) "struct dirent64" #-(and linux largefile) "struct dirent" - #-win32 (:ino-t ino "ino_t" "d_ino") + #-(or win32 android) (:ino-t ino "ino_t" "d_ino") + #+android ((unsigned 64) ino "unsigned long long" "d_ino") (:c-string name "char *" "d_name" ;; FIXME: sunos should really have :distrust-length ;; t, but this is currently broken. -- Jim Wise 2010-08-31 @@ -310,21 +311,31 @@ (:structure alien-stat ("struct stat" (mode-t mode "mode_t" "st_mode") + #-android (ino-t ino "ino_t" "st_ino") + #+android + ((unsigned 64) ino "unsigned long long" "st_ino") ;; Linux/MIPS uses unsigned long instead of dev_t here. - #-mips + #-(or mips android) (dev-t dev "dev_t" "st_dev") #+mips ((unsigned 32) dev "dev_t" "st_dev") + #+android + ((unsigned 64) dev "unsigned long long" "st_dev") (nlink-t nlink "nlink_t" "st_nlink") (uid-t uid "uid_t" "st_uid") ;; Linux/MIPS uses unsigned long instead of dev_t here. - #-mips + #-(or mips android) (dev-t rdev "dev_t" "st_rdev") #+mips ((unsigned 32) rdev "dev_t" "st_rdev") + #+android + ((unsigned 64) rdev "unsigned long long" "st_rdev") (gid-t gid "gid_t" "st_gid") + #-android (off-t size "off_t" "st_size") + #+android + ((signed 64) size "long long" "st_size") (time-t atime "time_t" "st_atime") (time-t mtime "time_t" "st_mtime") (time-t ctime "time_t" "st_ctime"))) @@ -649,6 +660,4 @@ log-info "LOG_INFO" "Log severity level denoting informational messages." t) #-win32 (:integer - log-debug "LOG_DEBUG" "Log severity level denoting debugging information ." t) - -) + log-debug "LOG_DEBUG" "Log severity level denoting debugging information ." t)) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 6ce4590..9553f62 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -817,7 +817,7 @@ avoiding atexit(3) hooks, etc. Otherwise exit(2) is called." (define-alien-type nil (struct wrapped_stat (st-dev wst-dev-t) - (st-ino ino-t) + (st-ino wst-ino-t) (st-mode mode-t) (st-nlink wst-nlink-t) (st-uid wst-uid-t) diff --git a/src/runtime/wrap.h b/src/runtime/wrap.h index 6942fbb..ade600b 100644 --- a/src/runtime/wrap.h +++ b/src/runtime/wrap.h @@ -42,12 +42,18 @@ typedef unsigned long aliased_dev_t; typedef dev_t aliased_dev_t; #endif -#if defined(LISP_FEATURE_LARGEFILE) || defined(LISP_FEATURE_DARWIN) +#ifdef LISP_FEATURE_ANDROID +typedef unsigned long long wst_ino_t; +typedef long long wst_off_t; +typedef unsigned long long wst_dev_t; +#elif defined(LISP_FEATURE_LARGEFILE) || defined(LISP_FEATURE_DARWIN) +typedef ino_t wst_ino_t; typedef aliased_dev_t wst_dev_t; typedef off_t wst_off_t; #else /* These wrappers shouldn't exist, and since pulling in runtime.h caused * problems on Win32, we don't use the u32 typedef. */ +typedef ino_t wst_ino_t; typedef unsigned int wst_dev_t; /* since Linux dev_t can be 64 bits */ typedef unsigned int wst_off_t; /* since OpenBSD 2.8 st_size is 64 bits */ #endif @@ -55,6 +61,9 @@ typedef unsigned int wst_off_t; /* since OpenBSD 2.8 st_size is 64 bits */ #ifdef LISP_FEATURE_OS_PROVIDES_BLKSIZE_T typedef blksize_t wst_blksize_t; typedef blkcnt_t wst_blkcnt_t; +#elif defined(LISP_FEATURE_ANDROID) +typedef unsigned long wst_blksize_t; +typedef unsigned long long wst_blkcnt_t; #else typedef unsigned long wst_blksize_t; typedef unsigned long wst_blkcnt_t; @@ -83,7 +92,7 @@ struct stat_wrapper { * another entry for Dan Barlow's ongoing episodic rant about C * header files, I guess.. -- WHN 2001-05-10 */ wst_dev_t wrapped_st_dev; /* device */ - ino_t wrapped_st_ino; /* inode */ + wst_ino_t wrapped_st_ino; /* inode */ mode_t wrapped_st_mode; /* protection */ wst_nlink_t wrapped_st_nlink; /* number of hard links */ wst_uid_t wrapped_st_uid; /* user ID of owner */ diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 1994b55..7801ba8 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -355,6 +355,7 @@ main(int argc, char *argv[]) DEFTYPE("uid-t", uid_t); printf(";; Types in src/runtime/wrap.h. See that file for explantion.\n"); printf(";; Don't use these types for anything other than the stat wrapper.\n"); + DEFTYPE("wst-ino-t", wst_ino_t); DEFTYPE("wst-dev-t", wst_dev_t); DEFTYPE("wst-off-t", wst_off_t); DEFTYPE("wst-blksize-t", wst_blksize_t); ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 06:26:20
|
The branch "master" has been updated in SBCL: via e55432f31f7ca3e342b4fd94dcb632ce77b1ba93 (commit) from 27776258ca3bb29f24346d068d78967842d9f595 (commit) - Log ----------------------------------------------------------------- commit e55432f31f7ca3e342b4fd94dcb632ce77b1ba93 Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 10:25:29 2014 +0400 Revert "Implement sb-posix:stat using wrappers." It doesn't fix all the Android problems, just pushes them away. --- contrib/sb-posix/constants.lisp | 22 +++++++++++ contrib/sb-posix/interface.lisp | 76 +++++++++++++++++++++----------------- src/runtime/largefile.c | 16 ++++++++ 3 files changed, 80 insertions(+), 34 deletions(-) diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 06afb02..11538da 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -307,6 +307,28 @@ (c-string-pointer passwd "char *" "gr_passwd") (gid-t gid "gid_t" "gr_gid"))) + (:structure alien-stat + ("struct stat" + (mode-t mode "mode_t" "st_mode") + (ino-t ino "ino_t" "st_ino") + ;; Linux/MIPS uses unsigned long instead of dev_t here. + #-mips + (dev-t dev "dev_t" "st_dev") + #+mips + ((unsigned 32) dev "dev_t" "st_dev") + (nlink-t nlink "nlink_t" "st_nlink") + (uid-t uid "uid_t" "st_uid") + ;; Linux/MIPS uses unsigned long instead of dev_t here. + #-mips + (dev-t rdev "dev_t" "st_rdev") + #+mips + ((unsigned 32) rdev "dev_t" "st_rdev") + (gid-t gid "gid_t" "st_gid") + (off-t size "off_t" "st_size") + (time-t atime "time_t" "st_atime") + (time-t mtime "time_t" "st_mtime") + (time-t ctime "time_t" "st_ctime"))) + #+darwin (:structure alien-timespec ("struct timespec" diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 7a312f7..d2b6154 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -547,63 +547,71 @@ not supported." :documentation "Microseconds.")) (:documentation "Instances of this class represent time values.")) -(define-protocol-class stat (struct sb-unix::wrapped_stat) () - ((sb-unix::st-mode :initarg :mode :reader stat-mode +(define-protocol-class stat alien-stat () + ((mode :initarg :mode :reader stat-mode :documentation "Mode of file.") - (sb-unix::st-ino :initarg :ino :reader stat-ino + (ino :initarg :ino :reader stat-ino :documentation "File serial number.") - (sb-unix::st-dev :initarg :dev :reader stat-dev + (dev :initarg :dev :reader stat-dev :documentation "Device ID of device containing file.") - (sb-unix::st-nlink :initarg :nlink :reader stat-nlink + (nlink :initarg :nlink :reader stat-nlink :documentation "Number of hard links to the file.") - (sb-unix::st-uid :initarg :uid :reader stat-uid + (uid :initarg :uid :reader stat-uid :documentation "User ID of file.") - (sb-unix::st-gid :initarg :gid :reader stat-gid + (gid :initarg :gid :reader stat-gid :documentation "Group ID of file.") - (sb-unix::st-size :initarg :size :reader stat-size + (size :initarg :size :reader stat-size :documentation "For regular files, the file size in bytes. For symbolic links, the length in bytes of the filename contained in the symbolic link.") - (sb-unix::st-rdev :initarg :rdev :reader stat-rdev + (rdev :initarg :rdev :reader stat-rdev :documentation "For devices the device number.") - (sb-unix::st-atime :initarg :atime :reader stat-atime + (atime :initarg :atime :reader stat-atime :documentation "Time of last access.") - (sb-unix::st-mtime :initarg :mtime :reader stat-mtime + (mtime :initarg :mtime :reader stat-mtime :documentation "Time of last data modification.") - (sb-unix::st-ctime :initarg :ctime :reader stat-ctime + (ctime :initarg :ctime :reader stat-ctime :documentation "Time of last status change.")) (:documentation "Instances of this class represent POSIX file metadata.")) -(defmacro define-stat-call (lisp-name c-name arg designator-fun type) +(defmacro define-stat-call (name arg designator-fun type) ;; FIXME: this isn't the documented way of doing this, surely? - `(progn - (export ',lisp-name :sb-posix) - (declaim (inline ,lisp-name)) - (defun ,lisp-name (,arg &optional stat) - (declare (type (or null stat) stat)) - (with-alien ((a-stat (struct sb-unix::wrapped_stat))) - (let ((r (alien-funcall - (extern-alien ,(real-c-name c-name) ,type) - (,designator-fun ,arg) - (addr a-stat)))) - (when (minusp r) - (syscall-error ',lisp-name)) - (alien-to-stat (addr a-stat) stat)))))) + (let ((lisp-name (lisp-for-c-symbol name)) + (real-name #+inode64 (format nil "~A$INODE64" name) + #-inode64 name)) + `(progn + (export ',lisp-name :sb-posix) + (declaim (inline ,lisp-name)) + (defun ,lisp-name (,arg &optional stat) + (declare (type (or null stat) stat)) + (with-alien-stat a-stat () + (let ((r (alien-funcall + (extern-alien ,(real-c-name (list real-name :options :largefile)) ,type) + (,designator-fun ,arg) + a-stat))) + (when (minusp r) + (syscall-error ',lisp-name)) + (alien-to-stat a-stat stat))))))) -(define-stat-call stat "stat_wrapper" +(define-stat-call #-win32 "stat" #+win32 "_stat" pathname filename - (function int (c-string :not-null t) (* (struct sb-unix::wrapped_stat)))) + (function int (c-string :not-null t) (* alien-stat))) - -(define-stat-call lstat "lstat_wrapper" +#-win32 +(define-stat-call "lstat" pathname filename - (function int (c-string :not-null t) (* (struct sb-unix::wrapped_stat)))) - + (function int (c-string :not-null t) (* alien-stat))) +;;; No symbolic links on Windows, so use stat +#+win32 +(progn + (declaim (inline lstat)) + (export (defun lstat (filename &optional stat) + (if stat (stat filename stat) (stat filename))))) -(define-stat-call fstat "fstat_wrapper" +(define-stat-call #-win32 "fstat" #+win32 "_fstat" fd file-descriptor - (function int int (* (struct sb-unix::wrapped_stat)))) + (function int int (* alien-stat))) ;;; mode flags diff --git a/src/runtime/largefile.c b/src/runtime/largefile.c index 4b5df46..b71a77f 100644 --- a/src/runtime/largefile.c +++ b/src/runtime/largefile.c @@ -24,6 +24,7 @@ #include <sys/types.h> #include <dirent.h> #include <unistd.h> +#include <sys/stat.h> off_t lseek_largefile(int fildes, off_t offset, int whence) { @@ -45,6 +46,21 @@ mmap_largefile(void *start, size_t length, int prot, int flags, int fd, off_t of return mmap(start, length, prot, flags, fd, offset); } +int +stat_largefile(const char *file_name, struct stat *buf) { + return stat(file_name, buf); +} + +int +fstat_largefile(int filedes, struct stat *buf) { + return fstat(filedes, buf); +} + +int +lstat_largefile(const char *file_name, struct stat *buf) { + return lstat(file_name, buf); +} + struct dirent64 * readdir_largefile(DIR *dir) { return readdir64(dir); ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 04:05:41
|
The branch "master" has been updated in SBCL: via 27776258ca3bb29f24346d068d78967842d9f595 (commit) from 34eab1610a5756ebf383303eccadaf829d04f92b (commit) - Log ----------------------------------------------------------------- commit 27776258ca3bb29f24346d068d78967842d9f595 Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 08:04:50 2014 +0400 Implement sb-posix:stat using wrappers. It's not easy to determine the layout of struct stat, and it fails to do so on Android, sb-unix:stat is implemented with a wrapper which parses everything on the C side. Just reuse that wrapper for sb-posix:stat. --- contrib/sb-posix/constants.lisp | 22 ----------- contrib/sb-posix/interface.lisp | 76 +++++++++++++++++--------------------- src/runtime/largefile.c | 16 -------- 3 files changed, 34 insertions(+), 80 deletions(-) diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 11538da..06afb02 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -307,28 +307,6 @@ (c-string-pointer passwd "char *" "gr_passwd") (gid-t gid "gid_t" "gr_gid"))) - (:structure alien-stat - ("struct stat" - (mode-t mode "mode_t" "st_mode") - (ino-t ino "ino_t" "st_ino") - ;; Linux/MIPS uses unsigned long instead of dev_t here. - #-mips - (dev-t dev "dev_t" "st_dev") - #+mips - ((unsigned 32) dev "dev_t" "st_dev") - (nlink-t nlink "nlink_t" "st_nlink") - (uid-t uid "uid_t" "st_uid") - ;; Linux/MIPS uses unsigned long instead of dev_t here. - #-mips - (dev-t rdev "dev_t" "st_rdev") - #+mips - ((unsigned 32) rdev "dev_t" "st_rdev") - (gid-t gid "gid_t" "st_gid") - (off-t size "off_t" "st_size") - (time-t atime "time_t" "st_atime") - (time-t mtime "time_t" "st_mtime") - (time-t ctime "time_t" "st_ctime"))) - #+darwin (:structure alien-timespec ("struct timespec" diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index d2b6154..7a312f7 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -547,71 +547,63 @@ not supported." :documentation "Microseconds.")) (:documentation "Instances of this class represent time values.")) -(define-protocol-class stat alien-stat () - ((mode :initarg :mode :reader stat-mode +(define-protocol-class stat (struct sb-unix::wrapped_stat) () + ((sb-unix::st-mode :initarg :mode :reader stat-mode :documentation "Mode of file.") - (ino :initarg :ino :reader stat-ino + (sb-unix::st-ino :initarg :ino :reader stat-ino :documentation "File serial number.") - (dev :initarg :dev :reader stat-dev + (sb-unix::st-dev :initarg :dev :reader stat-dev :documentation "Device ID of device containing file.") - (nlink :initarg :nlink :reader stat-nlink + (sb-unix::st-nlink :initarg :nlink :reader stat-nlink :documentation "Number of hard links to the file.") - (uid :initarg :uid :reader stat-uid + (sb-unix::st-uid :initarg :uid :reader stat-uid :documentation "User ID of file.") - (gid :initarg :gid :reader stat-gid + (sb-unix::st-gid :initarg :gid :reader stat-gid :documentation "Group ID of file.") - (size :initarg :size :reader stat-size + (sb-unix::st-size :initarg :size :reader stat-size :documentation "For regular files, the file size in bytes. For symbolic links, the length in bytes of the filename contained in the symbolic link.") - (rdev :initarg :rdev :reader stat-rdev + (sb-unix::st-rdev :initarg :rdev :reader stat-rdev :documentation "For devices the device number.") - (atime :initarg :atime :reader stat-atime + (sb-unix::st-atime :initarg :atime :reader stat-atime :documentation "Time of last access.") - (mtime :initarg :mtime :reader stat-mtime + (sb-unix::st-mtime :initarg :mtime :reader stat-mtime :documentation "Time of last data modification.") - (ctime :initarg :ctime :reader stat-ctime + (sb-unix::st-ctime :initarg :ctime :reader stat-ctime :documentation "Time of last status change.")) (:documentation "Instances of this class represent POSIX file metadata.")) -(defmacro define-stat-call (name arg designator-fun type) +(defmacro define-stat-call (lisp-name c-name arg designator-fun type) ;; FIXME: this isn't the documented way of doing this, surely? - (let ((lisp-name (lisp-for-c-symbol name)) - (real-name #+inode64 (format nil "~A$INODE64" name) - #-inode64 name)) - `(progn - (export ',lisp-name :sb-posix) - (declaim (inline ,lisp-name)) - (defun ,lisp-name (,arg &optional stat) - (declare (type (or null stat) stat)) - (with-alien-stat a-stat () - (let ((r (alien-funcall - (extern-alien ,(real-c-name (list real-name :options :largefile)) ,type) - (,designator-fun ,arg) - a-stat))) - (when (minusp r) - (syscall-error ',lisp-name)) - (alien-to-stat a-stat stat))))))) + `(progn + (export ',lisp-name :sb-posix) + (declaim (inline ,lisp-name)) + (defun ,lisp-name (,arg &optional stat) + (declare (type (or null stat) stat)) + (with-alien ((a-stat (struct sb-unix::wrapped_stat))) + (let ((r (alien-funcall + (extern-alien ,(real-c-name c-name) ,type) + (,designator-fun ,arg) + (addr a-stat)))) + (when (minusp r) + (syscall-error ',lisp-name)) + (alien-to-stat (addr a-stat) stat)))))) -(define-stat-call #-win32 "stat" #+win32 "_stat" +(define-stat-call stat "stat_wrapper" pathname filename - (function int (c-string :not-null t) (* alien-stat))) + (function int (c-string :not-null t) (* (struct sb-unix::wrapped_stat)))) -#-win32 -(define-stat-call "lstat" + +(define-stat-call lstat "lstat_wrapper" pathname filename - (function int (c-string :not-null t) (* alien-stat))) -;;; No symbolic links on Windows, so use stat -#+win32 -(progn - (declaim (inline lstat)) - (export (defun lstat (filename &optional stat) - (if stat (stat filename stat) (stat filename))))) + (function int (c-string :not-null t) (* (struct sb-unix::wrapped_stat)))) + -(define-stat-call #-win32 "fstat" #+win32 "_fstat" +(define-stat-call fstat "fstat_wrapper" fd file-descriptor - (function int int (* alien-stat))) + (function int int (* (struct sb-unix::wrapped_stat)))) ;;; mode flags diff --git a/src/runtime/largefile.c b/src/runtime/largefile.c index b71a77f..4b5df46 100644 --- a/src/runtime/largefile.c +++ b/src/runtime/largefile.c @@ -24,7 +24,6 @@ #include <sys/types.h> #include <dirent.h> #include <unistd.h> -#include <sys/stat.h> off_t lseek_largefile(int fildes, off_t offset, int whence) { @@ -46,21 +45,6 @@ mmap_largefile(void *start, size_t length, int prot, int flags, int fd, off_t of return mmap(start, length, prot, flags, fd, offset); } -int -stat_largefile(const char *file_name, struct stat *buf) { - return stat(file_name, buf); -} - -int -fstat_largefile(int filedes, struct stat *buf) { - return fstat(filedes, buf); -} - -int -lstat_largefile(const char *file_name, struct stat *buf) { - return lstat(file_name, buf); -} - struct dirent64 * readdir_largefile(DIR *dir) { return readdir64(dir); ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 04:05:39
|
The branch "master" has been updated in SBCL: via 34eab1610a5756ebf383303eccadaf829d04f92b (commit) from 5f3cc30cc34d509ab784d20ebec3c00836053028 (commit) - Log ----------------------------------------------------------------- commit 34eab1610a5756ebf383303eccadaf829d04f92b Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 08:01:19 2014 +0400 Make sb-bsd-socket work on common protocols without getprotobyname. Android doesn't have a working getprotobyname, but even for other platforms iterating over a small number of predefined protocols is much faster, and some default installations do not come bundled with /etc/protocols. --- contrib/sb-bsd-sockets/constants.lisp | 10 ++++++++- contrib/sb-bsd-sockets/inet.lisp | 29 +++++++++++++++++++++++--- contrib/sb-bsd-sockets/sockets.lisp | 2 +- contrib/sb-bsd-sockets/win32-constants.lisp | 9 ++++++- contrib/sb-grovel/def-to-lisp.lisp | 2 + 5 files changed, 44 insertions(+), 8 deletions(-) diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index de0e2e8..636fc21 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -351,4 +351,12 @@ (optname int) (optval (* t)) (optlen (* int)))) ;;; should be socklen-t! - ) + ;; Protocols + ;; Android have those as enums, foiling #ifdef checks + (#-android :integer #+android :integer-no-check IPPROTO_IP "IPPROTO_IP") + (#-android :integer #+android :integer-no-check IPPROTO_IPV6 "IPPROTO_IPV6") + (#-android :integer #+android :integer-no-check IPPROTO_ICMP "IPPROTO_ICMP") + (#-android :integer #+android :integer-no-check IPPROTO_IGMP "IPPROTO_IGMP") + (#-android :integer #+android :integer-no-check IPPROTO_TCP "IPPROTO_TCP") + (#-android :integer #+android :integer-no-check IPPROTO_UDP "IPPROTO_UDP") + (#-android :integer #+android :integer-no-check IPPROTO_RAW "IPPROTO_RAW")) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 42f207e..978218e 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -63,14 +63,35 @@ Examples: (:report (lambda (c s) (format s "Protocol not found: ~a" (prin1-to-string (unknown-protocol-name c)))))) +(defvar *protocols* + `((:tcp ,sockint::ipproto_tcp "tcp" "TCP") + (:udp ,sockint::ipproto_udp "udp" "UDP") + (:ip ,sockint::ipproto_ip "ip" "IP") + (:ipv6 ,sockint::ipproto_ipv6 "ipv6" "IPV6") + (:icmp ,sockint::ipproto_icmp "icmp" "ICMP") + (:igmp ,sockint::ipproto_igmp "igmp" "IGMP") + (:raw ,sockint::ipproto_raw "raw" "RAW"))) -#+(and sb-thread (not os-provides-getprotoby-r)) +;;; Try to get to a protocol quickly, falling back to calling +;;; getprotobyname if it's available. +(defun get-protocol-by-name (name) + (let ((result (cdr (if (keywordp name) + (assoc name *protocols*) + (assoc name *protocols* :test #'string-equal))))) + (if result + (values (first result) (second result) (third result)) + #-android + (getprotobyname (string-downcase name)) + #+android (error 'unknown-protocol :name name)))) + +#+(and sb-thread (not os-provides-getprotoby-r) (not android)) ;; Since getprotobyname is not thread-safe, we need a lock. (sb-ext:defglobal **getprotoby-lock** (sb-thread:make-mutex :name "getprotoby lock")) ;;; getprotobyname only works in the internet domain, which is why this ;;; is here -(defun get-protocol-by-name (name) ;exported +#-android +(defun getprotobyname (name) "Given a protocol name, return the protocol number, the protocol name, and a list of protocol aliases" @@ -116,7 +137,7 @@ a list of protocol aliases" #-solaris (when (sb-alien::null-alien (sb-alien:deref result 0)) (error 'unknown-protocol :name name)) - (return-from get-protocol-by-name + (return-from getprotobyname (protoent-to-values result-buf))) (t (let ((errno (sb-unix::get-errno))) @@ -139,7 +160,7 @@ a list of protocol aliases" (let ((ent (sockint::getprotobyname name))) (if (sb-alien::null-alien ent) (go :error) - (return-from get-protocol-by-name (protoent-to-values ent)))))) + (return-from getprotobyname (protoent-to-values ent)))))) #+sb-thread (sb-thread::with-system-mutex (**getprotoby-lock**) (get-it)) diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index ed863ae..790fbe4 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -54,7 +54,7 @@ directly instantiated."))) &allow-other-keys) (let* ((proto-num (cond ((and protocol (keywordp protocol)) - (get-protocol-by-name (string-downcase (symbol-name protocol)))) + (get-protocol-by-name protocol)) (protocol protocol) (t 0))) (fd (or (and (slot-boundp socket 'file-descriptor) diff --git a/contrib/sb-bsd-sockets/win32-constants.lisp b/contrib/sb-bsd-sockets/win32-constants.lisp index 5b4ed07..fd11891 100644 --- a/contrib/sb-bsd-sockets/win32-constants.lisp +++ b/contrib/sb-bsd-sockets/win32-constants.lisp @@ -247,5 +247,10 @@ (lpWSAData wsa-data :out))) (:function wsa-get-last-error ("WSAGetLastError" int)) - -) \ No newline at end of file + (:integer IPPROTO_IP "IPPROTO_IP") + (:integer IPPROTO_IPV6 "IPPROTO_IPV6") + (:integer IPPROTO_ICMP "IPPROTO_ICMP") + (:integer IPPROTO_IGMP "IPPROTO_IGMP") + (:integer IPPROTO_TCP "IPPROTO_TCP") + (:integer IPPROTO_UDP "IPPROTO_UDP") + (:integer IPPROTO_RAW "IPPROTO_RAW")) diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 7df3fff..2a5d9c3 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -122,6 +122,8 @@ code: (as-c "#else") (printf "(sb-int:style-warn \"Couldn't grovel for ~~A (unknown to the C compiler).\" \"~A\")" cname) (as-c "#endif")) + ((:integer-no-check) + (printf "(cl:defconstant ~A %d \"~A\")" lispname doc cname)) (:enum (c-for-enum lispname cname export)) (:type ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 00:24:18
|
The branch "master" has been updated in SBCL: via 5f3cc30cc34d509ab784d20ebec3c00836053028 (commit) from 7f27f59fe25b9956cd83312c33302794a0749446 (commit) - Log ----------------------------------------------------------------- commit 5f3cc30cc34d509ab784d20ebec3c00836053028 Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 04:23:50 2014 +0400 sb-posix: disable pwd.h and grp.h functions. Even though they are accessible, the structs have different layouts and it does not make much sense on Android. --- contrib/sb-posix/constants.lisp | 8 ++++---- contrib/sb-posix/interface.lisp | 6 +++--- contrib/sb-posix/posix-tests.lisp | 12 ++++++------ 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 789cb91..11538da 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -20,8 +20,8 @@ #-win32 "netdb.h" "errno.h" "dirent.h" "signal.h" - #-win32 "pwd.h" - #-win32 "grp.h" + #-(or win32 android) "pwd.h" + #-(or win32 android) "grp.h" "unistd.h" #-win32 "termios.h" #-win32 "syslog.h") @@ -278,7 +278,7 @@ :distrust-length nil)) t) ;; password database - #-win32 + #-(or android win32) (:structure alien-passwd ("struct passwd" (c-string-pointer name "char *" "pw_name") @@ -300,7 +300,7 @@ (:integer fields "int" "pw_fields"))) ;; group database - #-win32 + #-(or android win32) (:structure alien-group ("struct group" (c-string-pointer name "char *" "gr_name") diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 8e6be50..d2b6154 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -488,7 +488,7 @@ not supported." ;;; passwd database ;; The docstrings are copied from the descriptions in SUSv3, ;; where present. -#-win32 +#-(or android win32) (define-protocol-class passwd alien-passwd () ((name :initarg :name :accessor passwd-name :documentation "User's login name.") @@ -510,14 +510,14 @@ not supported." "Instances of this class represent entries in the system's user database.")) ;;; group database -#-win32 +#-(or android win32) (define-protocol-class group alien-group () ((name :initarg :name :accessor group-name) (passwd :initarg :passwd :accessor group-passwd) (gid :initarg :gid :accessor group-gid))) (defmacro define-obj-call (name arg type conv) - #-win32 + #-(or win32 android) ;; FIXME: this isn't the documented way of doing this, surely? (let ((lisp-name (intern (string-upcase name) :sb-posix))) `(progn diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index c73f2d1..27edee7 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -586,19 +586,19 @@ (values retval (read-line inf))))) 3 "foo") -#-win32 +#-(or android win32) (deftest pwent.1 ;; make sure that we found something (not (sb-posix:getpwuid 0)) nil) -#-win32 +#-(or android win32) (deftest pwent.2 ;; make sure that we found something (not (sb-posix:getpwnam "root")) nil) -#-win32 +#-(or android win32) (deftest pwent.non-existing ;; make sure that we get something sensible, not an error (handler-case (progn (sb-posix:getpwnam "almost-certainly-does-not-exist") @@ -606,19 +606,19 @@ (t (cond) t)) nil) -#-win32 +#-(or android win32) (deftest grent.1 ;; make sure that we found something (not (sb-posix:getgrgid 0)) nil) -#-win32 +#-(or android win32) (deftest grent.2 ;; make sure that we found something (not (sb-posix:getgrnam "sys")) nil) -#-win32 +#-(or android win32) (deftest grent.non-existing ;; make sure that we get something sensible, not an error (handler-case (progn (sb-posix:getgrnam "almost-certainly-does-not-exist") ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-01 00:24:16
|
The branch "master" has been updated in SBCL: via 7f27f59fe25b9956cd83312c33302794a0749446 (commit) from b702d06e168d8eee7e9014ffe2ef7b86f417a85e (commit) - Log ----------------------------------------------------------------- commit 7f27f59fe25b9956cd83312c33302794a0749446 Author: Stas Boukarev <sta...@gm...> Date: Sun Jun 1 04:19:37 2014 +0400 Load libc.so on Android. Without many networking functions do not become available for some reason. --- src/code/foreign-load.lisp | 2 ++ 1 files changed, 2 insertions(+), 0 deletions(-) diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 5752f32..7778653 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -154,6 +154,8 @@ Experimental." (defun reopen-shared-objects () ;; Ensure that the runtime is open (setf *runtime-dlhandle* (dlopen-or-lose)) + ;; Without this many symbols aren't accessible. + #!+android (load-shared-object "libc.so" :dont-save t) ;; Reopen stuff. (setf *shared-objects* (remove nil (mapcar #'try-reopen-shared-object *shared-objects*)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-05-31 23:08:14
|
The branch "master" has been updated in SBCL: via b702d06e168d8eee7e9014ffe2ef7b86f417a85e (commit) from e3d51d3a626e14b2f241f765b2d3f4bba883f869 (commit) - Log ----------------------------------------------------------------- commit b702d06e168d8eee7e9014ffe2ef7b86f417a85e Author: Douglas Katzman <do...@go...> Date: Sat May 31 18:16:32 2014 -0400 Trivial reader cleanup --- src/code/reader.lisp | 13 +------------ 1 files changed, 1 insertions(+), 12 deletions(-) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 6ea3e9e..e89d459 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1378,17 +1378,6 @@ extended <package-name>::<form-in-package> syntax." ;;;; number-reading functions -(defmacro digit* nil - `(do ((ch char (inch-read-buffer))) - ((or (eofp ch) (not (digit-char-p ch))) (setq char ch)) - ;; Report if at least one digit is seen. - (setq one-digit t))) - -;; FIXME: should just check for something like -;; (and (typep letter 'base-char) (... +char-attr-constituent-expt+)) -(defmacro exponent-letterp (letter) - `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d))) - ;;; FIXME: It would be cleaner to have these generated automatically ;;; by compile-time code instead of having them hand-created like ;;; this. The !COLD-INIT-INTEGER-READER code below should be resurrected @@ -1512,7 +1501,7 @@ extended <package-name>::<form-in-package> syntax." *read-default-float-format* stream))) (return-from make-float (if negative-fraction (- num) num)))) - ((exponent-letterp char) + ((= (get-constituent-trait char) +char-attr-constituent-expt+) (setq float-char char) ;; Build exponent. (setq char (inch-read-buffer)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Nikodemus S. <de...@us...> - 2014-05-31 18:22:33
|
The branch "master" has been updated in SBCL: via e3d51d3a626e14b2f241f765b2d3f4bba883f869 (commit) from 9595dc575aaf32f409ff67d101db90216ffeba66 (commit) - Log ----------------------------------------------------------------- commit e3d51d3a626e14b2f241f765b2d3f4bba883f869 Author: Nikodemus Siivola <nik...@ra...> Date: Sat May 31 21:20:13 2014 +0300 update .mailmap so 'git shortlog' is prettier --- .mailmap | 30 +++++++++++++++++++++++------- 1 files changed, 23 insertions(+), 7 deletions(-) diff --git a/.mailmap b/.mailmap index 39c7d1d..158c02b 100644 --- a/.mailmap +++ b/.mailmap @@ -1,16 +1,29 @@ -Alastair Bridgewater <lis...@us...> lisphacker <lisphacker> -<lis...@us...> <ny...@ar...> -<lis...@us...> <ny...@ka...> -<lis...@us...> <ny...@vi...> -<lis...@us...> <nye...@li...> +Alastair Bridgewater <ala...@gm...> +Alastair Bridgewater <ala...@gm...> <lisphacker> +Alastair Bridgewater <ala...@gm...> <lis...@us...> +Alastair Bridgewater <ala...@gm...> <ny...@ar...> +Alastair Bridgewater <ala...@gm...> <ny...@ka...> +Alastair Bridgewater <ala...@gm...> <ny...@la...> +Alastair Bridgewater <ala...@gm...> <ny...@li...> +Alastair Bridgewater <ala...@gm...> <ny...@vi...> +Alastair Bridgewater <ala...@gm...> <nye...@li...> +Alastair Bridgewater <ala...@gm...> nyef <ny...@su...> +Alastair Bridgewater <ala...@gm...> root <ro...@ne...> Christophe Rhodes <cs...@ca...> <cs...@ca...> +<cs...@ca...> <c.r...@go...> Cyrus Harmon <ch...@bo...> <ch-...@bo...> +<ch...@bo...> <ch...@bo...> -Jim Wise <ji...@us...> <jw...@dr...> +David Lichteblau <da...@li...> <da...@kn...> + +Francois-Rene Rideau <tu...@go...> <fa...@tu...> + +Jim Wise <ji...@us...> +Jim Wise <ji...@us...> <jimwise> +<ji...@us...> <jw...@dr...> <ji...@us...> <jw...@me...> -<ji...@us...> jimwise <jimwise> Martin Cracauer <cra...@go...> cracauer <cracauer> @@ -22,10 +35,13 @@ NIIMI Satoshi <sa...@us...> sa2c <sa2c> Paul Khuong <pv...@pv...> pkhuong <pkhuong> +Philipp Matthias Schäfer <phi...@gm...> Philipp Matthias Schaefer <phi...@gm...> + Richard M Kreuter <kr...@us...> kreuter <kreuter> Robert Brown <br...@go...> <rob...@gm...> Stas Boukarev <sta...@us...> <sta...@gm...> +Stas Boukarev <sta...@us...> stas <st...@de...7> Tobias C. Rittweiler <tri...@us...> trittweiler <trittweiler> ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Nikodemus S. <de...@us...> - 2014-05-31 17:53:55
|
The branch "master" has been updated in SBCL: via 9595dc575aaf32f409ff67d101db90216ffeba66 (commit) from 7166b6985991e6246b42c9757dca1c137f277071 (commit) - Log ----------------------------------------------------------------- commit 9595dc575aaf32f409ff67d101db90216ffeba66 Author: Nikodemus Siivola <nik...@ra...> Date: Sat May 31 18:10:00 2014 +0300 include function name in errors about invalid local calls They call won't appear in the backtrace, so it really needs to be in the error message to avoid confusion -- prior to this the information about which function was the responsible one was hidden in the compilation log. --- NEWS | 1 + src/code/interr.lisp | 12 ++++++++---- src/compiler/alpha/call.lisp | 2 +- src/compiler/arm/call.lisp | 2 +- src/compiler/fndb.lisp | 2 +- src/compiler/hppa/call.lisp | 2 +- src/compiler/ir1util.lisp | 3 +++ src/compiler/locall.lisp | 13 +++++++------ src/compiler/mips/call.lisp | 2 +- src/compiler/ppc/call.lisp | 2 +- src/compiler/sparc/call.lisp | 2 +- src/compiler/x86-64/call.lisp | 2 +- src/compiler/x86/call.lisp | 2 +- tests/compiler.pure.lisp | 8 ++++++++ 14 files changed, 36 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 2f1871d..c10ce84 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.2.0: * enhancement: GENCGC is enabled on ARM. + * enhancement: better error reporting for invalid calls to local functions. * bug fix: TYPE-OF must not return AND/OR/NOT expressions. (lp#1317308) * bug fix: accessing NIL arrays stopped producing errors. (lp#1311421) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index f2dd34c..f1cdc49 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -47,10 +47,14 @@ (defun undefined-alien-fun-error () (error 'undefined-alien-function-error)) -(deferr invalid-arg-count-error (nargs) - (error 'simple-program-error - :format-control "invalid number of arguments: ~S" - :format-arguments (list nargs))) +(deferr invalid-arg-count-error (nargs &optional (fname nil fnamep)) + (if fnamep + (error 'simple-program-error + :format-control "~S called with invalid number of arguments: ~S" + :format-arguments (list fname nargs)) + (error 'simple-program-error + :format-control "invalid number of arguments: ~S" + :format-arguments (list nargs)))) (deferr bogus-arg-to-values-list-error (list) (error 'simple-type-error diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 0172f66..7143f19 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -1250,7 +1250,7 @@ default-value-8 (:generator 1000 (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/arm/call.lisp b/src/compiler/arm/call.lisp index f0cc8c1..239e33d 100644 --- a/src/compiler/arm/call.lisp +++ b/src/compiler/arm/call.lisp @@ -607,7 +607,7 @@ (:generator 1000 (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index a296280..4d6db64 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1519,7 +1519,7 @@ (defknown %more-kw-arg (t fixnum) (values t t)) (defknown %more-arg-values (t index index) * (flushable)) (defknown %verify-arg-count (index index) (values)) -(defknown %arg-count-error (t) nil) +(defknown %arg-count-error (t t) nil) (defknown %unknown-values () *) (defknown %catch (t t) t) (defknown %unwind-protect (t t) t) diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp index be8e880..cfaedde 100644 --- a/src/compiler/hppa/call.lisp +++ b/src/compiler/hppa/call.lisp @@ -1259,7 +1259,7 @@ default-value-8 (:generator 1000 (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 7d9f2f3..b9b3ec7 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -2099,6 +2099,9 @@ is :ANY, the function name is not checked." (values (leaf-source-name leaf) t) (values nil nil)))) +(defun combination-fun-debug-name (combination) + (leaf-debug-name (ref-leaf (lvar-uses (combination-fun combination))))) + ;;; Return the COMBINATION node that is the call to the LET FUN. (defun let-combination (fun) (declare (type clambda fun)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d7b3a63..5287678 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -190,7 +190,7 @@ (%more-arg-context ,n-supplied ,max) (%funcall ,more ,@temps ,n-context ,n-count)))))) (t - (%arg-count-error ,n-supplied))))))))) + (%arg-count-error ,n-supplied ',(leaf-debug-name fun)))))))))) ;;; Make an external entry point (XEP) for FUN and return it. We ;;; convert the result of MAKE-XEP-LAMBDA in the correct environment, @@ -502,11 +502,12 @@ (aver (combination-p node)) (aver (typep count 'unsigned-byte)) (apply 'warn warn-arguments) - (transform-call-with-ir1-environment node - `(lambda (&rest args) - (declare (ignore args)) - (%arg-count-error ,count)) - '%arg-count-error)) + (transform-call-with-ir1-environment + node + `(lambda (&rest args) + (declare (ignore args)) + (%arg-count-error ,count ',(combination-fun-debug-name node))) + '%arg-count-error)) ;;; Attempt to convert a call to a lambda. If the number of args is ;;; wrong, we give a warning and mark the call as :ERROR to remove it diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp index 0a42bdc..0918fc3 100644 --- a/src/compiler/mips/call.lisp +++ b/src/compiler/mips/call.lisp @@ -1291,7 +1291,7 @@ default-value-8 (:generator 1000 (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index 825784f..1e0b5c5 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -1247,7 +1247,7 @@ default-value-8 (:generator 1000 (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp index d47d1e7..23de71d 100644 --- a/src/compiler/sparc/call.lisp +++ b/src/compiler/sparc/call.lisp @@ -1235,7 +1235,7 @@ default-value-8 (:generator 1000 (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index 2d7c117..791596a 100644 --- a/src/compiler/x86-64/call.lisp +++ b/src/compiler/x86-64/call.lisp @@ -1386,7 +1386,7 @@ (:generator 1000 (error-call vop ',error ,@args))))) (def arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (def type-check-error object-not-type-error sb!c::%type-check-error object type) (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 95aaf4c..3d57363 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1476,7 +1476,7 @@ (:generator 1000 (error-call vop ',error ,@args))))) (def arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (def type-check-error object-not-type-error sb!c::%type-check-error object type) (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index cb38871..f3fe5fe 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -5136,3 +5136,11 @@ (assert (< (approx-lines-of-assembly-code '(or system-area-pointer (sb-kernel:simple-unboxed-array (*)))) 27)))) + +(with-test (:name :local-argument-mismatch-error-string) + (let ((f (compile nil `(lambda (x) + (flet ((foo ())) + (foo x)))))) + (multiple-value-bind (ok err) (ignore-errors (funcall f 42)) + (assert (not ok)) + (assert (search "FLET FOO" (princ-to-string err)))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Nikodemus S. <de...@us...> - 2014-05-31 17:53:53
|
The branch "master" has been updated in SBCL: via 7166b6985991e6246b42c9757dca1c137f277071 (commit) from 30c17523727cf55ca3b163db5a4c200c1e8451ee (commit) - Log ----------------------------------------------------------------- commit 7166b6985991e6246b42c9757dca1c137f277071 Author: Nikodemus Siivola <nik...@ra...> Date: Sat May 31 19:57:17 2014 +0300 allow using optional arguments in DEFERR handlers Unused for now, use coming in next. --- src/code/interr.lisp | 14 ++++++++++++-- 1 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 81a9e41..f2dd34c 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -197,6 +197,17 @@ nil)))) +;;; Returns true if number of arguments matches required/optional +;;; arguments handler expects. +(defun internal-error-args-ok (arguments handler) + (multiple-value-bind (req opt) + (parse-lambda-list (%simple-fun-arglist handler) :silent t) + ;; The handler always gets name as the first (extra) argument. + (let ((n (1+ (length arguments))) + (n-req (length req)) + (n-opt (length opt))) + (and (>= n n-req) (<= n (+ n-req n-opt)))))) + ;;;; INTERNAL-ERROR signal handler (defun internal-error (context continuable) @@ -242,8 +253,7 @@ (handler (and (< -1 error-number (length *internal-errors*)) (svref *internal-errors* error-number)))) (cond ((and (functionp handler) - (eql (1- (length (%simple-fun-arglist handler))) - (length arguments))) + (internal-error-args-ok arguments handler)) (macrolet ((arg (n) `(sb!di::sub-access-debug-var-slot fp (nth ,n arguments) alien-context))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Nikodemus S. <de...@us...> - 2014-05-31 17:53:50
|
The branch "master" has been updated in SBCL: via 30c17523727cf55ca3b163db5a4c200c1e8451ee (commit) from fb0896e367aafc53626a0db3bca7d068448e354a (commit) - Log ----------------------------------------------------------------- commit 30c17523727cf55ca3b163db5a4c200c1e8451ee Author: Nikodemus Siivola <nik...@ra...> Date: Sat May 31 19:35:32 2014 +0300 fix test for bug-351 Wasn't testing what it was supposed to test: instead of hitting the malformed code from the SETF LET, it died on the invalid argument count instead. Oops. --- tests/compiler.pure.lisp | 16 +++++++++------- 1 files changed, 9 insertions(+), 7 deletions(-) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 2f44d07..cb38871 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1820,13 +1820,15 @@ ;;; bug #351 -- program-error for malformed LET and LET*, including those ;;; resulting from SETF of LET. -(dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops))) - (compile nil '(lambda () (let* :bogus-let* :oops))) - (compile nil '(lambda (x) (push x (let ((y 0)) y)))))) - (assert (functionp fun)) - (multiple-value-bind (res err) (ignore-errors (funcall fun)) - (assert (not res)) - (assert (typep err 'program-error)))) +(with-test (:name :bug-351) + (dolist (fun (list (compile nil '(lambda (x) (let :bogus-let :oops))) + (compile nil '(lambda (x) (let* :bogus-let* :oops))) + (compile nil '(lambda (x) (push x (let ((y 0)) y)))))) + (assert (functionp fun)) + (multiple-value-bind (res err) (ignore-errors (funcall fun t)) + (princ err) (terpri) + (assert (not res)) + (assert (typep err 'program-error))))) (let ((fun (compile nil '(lambda (x) (random (if x 10 20)))))) (dotimes (i 100 (error "bad RANDOM distribution")) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-05-31 17:21:40
|
The branch "master" has been updated in SBCL: via fb0896e367aafc53626a0db3bca7d068448e354a (commit) from 7bdae4d7a71db6a7c9feb6d8ebd073f82c7abf5b (commit) - Log ----------------------------------------------------------------- commit fb0896e367aafc53626a0db3bca7d068448e354a Author: Douglas Katzman <do...@go...> Date: Sat May 31 13:00:18 2014 -0400 Refactor FLUSH-WHITESPACE --- src/code/reader.lisp | 46 ++++++++++++++++++---------------------------- src/code/sysmacs.lisp | 2 +- 2 files changed, 19 insertions(+), 29 deletions(-) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index dde6c6a..6ea3e9e 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -427,35 +427,25 @@ standard Lisp readtable when NIL." (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. - (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (do ((attribute-array (character-attribute-array *readtable*)) - (attribute-hash-table - (character-attribute-hash-table *readtable*)) - (char (fast-read-char t) (fast-read-char t))) - ((/= (the fixnum - (if (typep char 'base-char) - (aref attribute-array (char-code char)) - (gethash char attribute-hash-table - +char-attr-constituent+))) - +char-attr-whitespace+) - (done-with-fast-read-char) - char))) + (let* ((stream (in-synonym-of stream)) + (rt *readtable*) + (attribute-array (character-attribute-array rt)) + (attribute-hash-table (character-attribute-hash-table rt))) + (macrolet ((done-p () + '(not (eql (if (typep char 'base-char) + (aref attribute-array (char-code char)) + (gethash char attribute-hash-table + +char-attr-constituent+)) + +char-attr-whitespace+)))) + (if (ansi-stream-p stream) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char t) (fast-read-char t))) + ((done-p) + (done-with-fast-read-char) + char))) ;; CLOS stream - (do ((attribute-array (character-attribute-array *readtable*)) - (attribute-hash-table - (character-attribute-hash-table *readtable*)) - (char (read-char stream nil :eof) (read-char stream nil :eof))) - ((or (eq char :eof) - (/= (the fixnum - (if (typep char 'base-char) - (aref attribute-array (char-code char)) - (gethash char attribute-hash-table - +char-attr-constituent+))) - +char-attr-whitespace+)) - (if (eq char :eof) - (error 'end-of-file :stream stream) + (do ((char (read-char stream nil nil) (read-char stream nil nil))) + ((if char (done-p) (error 'end-of-file :stream stream)) char)))))) ;;;; temporary initialization hack diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index b0aeb17..8a0718d 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -173,7 +173,7 @@ maintained." (if eof-p index-or-value (progn - (setq %frc-index% (1+ index-or-value)) + (setq %frc-index% (1+ (truly-the index index-or-value))) (aref %frc-buffer% index-or-value))))) (t (prog1 (aref %frc-buffer% %frc-index%) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-05-31 15:41:26
|
The branch "master" has been updated in SBCL: via 7bdae4d7a71db6a7c9feb6d8ebd073f82c7abf5b (commit) from 91e54df6125f28d32baaf3138f5d501c4df37396 (commit) - Log ----------------------------------------------------------------- commit 7bdae4d7a71db6a7c9feb6d8ebd073f82c7abf5b Author: Stas Boukarev <sta...@gm...> Date: Sat May 31 19:40:37 2014 +0400 Fix LOOP with character types. (loop with a t return a) returned #\x, do that only if the type is a subtype of character. Caught by ansi-cl-tests. --- src/code/loop.lisp | 5 ++++- tests/loop.pure.lisp | 8 ++++++++ 2 files changed, 12 insertions(+), 1 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index e13b93c..f06750d 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -742,7 +742,10 @@ code to be loaded. (let ((etype (sb!kernel:type-*-to-t (sb!kernel:array-type-specialized-element-type ctype)))) (make-array 0 :element-type (sb!kernel:type-specifier etype)))))) - ((sb!xc:typep #\x data-type) + #!+sb-unicode + ((sb!xc:subtypep data-type 'extended-char) + (code-char sb!int:base-char-code-limit)) + ((sb!xc:subtypep data-type 'character) #\x) (t nil))) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 4360684..44a7a6e 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -364,6 +364,7 @@ (assert (equal (loop for i from 1 to 4 sum (complex i (1+ i)) of-type complex) #c(10 14)))) + (with-test (:name :negative-repeat) (assert (zerop (let ((z 0)) (loop repeat 0 do (incf z)) @@ -377,3 +378,10 @@ (assert (zerop (let ((z 0)) (loop repeat -1000000 do (incf z)) z)))) + +(with-test (:name :of-type-character) + (assert (null (loop with a t return a))) + (assert (typep (loop with a of-type extended-char return a) 'extended-char)) + (assert (typep (loop with a of-type character return a) 'character)) + (assert (typep (loop with a of-type base-char return a) 'base-char)) + (assert (typep (loop with a of-type standard-char return a) 'standard-char))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-05-31 15:41:24
|
The branch "master" has been updated in SBCL: via 91e54df6125f28d32baaf3138f5d501c4df37396 (commit) from 8ab1619260896857944df4482a45d180a8c8ac68 (commit) - Log ----------------------------------------------------------------- commit 91e54df6125f28d32baaf3138f5d501c4df37396 Author: Stas Boukarev <sta...@gm...> Date: Sat May 31 19:14:43 2014 +0400 Fix LOOP REPEAT on negative integers. A recent regression caught by ansi-cl-tests. --- src/code/loop.lisp | 9 +++++++-- tests/loop.pure.lisp | 13 +++++++++++++ 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 2c33b51..e13b93c 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1179,8 +1179,13 @@ code to be loaded. (defun loop-do-repeat () (loop-disallow-conditional :repeat) (let* ((form (loop-get-form)) - (type (if (realp form) - `(mod ,(1+ (ceiling form))) + (type (cond ((not (realp form)) + 'integer) + ((plusp form) + `(mod ,(1+ (ceiling form)))) + (t + `(integer ,(ceiling form) )) + 'integer))) (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type))) (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index c97d7a5..4360684 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -364,3 +364,16 @@ (assert (equal (loop for i from 1 to 4 sum (complex i (1+ i)) of-type complex) #c(10 14)))) +(with-test (:name :negative-repeat) + (assert (zerop (let ((z 0)) + (loop repeat 0 do (incf z)) + z))) + (assert (zerop (let ((z 0)) + (loop repeat -1.5 do (incf z)) + z))) + (assert (zerop (let ((z 0)) + (loop repeat -1.5 do (incf z)) + z))) + (assert (zerop (let ((z 0)) + (loop repeat -1000000 do (incf z)) + z)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-05-31 15:41:22
|
The branch "master" has been updated in SBCL: via 8ab1619260896857944df4482a45d180a8c8ac68 (commit) from 17072c848a5107a4c3d7cc2d34bc302d701aa82f (commit) - Log ----------------------------------------------------------------- commit 8ab1619260896857944df4482a45d180a8c8ac68 Author: Stas Boukarev <sta...@gm...> Date: Sat May 31 19:05:35 2014 +0400 Fix LOOP sum x of-type complex. A regression during recent changes. Found out by ansi-cl-tests. --- src/code/loop.lisp | 12 ++++++++---- tests/loop.pure.lisp | 5 +++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 293d17c..2c33b51 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1029,10 +1029,14 @@ code to be loaded. (data nil)) ;collector-specific data (sb!int:defmacro-mundanely with-sum-count (lc &body body) - (let ((type (loop-collector-dtype lc)) - (temp-var (car (loop-collector-tempvars lc)))) - `(let ((,temp-var ,(loop-typed-init type))) - (declare (type ,type ,temp-var)) + (let* ((type (loop-collector-dtype lc)) + (temp-var (car (loop-collector-tempvars lc))) + (init (loop-typed-init type))) + `(let ((,temp-var ,init)) + (declare (type ,(if (sb!xc:typep init type) + type + `(or ,(type-of init) ,type)) + ,temp-var)) ,@body))) (defun loop-get-collection-info (collector class default-type) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 790ee86..c97d7a5 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -359,3 +359,8 @@ (assert (equal (let ((n 0)) (loop for x from (incf n) to (+ n 5) collect x)) '(1 2 3 4 5 6)))) + +(with-test (:name :summing-complex) + (assert (equal (loop for i from 1 to 4 + sum (complex i (1+ i)) of-type complex) + #c(10 14)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-05-31 15:00:21
|
The branch "master" has been updated in SBCL: via 17072c848a5107a4c3d7cc2d34bc302d701aa82f (commit) from 68d50581383bfdcbdc9fdd50e64b4e17bccefdf9 (commit) - Log ----------------------------------------------------------------- commit 17072c848a5107a4c3d7cc2d34bc302d701aa82f Author: Stas Boukarev <sta...@gm...> Date: Sat May 31 18:54:16 2014 +0400 Fix a regression in LOOP. (loop for i from #c(1 2) ...) is legal. I would think that (loop for i from #c(1 2) to #c(5 2)) should work to, but everybody seems to agree that it shouldn't, so I left it not working. Found out by ansi-cl-tests. --- src/code/loop.lisp | 40 +++++++++++++++++++++++++++++----------- tests/loop.pure.lisp | 11 +++++++++++ 2 files changed, 40 insertions(+), 11 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 88c5692..293d17c 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1565,8 +1565,7 @@ code to be loaded. (start-constantp nil) (limit-given nil) ; T when prep phrase has specified end (limit-constantp nil) - (limit-value nil) - ) + (limit-value nil)) (flet ((assert-index-for-arithmetic (index) (unless (atom index) (loop-error "Arithmetic index must be an atom.")))) @@ -1587,7 +1586,7 @@ code to be loaded. ;; KLUDGE: loop-make-var generates a temporary symbol for ;; indexv if it is NIL. We have to use it to have the index ;; actually count - (setq indexv (loop-make-var indexv form `(and real ,indexv-type)))) + (setq indexv (loop-make-var indexv form indexv-type))) ((:upto :to :downto :above :below) (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) @@ -1624,14 +1623,33 @@ code to be loaded. (when (and sequence-variable (not sequencep)) (loop-error "missing OF or IN phrase in sequence path")) ;; Now fill in the defaults. - (unless start-given - (assert-index-for-arithmetic indexv) - (setq indexv - (loop-make-var - indexv - (setq start-constantp t - start-value (or (loop-typed-init indexv-type) 0)) - `(and ,indexv-type real)))) + (cond ((not start-given) + ;; default start + ;; DUPLICATE KLUDGE: loop-make-var generates a temporary + ;; symbol for indexv if it is NIL. See also the comment in + ;; the (:from :downfrom :upfrom) case + (assert-index-for-arithmetic indexv) + (setq indexv + (loop-make-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real)))) + (limit-given + ;; if both start and limit are given, they had better both + ;; be REAL. We already enforce the REALness of LIMIT, + ;; above; here's the KLUDGE to enforce the type of START. + (flet ((type-declaration-of (x) + (and (eq (car x) 'type) (caddr x)))) + (let ((decl (find indexv *loop-declarations* + :key #'type-declaration-of)) + (%decl (find indexv *loop-declarations* + :key #'type-declaration-of + :from-end t))) + (sb!int:aver (eq decl %decl)) + (when decl + (setf (cadr decl) + `(and real ,(cadr decl)))))))) (cond ((member dir '(nil :up)) (when (or limit-given default-top) (unless limit-given diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index aa4962c..790ee86 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -348,3 +348,14 @@ #c(2 2))) (assert (= (loop repeat 1 sum 1 count 1) 2))) + +(with-test (:name :iterate-over-complex) + (assert + (equal + (loop for c from #c(0 1) repeat 5 collect c) + '(#C(0 1) #C(1 1) #C(2 1) #C(3 1) #C(4 1))))) + +(with-test (:name :side-effecting-start-form) + (assert (equal (let ((n 0)) + (loop for x from (incf n) to (+ n 5) collect x)) + '(1 2 3 4 5 6)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Nikodemus S. <de...@us...> - 2014-05-31 14:37:56
|
The branch "master" has been updated in SBCL: via 68d50581383bfdcbdc9fdd50e64b4e17bccefdf9 (commit) from 69232c29f1efcd6925e64a31f53046b2ee74bdf8 (commit) - Log ----------------------------------------------------------------- commit 68d50581383bfdcbdc9fdd50e64b4e17bccefdf9 Author: Nikodemus Siivola <nik...@ra...> Date: Sat May 31 17:04:09 2014 +0300 additional tests Add three test-cases from ansi-cl-tests that used to break stack analysis. Uncomment one old test that no longer fails. --- tests/compiler.pure.lisp | 65 ++++++++++++++++++++++++++++++++++++++-------- 1 files changed, 54 insertions(+), 11 deletions(-) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 480e4d1..2f44d07 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -702,6 +702,54 @@ (+ 359749 35728422)))) -24076))) +(with-test (:name :ansi-misc.293a) + (assert (= (funcall + (compile + nil + '(lambda (a b c) + (declare (optimize (speed 2) (space 3) (safety 1) + (debug 2) (compilation-speed 2))) + (block b6 + (multiple-value-prog1 + 0 b 0 + (catch 'ct7 + (return-from b6 + (catch 'ct2 + (complex (cl::handler-bind nil -254932942) 0)))))))) + 1 2 3) + -254932942))) + +(with-test (:name :ansi-misc.293d) + (assert (= (funcall + (compile + nil + '(lambda () + (declare (optimize (debug 3) (safety 0) (space 2) + (compilation-speed 2) (speed 2))) + (block b4 + (multiple-value-prog1 + 0 + (catch 'ct8 + (return-from b4 (catch 'ct2 (progn (tagbody) 0))))))))) + 0))) + +(with-test (:name :ansi-misc.618) + (assert (= (funcall + (compile + nil + '(lambda (c) + (declare (optimize (space 0) (compilation-speed 2) (debug 0) + (speed 3) (safety 0))) + (block b1 + (ignore-errors + (multiple-value-prog1 0 + (apply (constantly 0) + c + (catch 'ct2 (return-from b1 0)) + nil)))))) + -4951) + 0))) + ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD (assert (= (funcall (compile nil `(lambda (b) (declare (optimize (speed 3)) @@ -1917,17 +1965,12 @@ ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the ;;; machine's ASH instruction's immediate field) that the compiler ;;; thought was legitimate. -;;; -;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl -;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil -;;; exist and this test case serves as a reminder of the problem. -;;; --njf, 2005-07-05 -#+nil -(compile 'nil - (LAMBDA (B) - (DECLARE (TYPE (INTEGER -2 14) B)) - (DECLARE (IGNORABLE B)) - (ASH (IMAGPART B) 57))) +(with-test (:name :overlarge-immediate-in-ash-vop) + (compile 'nil + (LAMBDA (B) + (DECLARE (TYPE (INTEGER -2 14) B)) + (DECLARE (IGNORABLE B)) + (ASH (IMAGPART B) 57)))) ;;; bug reported by Eduardo Mu\~noz (multiple-value-bind (fun warnings failure) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |