From: William Harold Newman Date: Tue, 5 Nov 2002 21:22:31 +0000 (+0000) Subject: 0.7.9.32: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f319c3261c5eeb9c96dd003d7bb87664e0eea2fa;p=sbcl.git 0.7.9.32: merged emu pick-temporary-file-name-easily-subvertible patch (sbcl-devel 2002-11-01) --- diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index f6101db..a02162c 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -12,18 +12,27 @@ (in-package "SB-ALIEN") ; (SB-ALIEN, not SB!ALIEN, since we're in warm load.) +;;; SEMI-KLUDGE: Preferable would be to use something like O_NOFOLLOW +;;; which will refuse to open() a file if it is a symlink; but I've +;;; been told that is a FreeBSD/Linux-only thing. Meanwhile, this will +;;; make our filenames a lot less predictable. +;;; (The man file for open() says O_EXCL should treat even a symlink as +;;; an existing file. I wonder if it really does that.) +;;; Also, no more dependence on ASCII character ordering. +;;; -- mrd 20021101 +(defun generate-random-string (&optional (len 6)) + (let* ((characters "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") + (num (length characters)) + (string (make-string len))) + (dotimes (i len string) + (setf (char string i) + (char characters (random num)))))) + (defun pick-temporary-file-name (&optional - ;; KLUDGE: There are various security - ;; nastyisms associated with easily - ;; guessable temporary file names, - ;; and we haven't done anything to - ;; work around them here. -- pointed - ;; out by Dan Barlow on sbcl-devel - ;; 20000702 - (base "/tmp/sbcl-tmp-~D~C")) - (let ((code (char-code #\A))) + (base "/tmp/sbcl-tmp-~D~A")) + (let ((code (generate-random-string))) (loop - (let ((name (format nil base (sb-unix:unix-getpid) (code-char code)))) + (let ((name (format nil base (sb-unix:unix-getpid) code))) (multiple-value-bind (fd errno) (sb-unix:unix-open name (logior sb-unix:o_wronly @@ -37,14 +46,8 @@ (simple-file-perror "couldn't create temporary file ~S" name errno)) - ;; KLUDGE: depends on ASCII character ordering -- WHN 20000128 - ((= code (char-code #\Z)) - (setf code (char-code #\a))) - ((= code (char-code #\z)) - (return nil)) (t - (incf code)))))))) - + (setf code (generate-random-string))))))))) ;;; On any OS where we don't support foreign object file loading, any ;;; query of a foreign symbol value is answered with "no definition @@ -117,7 +120,6 @@ (defvar *dso-linker* "/usr/bin/ld") (defvar *dso-linker-options* '("-shared" "-o")) - (sb-alien:define-alien-routine dlopen system-area-pointer (file sb-alien:c-string) (mode sb-alien:int)) (sb-alien:define-alien-routine dlsym system-area-pointer @@ -127,17 +129,16 @@ ;;; Ensure that we've opened our own binary so we can dynamically resolve ;;; symbols in the C runtime. - +;;; ;;; Old comment: This used to happen only in ;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no libraries were ;;; dlopen()ed already, but that didn't work if something was ;;; dlopen()ed before any problem global vars were used. So now we do ;;; this in any function that can add to the *HANDLES-FROM-DLOPEN*, as ;;; well as in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS. - +;;; ;;; FIXME: It would work just as well to do it once at startup, actually. ;;; Then at least we know it's done. -dan 2001.05.10 - (defun ensure-runtime-symbol-table-opened () (unless *handles-from-dlopen* ;; Prevent recursive call if dlopen() isn't defined. @@ -226,7 +227,7 @@ (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) (let ((output-file (pick-temporary-file-name - (concatenate 'string "/tmp/~D~C" (string (gensym))))) + (concatenate 'string "/tmp/~D~A" (string (gensym))))) (error-output (make-string-output-stream))) (/show "running" *dso-linker*) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 46b983f..f867fc9 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -213,10 +213,12 @@ (type-specifier (fun-type-returns type))))) -;;; Since all function types are equivalent to FUNCTION, they are all -;;; subtypes of each other. -(!define-type-method - (function :simple-subtypep) (type1 type2) +;;; The meaning of this is a little confused. On the one hand, all +;;; function objects are represented the same way regardless of the +;;; arglists and return values, and apps don't get to ask things like +;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the +;;; other hand, Python wants to reason about function types. So... +(!define-type-method (function :simple-subtypep) (type1 type2) (flet ((fun-type-simple-p (type) (not (or (fun-type-rest type) (fun-type-keyp type)))) @@ -927,12 +929,16 @@ (if (and (> (length simplified-types) 1) (some #'union-type-p simplified-types)) (let* ((first-union (find-if #'union-type-p simplified-types)) - (other-types (coerce (remove first-union simplified-types) 'list)) - (distributed (maybe-distribute-one-union first-union other-types))) + (other-types (coerce (remove first-union simplified-types) + 'list)) + (distributed (maybe-distribute-one-union first-union + other-types))) (if distributed (apply #'type-union distributed) (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified-types))))) + :specifier `(and ,@(map 'list + #'type-specifier + simplified-types))))) (make-compound-type-or-something #'%make-intersection-type simplified-types (some #'type-enumerable @@ -960,7 +966,8 @@ (macrolet ((frob (name var) `(progn (setq ,var (make-named-type :name ',name)) - (setf (info :type :kind ',name) #+sb-xc-host :defined #-sb-xc-host :primitive) + (setf (info :type :kind ',name) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin ',name) ,var)))) ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a ;; special symbol which can be stuck in some places where an @@ -1204,7 +1211,7 @@ (error 'simple-type-error :datum predicate-name :expected-type 'symbol - :format-control "~S is not a symbol." + :format-control "The SATISFIES predicate name is not a symbol: ~S" :format-arguments (list predicate-name)))) ;; Create object. (make-hairy-type :specifier whole)) @@ -1465,7 +1472,8 @@ >= > t))))))) (!cold-init-forms - (setf (info :type :kind 'number) #+sb-xc-host :defined #-sb-xc-host :primitive) + (setf (info :type :kind 'number) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) @@ -1590,7 +1598,10 @@ ;; (error "Lower bound ~S is not less than upper bound ~S." low high)) ;; but it is correct to do *empty-type* - (make-numeric-type :class ',class :format ',format :low lb :high hb))))) + (make-numeric-type :class ',class + :format ',format + :low lb + :high hb))))) (!def-bounded-type rational rational nil) diff --git a/version.lisp-expr b/version.lisp-expr index 02b1f5b..ea30ceb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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.9.31" +"0.7.9.32"