common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.7.10.10:

Browse source 
Working INLINE inside MACROLET for user code.
		(more or less as per CSR sbcl-devel 2002-12-03)
	... change tricky cross-compiled inline functions to source
		transforms (including adding some functions to the
		function database)
	... use now-working FUNCTION-LAMBDA-EXPRESSION to get the
		expander function for local macros
	... build a complex LAMBDA-WITH-LEXENV for inlining user code
		(like CMUCL's INLINE-SYNTACTIC-CLOSURE-LAMBDA does)
	Some miscellaneous frobs
	... actually signal a style warning for array code (though it
		might actually be in currently-dead-but-should-be-alive
		code)
	... actually test the return value in the second half of
		filesys.test.sh
	... minor text adjustments (no more calling this period "early
		0.7.x")
This commit is contained in:
Christophe Rhodes 2002-12-04 15:23:00 +00:00
parent a23903deaf
commit 09d7974601
17 changed files with 328 additions and 230 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
BUGS
View file

@ -1040,6 +1040,8 @@ WORKAROUND:
lexical environment.
b. The body of (EVAL-WHEN (:COMPILE-TOPLEVEL) ...) is evaluated in
the null lexical environment.
c. The cross-compiler cannot inline functions defined in a non-null
lexical environment.
206: ":SB-FLUID feature broken"
(reported by Antonio Martinez-Shotton sbcl-devel 2002-10-07)

2
NEWS
View file

@ -1436,6 +1436,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10:
accessors that are related by inheritance, as specified in the
:CONC-NAME section of the specification of DEFSTRUCT. (thanks to
Valtteri Vuorikoski)
* the compiler is now able to inline functions that were defined in
a complex lexical environment (e.g. inside a MACROLET).
* fixed some more bugs revealed by Paul Dietz' test suite:
** As required by ANSI, LOOP now disallows anonymous collection
clauses such as COLLECT I in conjunction with aggregate boolean

12
TODO
View file

@ -1,11 +1,8 @@
for early 0.7.x:
for late 0.7.x:
* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made inlining DEFUN inside MACROLET work again
** (also, while working on INLINE anyway, it might be easy
to flush the old MAYBE-INLINE cruft entirely,
including e.g. on the man page)
* test file reworking
** *.pure.lisp tests run with assertoid.lisp loaded; assertoid
is moved to its own package, for use in *.impure.lisp.
** non-x86 ports now pass irrat.pure.lisp
** sparc and ppc now pass bit-vector.impure-cload.lisp
* faster bootstrapping (both make.sh and slam.sh)
@ -42,7 +39,8 @@ for early 0.7.x:
not quite ready for prime time..) of the system after
cold init
* fixups now feasible because of pre7 changes
** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE)
** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE,
including e.g. on the man page)
* miscellaneous simple refactoring
* belated renaming:
** renamed %PRIMITIVE to %VOP

5
package-data-list.lisp-expr
View file

@ -239,9 +239,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
"IR2-PHYSENV-NUMBER-STACK-P"
"KNOWN-CALL-LOCAL" "KNOWN-RETURN"
"LAMBDA-INDEPENDENT-OF-LEXENV-P"
"LAMBDA-WITH-LEXENV" "LEXENV-FIND"
"LOCATION=" "LTN-ANNOTATE"
"LOCATION=" "LTN-ANNOTATE"
"MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK"
"MAKE-CLOSURE" "MAKE-CONSTANT-TN" "MAKE-FIXNUM"
"MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN"
@ -249,6 +248,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET"
"MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK"
"MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE"
"MAYBE-INLINE-SYNTACTIC-CLOSURE"
"META-PRIMITIVE-TYPE-OR-LOSE"
"META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE"
"MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL"
@ -1037,6 +1037,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"DOUBLE-FLOAT-SIGNIFICAND"
"FLOAT-WAIT"
"DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
"EFFECTIVE-FIND-POSITION-TEST" "EFFECTIVE-FIND-POSITION-KEY"
"END-TOO-LARGE-ERROR"
"ERROR-NUMBER-OR-LOSE"
"FAILED-%WITH-ARRAY-DATA"

