tested for bug 21, didn't find it, removed it from BUGS.
added SANE-PACKAGE to handle non-PACKAGE values of *PACKAGE*
deleted some unused and redundant stuff from PCL
DTC's recommended workaround from the mailing list 3 Mar 2000:
(setf (pcl::find-class 'ccc1) (pcl::find-class 'ccc))
-21:
- There's probably a bug in the compiler handling of special variables
- in closures, inherited from the CMU CL code, as reported on the
- CMU CL mailing list. There's a patch for this on the CMU CL
- mailing list too:
- Message-ID: <38C8E188.A1E38B5E@jeack.com.au>
- Date: Fri, 10 Mar 2000 22:50:32 +1100
- From: "Douglas T. Crosher" <dtc@jeack.com.au>
-
22:
The ANSI spec, in section "22.3.5.2 Tilde Less-Than-Sign: Logical Block",
says that an error is signalled if ~W, ~_, ~<...~:>, ~I, or ~:T is used
** The TOP debugger command is also gone, since it's redundant with the
FRAME 0 command, and since it interfered with abbreviations for the
TOPLEVEL restart.
-* DEFCONSTANT has been made more ANSI-compatible (completely ANSI-compatible,
- as far as I know):
+* fixed bugs in DEFCONSTANT ANSI-compatibility:
** DEFCONSTANT now tests reassignments using EQL, not EQUAL, in order to
warn about behavior which is undefined under the ANSI spec. Note: This
is specified by ANSI, but it's not very popular with programmers.
pre-ANSI IR1 translation magic, so it does the ANSI-specified thing
when it's used as a non-toplevel form. (This is required in order
to implement the DEFCONSTANT-EQX macro.)
-?? fixed bug: (DEFCONSTANT X 1) (DEFVAR X) (SETF X 2) no longer "works".
-?? fixed bug 21, a compiler bug re. special variables in closures. One
- consequence of this is that ILISP should work better, because idioms like
- (LET ((*PACKAGE* ..)) (DO-SOMETHING)) no longer have screwy side-effects.
+ ** (DEFCONSTANT X 1) (DEFVAR X) (SETF X 2) no longer "works".
+ ** Unfortunately, non-toplevel DEFCONSTANT forms can still do some
+ funny things, due to bugs in the implementation of EVAL-WHEN
+ (bug #IR1-3). This probably won't be fixed until 0.7.x. (Fortunately,
+ non-toplevel DEFCONSTANTs are uncommon.)
* The core file version number and fasl file version number have been
incremented, because the old noncompliant DEFCONSTANT behavior involved
calling functions which no longer exist.
-
-?? signal handling reliability
-?? fixed some bugs mentioned in the man page:
- ?? DEFUN-vs.-DECLAIM
+* removed bug 21 from BUGS, since Martin Atzmueller points out that
+ it doesn't seem to affect SBCL after all
+* The system now recovers better from non-PACKAGE values of the *PACKAGE*
+ variable.
;; useful but non-standard user-level functions..
"ASSQ" "DELQ" "MEMQ"
"%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
+ "SANE-PACKAGE"
;; ..and macros
"COLLECT"
(let ((*features* (cons :sb-assembling *features*)))
(init-assembler)
(load (merge-pathnames name (make-pathname :type "lisp")))
- (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
+ (fasl-dump-cold-load-form `(in-package ,(package-name
+ (sane-package)))
*lap-output-file*)
(sb!assem:append-segment *code-segment* *elsewhere*)
(setf *elsewhere* nil)
(defun array-has-fill-pointer-p (array)
#!+sb-doc
- "Returns T if the given Array has a fill pointer, or Nil otherwise."
+ "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
(declare (array array))
(and (array-header-p array) (%array-fill-pointer-p array)))
(defun fill-pointer (vector)
#!+sb-doc
- "Returns the Fill-Pointer of the given Vector."
+ "Return the FILL-POINTER of the given VECTOR."
(declare (vector vector))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(%array-fill-pointer vector)
(declare (vector vector) (fixnum new))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(if (> new (%array-available-elements vector))
- (error "New fill pointer, ~S, is larger than the length of the vector."
- new)
+ (error
+ "The new fill pointer, ~S, is larger than the length of the vector."
+ new)
(setf (%array-fill-pointer vector) new))
(error 'simple-type-error
:datum vector
(defun vector-push (new-el array)
#!+sb-doc
- "Attempts to set the element of Array designated by the fill pointer
- to New-El and increment fill pointer by one. If the fill pointer is
- too large, Nil is returned, otherwise the index of the pushed element is
+ "Attempt to set the element of ARRAY designated by its fill pointer
+ to NEW-EL, and increment the fill pointer by one. If the fill pointer is
+ too large, NIL is returned, otherwise the index of the pushed element is
returned."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(let ((*debugger-hook* nil))
(funcall hook condition hook))))
(sb!unix:unix-sigsetmask 0)
- (let ((original-package *package*)) ; protected from WITH-STANDARD-IO-SYNTAX
+
+ ;; Elsewhere in the system, we use the SANE-PACKAGE function for
+ ;; this, but here causing an exception just as we're trying to handle
+ ;; an exception would be confusing, so instead we use a special hack.
+ (unless (and (packagep *package*)
+ (package-name *package*))
+ (setf *package* (find-package :cl-user))
+ (format *error-output*
+ "The value of ~S was not an undeleted PACKAGE. It has been
+reset to ~S."
+ '*package* *package*))
+ (let (;; Save *PACKAGE* to protect it from WITH-STANDARD-IO-SYNTAX.
+ (original-package *package*))
(with-standard-io-syntax
(let* ((*debug-condition* condition)
(*debug-restarts* (compute-restarts condition))
;; of the system running to finish processing it
(defstruct delayed-def!macro
(args (required-argument) :type cons)
- (package *package* :type package))
+ (package (sane-package) :type package))
;; a list of DELAYED-DEF!MACROs stored until we get DEF!MACRO working fully
;; so that we can apply it to them. After DEF!MACRO is made to work, this
;; list is processed, and then should no longer be used; it's made unbound in
;; enough of the system running to finish processing it
(defstruct delayed-def!struct
(args (required-argument) :type cons)
- (package *package* :type package))
+ (package (sane-package) :type package))
;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
;; working fully so that we can apply it to them then. After
;; DEF!STRUCT is made to work fully, this list is processed, then
(intern (string (dsd-%name dsd))
(if (dsd-accessor dsd)
(symbol-package (dsd-accessor dsd))
- *package*)))
+ (sane-package))))
\f
;;;; typed (non-class) structures
,n-size
,n-package)))))))))
- ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but since they
- ;; made the behavior of the fasloader depend on the *PACKAGE* variable, not
- ;; only were they a pain to support (because they required various hacks to
- ;; handle *PACKAGE*-manipulation forms) they were basically broken by design,
- ;; because ANSI gives the user so much flexibility in manipulating *PACKAGE*
- ;; at load-time that no reasonable hacks could possibly make things work
- ;; right. The ones used in CMU CL certainly didn't, as shown by e.g.
+ ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but
+ ;; since they made the behavior of the fasloader depend on the
+ ;; *PACKAGE* variable, not only were they a pain to support (because
+ ;; they required various hacks to handle *PACKAGE*-manipulation
+ ;; forms) they were basically broken by design, because ANSI gives
+ ;; the user so much flexibility in manipulating *PACKAGE* at
+ ;; load-time that no reasonable hacks could possibly make things
+ ;; work right. The ones used in CMU CL certainly didn't, as shown by
+ ;; e.g.
;; (IN-PACKAGE :CL-USER)
;; (DEFVAR CL::*FOO* 'FOO-VALUE)
;; (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
;;;; files for more information.
(in-package "SB!INT")
-
\f
;;;; DO-related stuff which needs to be visible on the cross-compilation host
(let ((*package* *keyword-package*))
(apply #'symbolicate things)))
+;;; Access *PACKAGE* in a way which lets us recover if someone has
+;;; done something silly like (SETF *PACKAGE* :CL-USER). (Such an
+;;; assignment is undefined behavior, so it's sort of reasonable for it
+;;; to cause the system to go totally insane afterwards, but it's
+;;; a fairly easy mistake to make, so let's try to recover gracefully
+;;; instead.)
+(defun sane-package ()
+ (let ((maybe-package *package*))
+ (cond ((and (packagep maybe-package)
+ ;; For good measure, we also catch the problem of
+ ;; *PACKAGE* being bound to a deleted package.
+ ;; Technically, this is not undefined behavior in itself,
+ ;; but it will immediately lead to undefined to behavior,
+ ;; since almost any operation on a deleted package is
+ ;; undefined.
+ (package-name maybe-package))
+ maybe-package)
+ (t
+ ;; We're in the undefined behavior zone. First, munge the
+ ;; system back into a defined state.
+ (let ((really-package (find-package :cl-user)))
+ (setf *package* really-package)
+ ;; Then complain.
+ (error 'simple-type-error
+ :datum maybe-package
+ :expected-type 'package
+ :format-control
+ "~S can't be a ~S:~% ~S has been reset to ~S"
+ :format-arguments (list '*package* (type-of maybe-package)
+ '*package* really-package)))))))
+
;;; Give names to elements of a numeric sequence.
(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
&rest identifiers)
(write-char #\: stream))
;; Otherwise, if the symbol's home package is the current
;; one, then a prefix is never necessary.
- ((eq package *package*))
+ ((eq package (sane-package)))
;; Uninterned symbols print with a leading #:.
((null package)
(when (or *print-gensym* *print-readably*)
(write-string "#:" stream)))
(t
- (multiple-value-bind (symbol accessible) (find-symbol name *package*)
+ (multiple-value-bind (symbol accessible)
+ (find-symbol name (sane-package))
;; If we can find the symbol by looking it up, it need not
;; be qualified. This can happen if the symbol has been
;; inherited from a package other than its home package.
(defun output-integer (integer stream)
;; FIXME: This UNLESS form should be pulled out into something like
- ;; GET-REASONABLE-PRINT-BASE, along the lines of GET-REASONABLE-PACKAGE
- ;; for the *PACKAGE* variable.
+ ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
+ ;; *PACKAGE* variable.
(unless (and (fixnump *print-base*)
(< 1 *print-base* 37))
(let ((obase *print-base*))
(casify-read-buffer escapes)
(let ((found (if package-designator
(find-package package-designator)
- *package*)))
+ (sane-package))))
(unless found
(error 'reader-package-error :stream stream
:format-arguments (list package-designator)
(defvar *gentemp-counter* 0)
(declaim (type unsigned-byte *gentemp-counter*))
-(defun gentemp (&optional (prefix "T") (package *package*))
+(defun gentemp (&optional (prefix "T") (package (sane-package)))
#!+sb-doc
- "Creates a new symbol interned in package Package with the given Prefix."
+ "Creates a new symbol interned in package PACKAGE with the given PREFIX."
(declare (type string prefix))
(loop
(let ((*print-base* 10)
(let ((sb!c::*default-cookie* sb!c::*default-cookie*)
(sb!c::*default-interface-cookie* sb!c::*default-interface-cookie*)
- (*package* *package*)
+ (*package* (sane-package))
(*readtable* *readtable*)
(*load-depth* (1+ *load-depth*))
;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST argument of
(defun package-external-symbol-count (package)
(stuff (package-external-symbols package))))
\f
-(defvar *package* () ; actually initialized in cold load
+(defvar *package* (error "*PACKAGE* should be initialized in cold load!")
#!+sb-doc "the current package")
;;; FIXME: should be declared of type PACKAGE, with no NIL init form,
;;; after I get around to cleaning up DOCUMENTATION
-;;;
-;;; FIXME: Setting *PACKAGE* to a non-PACKAGE value (even a plausible
-;;; one, like :CL-USER) makes the system fairly unusable, without
-;;; generating useful diagnostics. Is it possible to handle this
-;;; situation more gracefully by replacing references to *PACKAGE*
-;;; with references to (DEFAULT-PACKAGE) and implementing
-;;; DEFAULT-PACKAGE so that it checks for the PACKAGEness of *PACKAGE*
-;;; and helps the user to fix any problem (perhaps going through
-;;; CERROR)?
-;;; Error: An attempt was made to use the *PACKAGE* variable when it was
-;;; bound to the illegal (non-PACKAGE) value ~S. This is
-;;; forbidden by the ANSI specification and could have made
-;;; the system very confused. The *PACKAGE* variable has been
-;;; temporarily reset to #<PACKAGE "COMMON-LISP-USER">. How
-;;; would you like to proceed?
-;;; NAMED Set *PACKAGE* to ~S (which is the package which is
-;;; named by the old illegal ~S value of *PACKAGE*, and
-;;; is thus very likely the intended value) and continue
-;;; without signalling an error.
-;;; ERROR Leave *PACKAGE* set to #<PACKAGE "COMMON-LISP-USER">
-;;; and signal PACKAGE-ERROR to the code which tried to
-;;; use the old illegal value of *PACKAGE*.
-;;; CONTINUE Leave *PACKAGE* set to #<PACKAGE "COMMON-LISP-USER">
-;;; and continue without signalling an error.
;;; a map from package names to packages
(defvar *package-names*)
*package-names*)
res))
\f
-(defun intern (name &optional (package *package*))
+(defun intern (name &optional (package (sane-package)))
#!+sb-doc
"Returns a symbol having the specified name, creating it if necessary."
;; We just simple-stringify the name and call INTERN*, where the real
(length name)
(find-undeleted-package-or-lose package))))
-(defun find-symbol (name &optional (package *package*))
+(defun find-symbol (name &optional (package (sane-package)))
#!+sb-doc
"Returns the symbol named String in Package. If such a symbol is found
then the second value is :internal, :external or :inherited to indicate
\f
;;; If we are uninterning a shadowing symbol, then a name conflict can
;;; result, otherwise just nuke the symbol.
-(defun unintern (symbol &optional (package *package*))
+(defun unintern (symbol &optional (package (sane-package)))
#!+sb-doc
"Makes Symbol no longer present in Package. If Symbol was present
then T is returned, otherwise NIL. If Package is Symbol's home
(unintern symbol q)
(return t))))))))))
\f
-(defun export (symbols &optional (package *package*))
+(defun export (symbols &optional (package (sane-package)))
#!+sb-doc
"Exports Symbols from Package, checking that no name conflicts result."
(let ((package (find-undeleted-package-or-lose package))
t))
\f
;;; Check that all symbols are accessible, then move from external to internal.
-(defun unexport (symbols &optional (package *package*))
+(defun unexport (symbols &optional (package (sane-package)))
#!+sb-doc
"Makes Symbols no longer exported from Package."
(let ((package (find-undeleted-package-or-lose package))
\f
;;; Check for name conflict caused by the import and let the user
;;; shadowing-import if there is.
-(defun import (symbols &optional (package *package*))
+(defun import (symbols &optional (package (sane-package)))
#!+sb-doc
"Make Symbols accessible as internal symbols in Package. If a symbol
is already accessible then it has no effect. If a name conflict
\f
;;; If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
-(defun shadowing-import (symbols &optional (package *package*))
+(defun shadowing-import (symbols &optional (package (sane-package)))
#!+sb-doc
"Import Symbols into package, disregarding any name conflict. If
a symbol of the same name is present, then it is uninterned.
(pushnew sym (package-%shadowing-symbols package)))))
t)
-(defun shadow (symbols &optional (package *package*))
+(defun shadow (symbols &optional (package (sane-package)))
#!+sb-doc
"Make an internal symbol in Package with the same name as each of the
specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
t)
\f
;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
-(defun use-package (packages-to-use &optional (package *package*))
+(defun use-package (packages-to-use &optional (package (sane-package)))
#!+sb-doc
"Add all the Packages-To-Use to the use list for Package so that
the external symbols of the used packages are accessible as internal
(push package (package-%used-by-list pkg)))))
t)
-(defun unuse-package (packages-to-unuse &optional (package *package*))
+(defun unuse-package (packages-to-unuse &optional (package (sane-package)))
#!+sb-doc
"Remove Packages-To-Unuse from the use list for Package."
(let ((package (find-undeleted-package-or-lose package)))
minimal-debug-function-name-component)
((not pkg)
minimal-debug-function-name-uninterned)
- ((eq pkg *package*)
+ ((eq pkg (sane-package))
minimal-debug-function-name-symbol)
(t
minimal-debug-function-name-packaged))))
#+nil (*compiler-style-warning-count* 0)
#+nil (*compiler-note-count* 0)
(*block-compile* *block-compile-argument*)
- (*package* *package*)
- (*initial-package* *package*)
+ (*package* (sane-package))
+ (*initial-package* (sane-package))
(*initial-cookie* *default-cookie*)
(*initial-interface-cookie* *default-interface-cookie*)
(*default-cookie* (copy-cookie *initial-cookie*))
,(cadr var)))))))
(rest `((,var ,args-tail)))
(key (cond ((not (consp var))
- `((,var (get-key-arg ,(make-keyword var)
+ `((,var (get-key-arg ,(sb-int:keywordicate var)
,args-tail))))
((null (cddr var))
(multiple-value-bind (keyword variable)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (make-keyword (car var))
+ (values (sb-int:keywordicate (car var))
(car var)))
;; MNA: non-self-eval-keyword patch
`((,key (get-key-arg1 ',keyword ,args-tail))
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (make-keyword (car var))
+ (values (sb-int:keywordicate (car var))
(car var)))
;; MNA: non-self-eval-keyword patch
`((,key (get-key-arg1 ',keyword ,args-tail))
(or mf (method-function-from-fast-function mff)))))))
\f
(defun analyze-lambda-list (lambda-list)
- ;;(declare (values nrequired noptional keysp restp allow-other-keys-p
- ;; keywords keyword-parameters))
- (flet ((parse-keyword-argument (arg)
+ (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
+ (parse-keyword-argument (arg)
(if (listp arg)
(if (listp (car arg))
(caar arg)
- (make-keyword (car arg)))
- (make-keyword arg))))
+ (sb-int:keywordicate (car arg)))
+ (sb-int:keywordicate arg))))
(let ((nrequired 0)
(noptional 0)
(keysp nil)
(defun keyword-spec-name (x)
(let ((key (if (atom x) x (car x))))
(if (atom key)
- (intern (symbol-name key) *keyword-package*)
+ (intern (symbol-name key) sb-int:*keyword-package*)
(car key))))
(defun ftype-declaration-from-lambda-list (lambda-list name)
;;; be resolved by renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or
;;; with more gruntwork by punting the SB-ITERATE package and
;;; replacing calls to SB-ITERATE:ITERATE with calls to CL:LOOP.
+;;; So perhaps:
+;;; * Do some sort of automated check for overlap of symbols to make
+;;; sure there wouldn't be any other clashes.
+;;; * Rename SB-INT:ITERATE to SB-INT:NAMED-LET.
+;;; * Make SB-PCL use SB-INT and SB-EXT.
+;;; * Grep for SB-INT: and SB-EXT: prefixes in the pcl/ directory
+;;; and delete them.
;;; The caching algorithm implemented:
;;;
(when (and (consp form) (eq (car form) name))
(return-from get-declaration (cdr form))))))
-;;; FIXME: This duplicates SB-EXT:*KEYWORD-PACKAGE*.
-(defvar *keyword-package* (find-package 'keyword))
-
-;;; FIXME: This duplicates some of the functionality of SB-EXT:KEYWORDICATE.
-(defun make-keyword (symbol)
- (intern (symbol-name symbol) *keyword-package*))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defun string-append (&rest strings)
- (setq strings (copy-list strings)) ;The TI Explorer can't even
- ;RPLACA a &REST arg?
- (do ((string-loc strings (cdr string-loc)))
- ((null string-loc)
- (apply #'concatenate 'string strings))
- (rplaca string-loc (string (car string-loc)))))
-
-) ; EVAL-WHEN
-
-(defun symbol-append (sym1 sym2 &optional (package *package*))
- (intern (string-append sym1 sym2) package))
-
(defmacro collecting-once (&key initial-value)
`(let* ((head ,initial-value)
(tail ,(and initial-value `(last head))))
(loop (when (null .plist-tail.) (return nil))
(setq ,key (pop .plist-tail.))
(when (null .plist-tail.)
- (error "malformed plist in doplist, odd number of elements"))
+ (error "malformed plist, odd number of elements"))
(setq ,val (pop .plist-tail.))
(progn ,@bod)))))
(+ i f)))
(assert (= (exercise-valuesify 1.25) 2.25))
+;;; A bug inherited from CMU CL screwed up special variable bindings
+;;; inside closures. This was fixed in sbcl-0.6.8.10 by applying the
+;;; patches Douglas Crosher posted to cmucl-imp@cons.org 2000-03-10
+;;; (split across two different messages).
+;;; FIXME: I'd like to find a test case for this..
+
(sb-ext:quit :unix-status 104) ; success
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.8.9"
+"0.6.8.10"
projects / sbcl.git / commitdiff