* Either get rid of or at least rework the fdefinition/encapsulation
system so that (SYMBOL-FUNCTION 'FOO) is identically equal to
(FDEFINITION 'FOO).
-* building using CLISP (since building under OpenMCL works, this is
- reduced to "it would be nice" rather than "as proof of concept")
-
=======================================================================
for 0.9:
a loader, used to read sbcl.core
.TP
.I sbcl.core
-dumped memory image containing most of SBCL, to be loaded by the
-'sbcl' executable
+dumped memory image containing most of SBCL, to be loaded by
+the 'sbcl' executable
.TP
.I sbclrc
optional system-wide startup script (in an etc-ish system
;; redefine our functions anyway; and developers can
;; fend for themselves.)
#!-sb-fluid (sb!ext:*derive-function-types* t)
- ;; FIXME: *TOPLEVEL-LAMBDA-MAX* should go away altogether.
- (sb!c::*toplevel-lambda-max* 1)
;; Let the target know that we're the cross-compiler.
(*features* (cons :sb-xc *features*))
;; We need to tweak the readtable..
vector (* n-word-bits vector-data-offset)
(* length n-byte-bits))
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
- (sc-offsets (sb!c::read-var-integer vector index)))
+ (sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets)))))))
(list successors))
(dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
succ-and-flags))
- (push (sb!c::read-var-integer blocks i) successors))
+ (push (sb!c:read-var-integer blocks i) successors))
(let* ((locations
- (dotimes (k (sb!c::read-var-integer blocks i)
+ (dotimes (k (sb!c:read-var-integer blocks i)
(result locations-buffer))
(let ((kind (svref sb!c::*compiled-code-location-kinds*
(aref+ blocks i)))
(pc (+ last-pc
- (sb!c::read-var-integer blocks i)))
+ (sb!c:read-var-integer blocks i)))
(tlf-offset (or tlf-number
- (sb!c::read-var-integer blocks
- i)))
- (form-number (sb!c::read-var-integer blocks i))
- (live-set (sb!c::read-packed-bit-vector
+ (sb!c:read-var-integer blocks i)))
+ (form-number (sb!c:read-var-integer blocks i))
+ (live-set (sb!c:read-packed-bit-vector
live-set-len blocks i)))
(vector-push-extend (make-known-code-location
pc debug-fun tlf-offset
vector-data-offset)
(* length n-byte-bits))
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
- (sc-offsets (sb!c::read-var-integer vector index)))
+ (sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets)))))))
vector-data-offset)
(* length n-byte-bits))
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(/hexstr error-number)
(collect ((sc-offsets))
(loop
(/hexstr index)
(when (>= index length)
(return))
- (sc-offsets (sb!c::read-var-integer vector index)))
+ (sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets)))))))
sb!vm:vector-data-offset)
(* length sb!vm:n-byte-bits))
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
- (sc-offsets (sb!c::read-var-integer vector index)))
+ (sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets))))))
vector-data-offset)
(* length n-byte-bits))
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
- (sc-offsets (sb!c::read-var-integer vector index)))
+ (sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets))))))
(defun args-for-tagged-add-inst (context bad-inst)
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
(misc #'fill-pointer-misc))
- (:constructor make-fill-pointer-output-stream (string))
+ (:constructor %make-fill-pointer-output-stream (string))
(:copier nil))
- ;; the string we throw stuff in
- string)
+ ;; a string with a fill pointer where we stuff the stuff we write
+ (string (error "missing argument") :type string :read-only t))
+
+(defun make-fill-pointer-output-stream (string)
+ (declare (type string string))
+ (fill-pointer string) ; called for side effect of checking has-fill-pointer
+ (%make-fill-pointer-output-stream string))
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
vector (* n-word-bits vector-data-offset)
(* length n-byte-bits))
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(/hexstr error-number)
(collect ((sc-offsets))
(loop
(/hexstr index)
(when (>= index length)
(return))
- (let ((sc-offset (sb!c::read-var-integer vector index)))
+ (let ((sc-offset (sb!c:read-var-integer vector index)))
(/show0 "SC-OFFSET=..")
(/hexstr sc-offset)
(sc-offsets sc-offset)))
(lengths))
(lengths 1) ; the length byte
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(lengths index)
(loop
(when (>= index length)
(return))
(let ((old-index index))
- (sc-offsets (sb!c::read-var-integer vector index))
+ (sc-offsets (sb!c:read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
\f
;;;; COMPILE-FILE
-;;; We build a list of top level lambdas, and then periodically smash
-;;; them together into a single component and compile it.
-(defvar *pending-toplevel-lambdas*)
-
-;;; The maximum number of top level lambdas we put in a single
-;;; top level component.
-;;;
-;;; CMU CL 18b used this nontrivially by default (setting it to 10)
-;;; but consequently suffered from the inability to execute some
-;;; troublesome constructs correctly, e.g. inability to load a fasl
-;;; file compiled from the source file
-;;; (defpackage "FOO" (:use "CL"))
-;;; (print 'foo::bar)
-;;; because it would dump data-setup fops (including a FOP-PACKAGE for
-;;; "FOO") for the second form before dumping the the code in the
-;;; first form, or the fop to execute the code in the first form. By
-;;; setting this value to 0 by default, we avoid this badness. This
-;;; increases the number of toplevel form functions, and so increases
-;;; the size of object files.
-;;;
-;;; The variable is still supported because when we are compiling the
-;;; SBCL system itself, which is known not contain any troublesome
-;;; constructs, we can set it to a nonzero value, which reduces the
-;;; number of toplevel form objects, reducing the peak memory usage in
-;;; GENESIS, which is desirable, since at least for SBCL version
-;;; 0.6.7, this is the high water mark for memory usage during system
-;;; construction.
-(defparameter *toplevel-lambda-max* 0)
-
(defun object-call-toplevel-lambda (tll)
(declare (type functional tll))
(let ((object *compile-object*))
(etypecase object
- (fasl-output
- (fasl-dump-toplevel-lambda-call tll object))
- (core-object
- (core-call-toplevel-lambda tll object))
+ (fasl-output (fasl-dump-toplevel-lambda-call tll object))
+ (core-object (core-call-toplevel-lambda tll object))
(null))))
-;;; Add LAMBDAS to the pending lambdas. If this leaves more than
-;;; *TOPLEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true,
-;;; then smash the lambdas into a single component, compile it, and
-;;; call the resulting function.
-(defun sub-compile-toplevel-lambdas (lambdas force-p)
+;;; Smash LAMBDAS into a single component, compile it, and arrange for
+;;; the resulting function to be called.
+(defun sub-compile-toplevel-lambdas (lambdas)
(declare (list lambdas))
- (setq *pending-toplevel-lambdas*
- (append *pending-toplevel-lambdas* lambdas))
- (let ((pending *pending-toplevel-lambdas*))
- (when (and pending
- (or (> (length pending) *toplevel-lambda-max*)
- force-p))
- (multiple-value-bind (component tll) (merge-toplevel-lambdas pending)
- (setq *pending-toplevel-lambdas* ())
- (compile-component component)
- (clear-ir1-info component)
- (object-call-toplevel-lambda tll))))
+ (when lambdas
+ (multiple-value-bind (component tll) (merge-toplevel-lambdas lambdas)
+ (compile-component component)
+ (clear-ir1-info component)
+ (object-call-toplevel-lambda tll)))
(values))
;;; Compile top level code and call the top level lambdas. We pick off
;;; top level lambdas in non-top-level components here, calling
;;; SUB-c-t-l-l on each subsequence of normal top level lambdas.
-(defun compile-toplevel-lambdas (lambdas force-p)
+(defun compile-toplevel-lambdas (lambdas)
(declare (list lambdas))
(let ((len (length lambdas)))
(flet ((loser (start)
len)))
(do* ((start 0 (1+ loser))
(loser (loser start) (loser start)))
- ((>= start len)
- (when force-p
- (sub-compile-toplevel-lambdas nil t)))
- (sub-compile-toplevel-lambdas (subseq lambdas start loser)
- (or force-p (/= loser len)))
+ ((>= start len))
+ (sub-compile-toplevel-lambdas (subseq lambdas start loser))
(unless (= loser len)
(object-call-toplevel-lambda (elt lambdas loser))))))
(values))
(maybe-mumble "IDFO ")
(multiple-value-bind (components top-components hairy-top)
(find-initial-dfo lambdas)
- (let ((*all-components* (append components top-components))
- (toplevel-closure nil))
+ (let ((*all-components* (append components top-components)))
(when *check-consistency*
(maybe-mumble "[check]~%")
(check-ir1-consistency *all-components*))
(dolist (component (append hairy-top top-components))
- (when (pre-physenv-analyze-toplevel component)
- (setq toplevel-closure t)))
+ (pre-physenv-analyze-toplevel component))
(dolist (component components)
(compile-component component)
- (when (replace-toplevel-xeps component)
- (setq toplevel-closure t)))
+ (replace-toplevel-xeps component))
(when *check-consistency*
(maybe-mumble "[check]~%")
(if load-time-value-p
(compile-load-time-value-lambda lambdas)
- (compile-toplevel-lambdas lambdas toplevel-closure))
+ (compile-toplevel-lambdas lambdas))
(mapc #'clear-ir1-info components)
(clear-stuff)))
(sb!xc:*compile-file-pathname* nil)
(sb!xc:*compile-file-truename* nil)
(*toplevel-lambdas* ())
- (*pending-toplevel-lambdas* ())
(*compiler-error-bailout*
(lambda ()
(compiler-mumble "~2&; fatal error, aborting compilation~%")
(sub-sub-compile-file info)
(finish-block-compilation)
- (compile-toplevel-lambdas () t)
(let ((object *compile-object*))
(etypecase object
(fasl-output (fasl-dump-source-info info object))
(:ignore-it
nil)
(t
- (compile-toplevel-lambdas () t)
(when (fasl-constant-already-dumped-p constant *compile-object*)
(return-from emit-make-load-form nil))
(let* ((name (let ((*print-level* 1) (*print-length* 2))
(lengths))
(lengths 1) ; the length byte
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(lengths index)
(loop
(when (>= index length)
(return))
(let ((old-index index))
- (sc-offsets (sb!c::read-var-integer vector index))
+ (sc-offsets (sb!c:read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
(lengths))
(lengths 1) ; the length byte
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(lengths index)
(loop
(when (>= index length)
(return))
(let ((old-index index))
- (sc-offsets (sb!c::read-var-integer vector index))
+ (sc-offsets (sb!c:read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
,(cond ((policy node (< safety 3))
;; ANSI requires the length-related type check only
;; when the SAFETY quality is 3... in other cases, we
- ;; skip it.
+ ;; skip it, because it could be expensive.
bare)
((not constant-result-type-arg-p)
`(sequence-of-checked-length-given-type ,bare
result-type-arg))
(t
- (let ((result-ctype (ir1-transform-specifier-type result-type)))
+ (let ((result-ctype (ir1-transform-specifier-type
+ result-type)))
(if (array-type-p result-ctype)
(let ((dims (array-type-dimensions result-ctype)))
(unless (and (listp dims) (= (length dims) 1))
(lengths))
(lengths 1) ; the length byte
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(lengths index)
(loop
(when (>= index length)
(return))
(let ((old-index index))
- (sc-offsets (sb!c::read-var-integer vector index))
+ (sc-offsets (sb!c:read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
(assert-type-error (concatenate '(string 6) "foo" " " "bar"))
(assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
(assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
- ;; SIMPLE-ARRAY isn't allowed as a vector type specifier
+ ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
(locally
- (declare (optimize safety))
+ (declare (optimize safety))
(assert-type-error (concatenate 'simple-array "foo" "bar"))
(assert-type-error (map 'simple-array #'identity '(1 2 3)))
+ (assert (equalp #(11 13)
+ (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
(assert-type-error (coerce '(1 2 3) 'simple-array))
(assert-type-error (merge 'simple-array '(1 3) '(2 4) '<))
+ (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
+ (assert-type-error (map 'array #'identity '(1 2 3)))
+ (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
+ (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
;; but COERCE has an exemption clause:
(assert (string= "foo" (coerce "foo" 'simple-array)))
;; ... though not in all cases.
;;; internal versions off the main CVS branch, it gets hairier, e.g.
;;; "0.pre7.14.flaky4.13".)
-"0.7.8.23"
+"0.7.8.24"
projects / sbcl.git / commitdiff