32
src/code/defboot.lisp
View file

@ -164,29 +164,15 @@
#-sb-xc-host
(named-lambda `(named-lambda ,name ,@lambda-guts))
(inline-lambda
(cond (;; Does the user not even want to inline?
(not (inline-fun-name-p name))
nil)
(;; Does inlining look too hairy to handle?
(not (sb!c:lambda-independent-of-lexenv-p lambda env))
(sb!c:maybe-compiler-note
"lexical environment too hairy, can't inline DEFUN ~S"
name)
nil)
(t
;; FIXME: The only reason that we return
;; LAMBDA-WITH-LEXENV instead of returning bare
;; LAMBDA is to avoid modifying downstream code
;; which expects LAMBDA-WITH-LEXENV. But the code
;; here is the only code which feeds into the
;; downstream code, and the generality of the
;; interface is no longer used, so it'd make sense
;; to simplify the interface instead of using the
;; old general LAMBDA-WITH-LEXENV interface in this
;; simplified way.
`(sb!c:lambda-with-lexenv
nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS
,@lambda-guts)))))
(when (inline-fun-name-p name)
;; we want to attempt to inline, so complain if we can't
(or (sb!c:maybe-inline-syntactic-closure lambda env)
(progn
(#+sb-xc-host warn
#-sb-xc-host sb!c:maybe-compiler-note
"lexical environment too hairy, can't inline DEFUN ~S"
name)
nil)))))
`(progn
;; In cross-compilation of toplevel DEFUNs, we arrange

27
src/code/numbers.lisp
View file

@ -685,19 +685,20 @@
(+ rem divisor)
rem)))
(macrolet ((def (name op doc)
`(defun ,name (number &optional (divisor 1))
,doc
(multiple-value-bind (res rem) (,op number divisor)
(values (float res (if (floatp rem) rem 1.0)) rem)))))
(def ffloor floor
"Same as FLOOR, but returns first value as a float.")
(def fceiling ceiling
"Same as CEILING, but returns first value as a float." )
(def ftruncate truncate
"Same as TRUNCATE, but returns first value as a float.")
(def fround round
"Same as ROUND, but returns first value as a float."))
(defmacro !define-float-rounding-function (name op doc)
`(defun ,name (number &optional (divisor 1))
,doc
(multiple-value-bind (res rem) (,op number divisor)
(values (float res (if (floatp rem) rem 1.0)) rem))))
(!define-float-rounding-function ffloor floor
"Same as FLOOR, but returns first value as a float.")
(!define-float-rounding-function fceiling ceiling
"Same as CEILING, but returns first value as a float." )
(!define-float-rounding-function ftruncate truncate
"Same as TRUNCATE, but returns first value as a float.")
(!define-float-rounding-function fround round
"Same as ROUND, but returns first value as a float.")
;;;; comparisons

104
src/code/seq.lisp
View file

@ -1897,23 +1897,10 @@
;;;; FIND, POSITION, and their -IF and -IF-NOT variants
;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
;;; POSITION-IF, etc.
(declaim (inline effective-find-position-test effective-find-position-key))
(defun effective-find-position-test (test test-not)
(cond ((and test test-not)
(error "can't specify both :TEST and :TEST-NOT"))
(test (%coerce-callable-to-fun test))
(test-not
;; (Without DYNAMIC-EXTENT, this is potentially horribly
;; inefficient, but since the TEST-NOT option is deprecated
;; anyway, we don't care.)
(complement (%coerce-callable-to-fun test-not)))
(t #'eql)))
(effective-find-position-test test test-not))
(defun effective-find-position-key (key)
(if key
(%coerce-callable-to-fun key)
#'identity))
(effective-find-position-key key))
;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
(macrolet (;; shared logic for defining %FIND-POSITION and
@ -1961,76 +1948,31 @@
from-end start end key)))
(frobs))))
;;; the user interface to FIND and POSITION: Get all our ducks in a
;;; row, then call %FIND-POSITION.
(declaim (inline find position))
(defmacro !def-find-position (fun-name values-index)
`(defun ,fun-name (item sequence &key
from-end (start 0) end
key test test-not)
(nth-value
,values-index
(%find-position item sequence
from-end start
end (effective-find-position-key key)
(effective-find-position-test test test-not)))))
(!def-find-position find 0)
(!def-find-position position 1)
;;; the user interface to FIND and POSITION: just interpreter stubs,
;;; nowadays.
(defun find (item sequence &key from-end (start 0) end key test test-not)
;; FIXME: this can't be the way to go, surely?
(find item sequence :from-end from-end :start start :end end :key key
:test test :test-not test-not))
(defun position (item sequence &key from-end (start 0) end key test test-not)
(position item sequence :from-end from-end :start start :end end :key key
:test test :test-not test-not))
;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
;;; to the interface to FIND and POSITION
(declaim (inline find-if position-if))
(defmacro !def-find-position-if (fun-name values-index)
`(defun ,fun-name (predicate sequence
&key from-end (start 0) end key)
(nth-value
,values-index
(%find-position-if (%coerce-callable-to-fun predicate)
sequence
from-end
start
end
(effective-find-position-key key)))))
(!def-find-position-if find-if 0)
(!def-find-position-if position-if 1)
;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
;;; didn't bother to worry about optimizing them, except note that on
;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
;;; sbcl-devel
;;;
;;; My understanding is that while the :test-not argument is
;;; deprecated in favour of :test (complement #'foo) because of
;;; semantic difficulties (what happens if both :test and :test-not
;;; are supplied, etc) the -if-not variants, while officially
;;; deprecated, would be undeprecated were X3J13 actually to produce
;;; a revised standard, as there are perfectly legitimate idiomatic
;;; reasons for allowing the -if-not versions equal status,
;;; particularly remove-if-not (== filter).
;;;
;;; This is only an informal understanding, I grant you, but
;;; perhaps it's worth optimizing the -if-not versions in the same
;;; way as the others?
;;;
;;; FIXME: Maybe remove uses of these deprecated functions (and
;;; definitely of :TEST-NOT) within the implementation of SBCL.
(declaim (inline find-if-not position-if-not))
(defmacro !def-find-position-if-not (fun-name values-index)
`(defun ,fun-name (predicate sequence
&key from-end (start 0) end key)
(nth-value
,values-index
(%find-position-if-not (%coerce-callable-to-fun predicate)
sequence
from-end
start
end
(effective-find-position-key key)))))
(!def-find-position-if-not find-if-not 0)
(!def-find-position-if-not position-if-not 1)
(defun find-if (predicate sequence &key from-end (start 0) end key)
(find-if predicate sequence :from-end from-end :start start
:end end :key key))
(defun position-if (predicate sequence &key from-end (start 0) end key)
(position-if predicate sequence :from-end from-end :start start
:end end :key key))
(defun find-if-not (predicate sequence &key from-end (start 0) end key)
(find-if-not predicate sequence :from-end from-end :start start
:end end :key key))
(defun position-if-not (predicate sequence &key from-end (start 0) end key)
(position-if-not predicate sequence :from-end from-end :start start
:end end :key key))
;;;; COUNT-IF, COUNT-IF-NOT, and COUNT

85
src/code/sort.lisp
View file

@ -16,89 +16,8 @@
;;; to generalize the CMU CL code to allow START and END values, this
;;; code has been written from scratch following Chapter 7 of
;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
(macrolet ((%index (x) `(truly-the index ,x))
(%parent (i) `(ash ,i -1))
(%left (i) `(%index (ash ,i 1)))
(%right (i) `(%index (1+ (ash ,i 1))))
(%heapify (i)
`(do* ((i ,i)
(left (%left i) (%left i)))
((> left current-heap-size))
(declare (type index i left))
(let* ((i-elt (%elt i))
(i-key (funcall keyfun i-elt))
(left-elt (%elt left))
(left-key (funcall keyfun left-elt)))
(multiple-value-bind (large large-elt large-key)
(if (funcall predicate i-key left-key)
(values left left-elt left-key)
(values i i-elt i-key))
(let ((right (%right i)))
(multiple-value-bind (largest largest-elt)
(if (> right current-heap-size)
(values large large-elt)
(let* ((right-elt (%elt right))
(right-key (funcall keyfun right-elt)))
(if (funcall predicate large-key right-key)
(values right right-elt)
(values large large-elt))))
(cond ((= largest i)
(return))
(t
(setf (%elt i) largest-elt
(%elt largest) i-elt
i largest)))))))))
(%sort-vector (keyfun &optional (vtype 'vector))
`(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting
;; type inference to propagate all the way
;; through this tangled mess of inlining. The
;; TRULY-THE here works around that. -- WHN
(%elt (i)
`(aref (truly-the ,',vtype vector)
(%index (+ (%index ,i) start-1)))))
(let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
(current-heap-size (- end start))
(keyfun ,keyfun))
(declare (type (integer -1 #.(1- most-positive-fixnum))
start-1))
(declare (type index current-heap-size))
(declare (type function keyfun))
(loop for i of-type index
from (ash current-heap-size -1) downto 1 do
(%heapify i))
(loop
(when (< current-heap-size 2)
(return))
(rotatef (%elt 1) (%elt current-heap-size))
(decf current-heap-size)
(%heapify 1))))))
;; FIXME: Oh dear.
(declaim (inline sort-vector))
(defun sort-vector (vector start end predicate key)
(declare (type vector vector))
(declare (type index start end))
(declare (type function predicate))
(declare (type (or function null) key))
;; This used to be (OPTIMIZE (SPEED 3) (SAFETY 3)), but now
;; (0.7.1.39) that (SAFETY 3) means "absolutely safe (including
;; expensive things like %DETECT-STACK-EXHAUSTION)" we get closer
;; to what we want by using (SPEED 2) (SAFETY 2): "pretty fast,
;; pretty safe, and safety is no more important than speed".
(declare (optimize (speed 2) (safety 2) (debug 1) (space 1)))
(if (typep vector 'simple-vector)
;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
(if (null key)
;; Special-casing the KEY=NIL case lets us avoid some
;; function calls.
(%sort-vector #'identity simple-vector)
(%sort-vector key simple-vector))
;; It's hard to anticipate many speed-critical applications for
;; sorting vector types other than (VECTOR T), so we just lump
;; them all together in one slow dynamically typed mess.
(locally
(declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
(%sort-vector (or key #'identity))))))
(defun sort-vector (vector start end predicate key)
(sort-vector vector start end predicate key))
;;; This is MAYBE-INLINE because it's not too hard to have an
;;; application where sorting is a major bottleneck, and inlining it

6
src/compiler/array-tran.lisp
View file

@ -304,9 +304,9 @@
;; elements before he reads elements (or to read manuals
;; before he writes code:-), we'll signal a STYLE-WARNING
;; in case he didn't realize this.
(compiler-note "The default initial element ~S is not a ~S."
(saetp-initial-element-default saetp)
eltype))
(compiler-style-warn "The default initial element ~S is not a ~S."
(saetp-initial-element-default saetp)
eltype))
creation-form)
(t
`(let ((array ,creation-form))

9
src/compiler/fndb.lisp
View file

@ -614,6 +614,8 @@
(defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence
(call)
:derive-type (sequence-result-nth-arg 1))
(defknown sb!impl::sort-vector (vector index index function (or function null)) vector
(call))
(defknown merge (type-specifier sequence sequence callable
&key (:key callable))
@ -1316,6 +1318,13 @@
(function sequence t index sequence-end function)
(values t (or index null))
(call))
(defknown effective-find-position-test (callable callable)
function
(flushable foldable))
(defknown effective-find-position-key (callable)
function
(flushable foldable))
(defknown sb!kernel::arg-count-error (t t t t t t) nil (unsafe))

94
src/compiler/lexenv.lisp
View file

@ -76,21 +76,81 @@
(null (make-null-lexenv))
(lexenv x)))
;;; Is it safe to just grab the lambda expression LAMBDA in isolation,
;;; ignoring the LEXENV?
;;;
;;; Note: The corresponding CMU CL code did something hairier so that
;;; it could save inline definitions of DEFUNs in nontrivial lexical
;;; environments. If it's ever important to try to do that, take a
;;; look at the old CMU CL #'INLINE-SYNTACTIC-CLOSURE.
(defun lambda-independent-of-lexenv-p (lambda lexenv)
(defun maybe-inline-syntactic-closure (lambda lexenv)
(declare (type list lambda) (type lexenv lexenv))
(aver (eql (first lambda) 'lambda)) ; basic sanity check
;; This is a trivial implementation that just makes sure that LEXENV
;; doesn't have anything interesting in it. A more sophisticated
;; implementation could skip things in LEXENV which aren't captured
;; by LAMBDA, but this implementation doesn't try.
(and (null (lexenv-blocks lexenv))
(null (lexenv-tags lexenv))
(null (lexenv-vars lexenv))
(null (lexenv-funs lexenv))))
(aver (eql (first lambda) 'lambda))
;; We used to have a trivial implementation, verifying that lexenv
;; was effectively null. However, this fails to take account of the
;; idiom
;;
;; (declaim (inline foo))
;; (macrolet ((def (x) `(defun ,x () ...)))
;; (def foo))
;;
;; which, while too complicated for the cross-compiler to handle in
;; unfriendly foreign lisp environments, would be good to support in
;; the target compiler. -- CSR, 2002-05-13 and 2002-11-02
(let ((vars (lexenv-vars lexenv))
(funs (lexenv-funs lexenv)))
(collect ((decls) (macros) (symbol-macros))
(cond
((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil)
((and (null vars) (null funs)) `(lambda-with-lexenv
nil nil nil
,@(cdr lambda)))
((dolist (x vars nil)
#+sb-xc-host
;; KLUDGE: too complicated for cross-compilation
(return t)
#-sb-xc-host
(let ((name (car x))
(what (cdr x)))
;; only worry about the innermost binding
(when (eq x (assoc name vars :test #'eq))
(typecase what
(cons
(aver (eq (car what) 'macro))
(symbol-macros x))
(global-var
;; A global should not appear in the lexical
;; environment? Is this true? FIXME!
(aver (eq (global-var-kind what) :special))
(decls `(special ,name)))
(t
;; we can't inline in the presence of this object
(return t))))))
nil)
((dolist (x funs nil)
#+sb-xc-host
;; KLUDGE: too complicated for cross-compilation (and
;; failure of OAOO in comments, *sigh*)
(return t)
#-sb-xc-host
(let ((name (car x))
(what (cdr x)))
;; again, only worry about the innermost binding, but
;; functions can have name (SETF FOO) so we need to use
;; EQUAL for the test.
(when (eq x (assoc name funs :test #'equal))
(typecase what
(cons
(macros (cons name (function-lambda-expression (cdr what)))))
;; FIXME: Is there a good reason for this not to be
;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case
;; you're wondering how this ever worked :-)? Maybe
;; in conjunction with an AVERrance that it's not an
;; (AND GLOBAL-VAR (NOT GLOBAL-FUN))? -- CSR,
;; 2002-07-08
(global-var
(when (defined-fun-p what)
(decls `(,(car (rassoc (defined-fun-inlinep what)
*inlinep-translations*))
,name))))
(t (return t))))))
nil)
(t
;; if we get this far, we've successfully dealt with
;; everything in FUNS and VARS, so:
`(lambda-with-lexenv ,(decls) ,(macros) ,(symbol-macros)
,@(cdr lambda)))))))

77
src/compiler/seqtran.lisp
View file

@ -927,3 +927,80 @@
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-vector-macro item sequence
from-end start end key test))
;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
;;; POSITION-IF, etc.
(define-source-transform effective-find-position-test (test test-not)
`(cond
((and ,test ,test-not)
(error "can't specify both :TEST and :TEST-NOT"))
(,test (%coerce-callable-to-fun ,test))
(,test-not
;; (Without DYNAMIC-EXTENT, this is potentially horribly
;; inefficient, but since the TEST-NOT option is deprecated
;; anyway, we don't care.)
(complement (%coerce-callable-to-fun ,test-not)))
(t #'eql)))
(define-source-transform effective-find-position-key (key)
`(if ,key
(%coerce-callable-to-fun ,key)
#'identity))
(macrolet ((define-find-position (fun-name values-index)
`(define-source-transform ,fun-name (item sequence &key
from-end (start 0) end
key test test-not)
`(nth-value ,,values-index
(%find-position ,item ,sequence
,from-end ,start
,end
(effective-find-position-key ,key)
(effective-find-position-test ,test ,test-not))))))
(define-find-position find 0)
(define-find-position position 1))
(macrolet ((define-find-position-if (fun-name values-index)
`(define-source-transform ,fun-name (predicate sequence &key
from-end (start 0)
end key)
`(nth-value
,,values-index
(%find-position-if (%coerce-callable-to-fun ,predicate)
,sequence ,from-end
,start ,end
(effective-find-position-key ,key))))))
(define-find-position-if find-if 0)
(define-find-position-if position-if 1))
;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
;;; didn't bother to worry about optimizing them, except note that on
;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
;;; sbcl-devel
;;;
;;; My understanding is that while the :test-not argument is
;;; deprecated in favour of :test (complement #'foo) because of
;;; semantic difficulties (what happens if both :test and :test-not
;;; are supplied, etc) the -if-not variants, while officially
;;; deprecated, would be undeprecated were X3J13 actually to produce
;;; a revised standard, as there are perfectly legitimate idiomatic
;;; reasons for allowing the -if-not versions equal status,
;;; particularly remove-if-not (== filter).
;;;
;;; This is only an informal understanding, I grant you, but
;;; perhaps it's worth optimizing the -if-not versions in the same
;;; way as the others?
;;;
;;; FIXME: Maybe remove uses of these deprecated functions (and
;;; definitely of :TEST-NOT) within the implementation of SBCL.
(macrolet ((define-find-position-if-not (fun-name values-index)
`(define-source-transform ,fun-name (predicate sequence &key
from-end (start 0)
end key)
`(nth-value
,,values-index
(%find-position-if-not (%coerce-callable-to-fun ,predicate)
,sequence ,from-end
,start ,end
(effective-find-position-key ,key))))))
(define-find-position-if-not find-if-not 0)
(define-find-position-if-not position-if-not 1))

2
src/compiler/sparc/system.lisp
View file

@ -68,6 +68,8 @@
(:generator 6
(load-type result function (- fun-pointer-lowtag))))
;;; Is this VOP dead? I can't see anywhere that it is used... -- CSR,
;;; 2002-06-21
(define-vop (set-fun-subtype)
(:translate (setf fun-subtype))
(:policy :fast-safe)

73
src/compiler/srctran.lisp
View file

@ -3334,6 +3334,79 @@
(mapcar #'get-element-type (union-type-types array-type))))
(t
*universal-type*)))))
(define-source-transform sb!impl::sort-vector (vector start end predicate key)
`(macrolet ((%index (x) `(truly-the index ,x))
(%parent (i) `(ash ,i -1))
(%left (i) `(%index (ash ,i 1)))
(%right (i) `(%index (1+ (ash ,i 1))))
(%heapify (i)
`(do* ((i ,i)
(left (%left i) (%left i)))
((> left current-heap-size))
(declare (type index i left))
(let* ((i-elt (%elt i))
(i-key (funcall keyfun i-elt))
(left-elt (%elt left))
(left-key (funcall keyfun left-elt)))
(multiple-value-bind (large large-elt large-key)
(if (funcall ,',predicate i-key left-key)
(values left left-elt left-key)
(values i i-elt i-key))
(let ((right (%right i)))
(multiple-value-bind (largest largest-elt)
(if (> right current-heap-size)
(values large large-elt)
(let* ((right-elt (%elt right))
(right-key (funcall keyfun right-elt)))
(if (funcall ,',predicate large-key right-key)
(values right right-elt)
(values large large-elt))))
(cond ((= largest i)
(return))
(t
(setf (%elt i) largest-elt
(%elt largest) i-elt
i largest)))))))))
(%sort-vector (keyfun &optional (vtype 'vector))
`(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting
;; type inference to propagate all the way
;; through this tangled mess of
;; inlining. The TRULY-THE here works
;; around that. -- WHN
(%elt (i)
`(aref (truly-the ,',vtype ,',',vector)
(%index (+ (%index ,i) start-1)))))
(let ((start-1 (1- ,',start)) ; Heaps prefer 1-based addressing.
(current-heap-size (- ,',end ,',start))
(keyfun ,keyfun))
(declare (type (integer -1 #.(1- most-positive-fixnum))
start-1))
(declare (type index current-heap-size))
(declare (type function keyfun))
(loop for i of-type index
from (ash current-heap-size -1) downto 1 do
(%heapify i))
(loop
(when (< current-heap-size 2)
(return))
(rotatef (%elt 1) (%elt current-heap-size))
(decf current-heap-size)
(%heapify 1))))))
(if (typep ,vector 'simple-vector)
;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
(if (null ,key)
;; Special-casing the KEY=NIL case lets us avoid some
;; function calls.
(%sort-vector #'identity simple-vector)
(%sort-vector ,key simple-vector))
;; It's hard to anticipate many speed-critical applications for
;; sorting vector types other than (VECTOR T), so we just lump
;; them all together in one slow dynamically typed mess.
(locally
(declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
(%sort-vector (or ,key #'identity))))))
;;;; debuggers' little helpers

21
tests/compiler.impure.lisp
View file

@ -614,6 +614,27 @@ BUG 48c, not yet fixed:
(assert (typep (check-embedded-thes 3 3 0 2.5f0) 'type-error))
(assert (typep (check-embedded-thes 3 3 2 3.5f0) 'type-error))
;;; INLINE inside MACROLET
(declaim (inline to-be-inlined))
(macrolet ((def (x) `(defun ,x (y) (+ y 1))))
(def to-be-inlined))
(defun call-inlined (z)
(to-be-inlined z))
(assert (= (call-inlined 3) 4))
(macrolet ((frob (x) `(+ ,x 3)))
(defun to-be-inlined (y)
(frob y)))
(assert (= (call-inlined 3)
;; we should have inlined the previous definition, so the
;; new one won't show up yet.
4))
(defun call-inlined (z)
(to-be-inlined z))
(assert (= (call-inlined 3) 6))
(defun to-be-inlined (y)
(+ y 5))
(assert (= (call-inlined 3) 6))
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself

5
tests/filesys.test.sh
View file

@ -184,7 +184,12 @@ Lisp filename syntax idiosyncrasies)."
(need-match "animal/vertebrate/mammal/../**/robot/*.*" nil)
(need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil))
(need-matches)
(sb-ext:quit :unix-status 52)
EOF
if [ $? != 52 ]; then
echo DIRECTORY/TRUENAME test part 1 failed, unexpected SBCL return code=$?
exit 1
fi
cd ..
rm -r $testdir

2
version.lisp-expr
View file

@ -18,4 +18,4 @@
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.7.10.9"
"0.7.10.10"