From: William Harold Newman Date: Tue, 27 Mar 2001 19:50:40 +0000 (+0000) Subject: 0.6.11.27: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0b3ec4b1d978b887db175b7b3bada8e727683e15;p=sbcl.git 0.6.11.27: redid BYTE-BLT to use memmove(3) (so GENESIS will work again!) deleted unused %SP-BYTE-BLT, and some unused stuff in SB!SYS added error checking in DEF!STRUCT to catch any programmer errors of (DEFSTRUCT FOO ..) followed by (DEF!STRUCT (.. (:INCLUDE FOO)) ..) MNA MAKE-LOAD-FORM UNIX-HOST bug and patch (fixing a particular instance of the DEF!STRUCT programmer error) --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b548511..7e1f40e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -35,7 +35,6 @@ :doc "private: stuff for implementing ALIENs and friends" :use ("CL") :export ("%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" - "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN-ARRAY-TYPE" @@ -1429,12 +1428,12 @@ and even SB-VM seem to have become somewhat blurred over the years." "GET-PAGE-SIZE" "GET-SYSTEM-INFO" "IGNORE-INTERRUPT" "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" - "MACRO" "MAKE-FD-STREAM" "MAKE-OBJECT-SET" "MAP-PORT" + "MACRO" "MAKE-FD-STREAM" "MAKE-OBJECT-SET" "MEMMOVE" "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" - "NULL-TERMINATED-STRING" "OBJECT-SET-OPERATION" + "OBJECT-SET-OPERATION" "OS-COLD-INIT-OR-REINIT" "OS-CONTEXT-T" "OUTPUT-RAW-BYTES" - "PARSE-BODY" "PERQ-STRING" "POINTER" - "POINTER<" "POINTER>" "PORT" "POSITIVE-PRIMEP" "PUSH-USING-SETQ" + "PARSE-BODY" "POINTER" + "POINTER<" "POINTER>" "PORT" "POSITIVE-PRIMEP" "READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE" "REMOVE-FD-HANDLER" "REMOVE-PORT-DEATH-HANDLER" "REMOVE-PORT-OBJECT" diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 88c9db0..1753747 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -186,6 +186,12 @@ #!-sb-fluid (declaim (inline do-unary-bit-bash)) (defun do-unary-bit-bash (src src-offset dst dst-offset length dst-ref-fn dst-set-fn src-ref-fn) + ;; FIXME: Declaring these bit indices to be of type OFFSET, then + ;; using the inline expansion in SPEED 3 SAFETY 0 functions, is not + ;; a good thing. At the very least, we should make sure that the + ;; type (overflow) checks get done. Better would be to avoid + ;; using bit indices, and to use 32-bit unsigneds instead, and/or + ;; to call out to things like memmove(3) for big moves. (declare (type offset src-offset dst-offset length) (type function dst-ref-fn dst-set-fn src-ref-fn)) (multiple-value-bind (dst-word-offset dst-bit-offset) diff --git a/src/code/debug-var-io.lisp b/src/code/debug-var-io.lisp index 36cbb44..6a61e26 100644 --- a/src/code/debug-var-io.lisp +++ b/src/code/debug-var-io.lisp @@ -44,8 +44,8 @@ (ash (aref ,vec (+ ,index 4)) 24)) (incf ,index 5)))))) -;;; Takes an adjustable vector Vec with a fill pointer and pushes the -;;; variable length representation of Int on the end. +;;; Take an adjustable vector VEC with a fill pointer and push the +;;; variable length representation of INT on the end. (defun write-var-integer (int vec) (declare (type (unsigned-byte 32) int)) (cond ((<= int 253) @@ -62,10 +62,10 @@ ;;;; packed strings ;;;; -;;;; A packed string is a variable length integer length followed by the -;;;; character codes. +;;;; A packed string is a variable length integer length followed by +;;;; the character codes. -;;; Read a packed string from Vec starting at Index, advancing Index. +;;; Read a packed string from VEC starting at INDEX, advancing INDEX. (defmacro read-var-string (vec index) (once-only ((len `(read-var-integer ,vec ,index))) (once-only ((res `(make-string ,len))) @@ -74,8 +74,9 @@ (incf ,index ,len) ,res)))) -;;; Write String into Vec (adjustable, fill-pointer) represented as the -;;; length (in a var-length integer) followed by the codes of the characters. +;;; Write STRING into VEC (adjustable, with fill-pointer) represented +;;; as the length (in a var-length integer) followed by the codes of +;;; the characters. (defun write-var-string (string vec) (declare (simple-string string)) (let ((len (length string))) @@ -86,8 +87,8 @@ ;;;; packed bit vectors -;;; Read the specified number of Bytes out of Vec at Index and convert them -;;; to a bit-vector. Index is incremented. +;;; Read the specified number of BYTES out of VEC at INDEX and convert +;;; them to a BIT-VECTOR. INDEX is incremented. (defmacro read-packed-bit-vector (bytes vec index) (once-only ((n-bytes bytes)) (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit))) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index cd70554..fecf0f8 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -79,8 +79,8 @@ (defun just-dump-it-normally (object &optional (env nil env-p)) (declare (type structure!object object)) (if env-p - (make-load-form-saving-slots object :environment env) - (make-load-form-saving-slots object))) + (make-load-form-saving-slots object :environment env) + (make-load-form-saving-slots object))) ;;; a MAKE-LOAD-FORM function for objects which don't use the load ;;; form system. This is used for LAYOUT objects because the special @@ -119,8 +119,8 @@ (defun parse-def!struct-args (nameoid &rest rest) (multiple-value-bind (name options) ; Note: OPTIONS can change below. (if (consp nameoid) - (values (first nameoid) (rest nameoid)) - (values nameoid nil)) + (values (first nameoid) (rest nameoid)) + (values nameoid nil)) (let* ((include-clause (find :include options :key #'first)) (def!struct-supertype nil) ; may change below (mlff-clause (find :make-load-form-fun options :key #'first)) @@ -132,10 +132,10 @@ (when include-clause (setf def!struct-supertype (second include-clause))) (if (eq name 'structure!object) ; if root of hierarchy - (aver (not include-clause)) - (unless include-clause - (setf def!struct-supertype 'structure!object) - (push `(:include ,def!struct-supertype) options))) + (aver (not include-clause)) + (unless include-clause + (setf def!struct-supertype 'structure!object) + (push `(:include ,def!struct-supertype) options))) (values name `((,name ,@options) ,@rest) mlff def!struct-supertype))))) ;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate @@ -153,23 +153,23 @@ (let* ((class (sb!xc:find-class (type-of instance))) (layout (class-layout class))) (if (zerop index) - layout - (let* ((dd (layout-info layout)) - (dsd (elt (dd-slots dd) (1- index))) - (accessor (dsd-accessor dsd))) - (declare (type symbol accessor)) - (funcall accessor instance))))) + layout + (let* ((dd (layout-info layout)) + (dsd (elt (dd-slots dd) (1- index))) + (accessor (dsd-accessor dsd))) + (declare (type symbol accessor)) + (funcall accessor instance))))) (defun %instance-set (instance index new-value) (check-type instance structure!object) (let* ((class (sb!xc:find-class (type-of instance))) (layout (class-layout class))) (if (zerop index) - (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host") - (let* ((dd (layout-info layout)) - (dsd (elt (dd-slots dd) (1- index))) - (accessor (dsd-accessor dsd))) - (declare (type symbol accessor)) - (funcall (fdefinition `(setf ,accessor)) new-value instance)))))) + (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host") + (let* ((dd (layout-info layout)) + (dsd (elt (dd-slots dd) (1- index))) + (accessor (dsd-accessor dsd))) + (declare (type symbol accessor)) + (funcall (fdefinition `(setf ,accessor)) new-value instance)))))) ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return ;;; DEFSTRUCT-style arguments with any class names in the SB!XC @@ -182,17 +182,17 @@ (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args (multiple-value-bind (name options) (if (symbolp name-and-options) - (values name-and-options nil) - (values (first name-and-options) - (rest name-and-options))) + (values name-and-options nil) + (values (first name-and-options) + (rest name-and-options))) (flet ((uncross-option (option) (if (eq (first option) :include) - (destructuring-bind - (include-keyword included-name &rest rest) - option - `(,include-keyword - ,(uncross included-name) - ,@rest)) + (destructuring-bind + (include-keyword included-name &rest rest) + option + `(,include-keyword + ,(uncross included-name) + ,@rest)) option))) `((,(uncross name) ,@(mapcar #'uncross-option options)) @@ -209,17 +209,17 @@ (multiple-value-bind (name defstruct-args mlff def!struct-supertype) (apply #'parse-def!struct-args args) `(progn - ;; (Putting the DEFSTRUCT here, outside the EVAL-WHEN, seems to - ;; be necessary in order to cross-compile the hash table - ;; implementation. -- WHN 19990809) + ;; Make sure that we really do include STRUCTURE!OBJECT. (If an + ;; :INCLUDE clause was used, and the included class didn't + ;; itself include STRUCTURE!OBJECT, then we wouldn't; and it's + ;; better to find out ASAP then to let the bug lurk until + ;; someone tries to do MAKE-LOAD-FORM on the object.) + (aver (subtypep ',def!struct-supertype 'structure!object)) (defstruct ,@defstruct-args) - ;; (Putting this SETF here, outside the EVAL-WHEN, seems to be - ;; necessary in order to allow us to put the DEFSTRUCT outside - ;; the EVAL-WHEN.) (setf (def!struct-type-make-load-form-fun ',name) ,(if (symbolp mlff) - `',mlff - mlff) + `',mlff + mlff) (def!struct-supertype ',name) ',def!struct-supertype) ;; This bit of commented-out code hasn't been needed for quite @@ -249,29 +249,29 @@ #+sb-xc-host (defun force-delayed-def!structs () (if (boundp '*delayed-def!structs*) - (progn - (mapcar (lambda (x) - (let ((*package* (delayed-def!struct-package x))) - ;; KLUDGE(?): EVAL is almost always the wrong thing. - ;; However, since we have to map DEFSTRUCT over the - ;; list, and since ANSI declined to specify any - ;; functional primitives corresponding to the - ;; DEFSTRUCT macro, it seems to me that EVAL is - ;; required in there somewhere.. - (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x))))) - (reverse *delayed-def!structs*)) - ;; We shouldn't need this list any more. Making it unbound - ;; serves as a signal to DEF!STRUCT that it needn't delay - ;; DEF!STRUCTs any more. It is also generally a good thing for - ;; other reasons: it frees garbage, and it discourages anyone - ;; else from pushing anything else onto the list later. - (makunbound '*delayed-def!structs*)) - ;; This condition is probably harmless if it comes up when - ;; interactively experimenting with the system by loading a source - ;; file into it more than once. But it's worth warning about it - ;; because it definitely shouldn't come up in an ordinary build - ;; process. - (warn "*DELAYED-DEF!STRUCTS* is already unbound."))) + (progn + (mapcar (lambda (x) + (let ((*package* (delayed-def!struct-package x))) + ;; KLUDGE(?): EVAL is almost always the wrong thing. + ;; However, since we have to map DEFSTRUCT over the + ;; list, and since ANSI declined to specify any + ;; functional primitives corresponding to the + ;; DEFSTRUCT macro, it seems to me that EVAL is + ;; required in there somewhere.. + (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x))))) + (reverse *delayed-def!structs*)) + ;; We shouldn't need this list any more. Making it unbound + ;; serves as a signal to DEF!STRUCT that it needn't delay + ;; DEF!STRUCTs any more. It is also generally a good thing for + ;; other reasons: it frees garbage, and it discourages anyone + ;; else from pushing anything else onto the list later. + (makunbound '*delayed-def!structs*)) + ;; This condition is probably harmless if it comes up when + ;; interactively experimenting with the system by loading a source + ;; file into it more than once. But it's worth warning about it + ;; because it definitely shouldn't come up in an ordinary build + ;; process. + (warn "*DELAYED-DEF!STRUCTS* is already unbound."))) ;;; The STRUCTURE!OBJECT abstract class is the base of the type ;;; hierarchy for objects which have/use DEF!STRUCT functionality. @@ -304,5 +304,5 @@ #+sb-xc-host (defmethod make-load-form ((obj structure!object) &optional (env nil env-p)) (if env-p - (structure!object-make-load-form obj env) - (structure!object-make-load-form obj))) + (structure!object-make-load-form obj env) + (structure!object-make-load-form obj))) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index caadeaf..39293ab 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -131,7 +131,7 @@ (declare (type system-area-pointer context)) ;; FIXME: The find-the-detailed-problem code below went stale with ;; the big switchover to POSIX signal handling and signal contexts - ;; which are opaque at the Lisp level ca plod-0.6.7. It needs to be + ;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be ;; revived, which will require writing a C-level os-dependent ;; function to extract floating point modes, and a Lisp-level ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function. diff --git a/src/code/mipsstrops.lisp b/src/code/mipsstrops.lisp index 956a7a4..c2798d1 100644 --- a/src/code/mipsstrops.lisp +++ b/src/code/mipsstrops.lisp @@ -12,24 +12,16 @@ (in-package "SB!IMPL") -;(defun %sp-byte-blt (src-string src-start dst-string dst-start dst-end) -; "Moves bytes from Src-String into Dst-String between Dst-Start (inclusive) -;and Dst-End (exclusive) (Dst-Start - Dst-End bytes are moved). Overlap of the -;strings does not affect the result. This would be done on the Vax -;with MOVC3. The arguments do not need to be strings: 8-bit U-Vectors -;are also acceptable." -; (%primitive byte-blt src-string src-start dst-string dst-start dst-end)) - +;;; Compare the substrings specified by STRING1 and STRING2 and return +;;; NIL if the strings are STRING=, or the lowest index of STRING1 in +;;; which the two differ. If one string is longer than the other and +;;; the shorter is a prefix of the longer, the length of the shorter + +;;; START1 is returned. The arguments must be simple strings. +;;; +;;; This would be done on the Vax with CMPC3. (defun %sp-string-compare (string1 start1 end1 string2 start2 end2) (declare (simple-string string1 string2)) (declare (fixnum start1 end1 start2 end2)) - #!+sb-doc - "Compares the substrings specified by String1 and String2 and returns -NIL if the strings are String=, or the lowest index of String1 in -which the two differ. If one string is longer than the other and the -shorter is a prefix of the longer, the length of the shorter + start1 is -returned. This would be done on the Vax with CMPC3. The arguments must -be simple strings." (let ((len1 (- end1 start1)) (len2 (- end2 start2))) (declare (fixnum len1 len2)) @@ -56,11 +48,10 @@ be simple strings." (if (char/= (schar string1 index1) (schar string2 index2)) (return index1))))))) +;;; like %SP-STRING-COMPARE, only backwards (defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2) (declare (simple-string string1 string2)) (declare (fixnum start1 end1 start2 end2)) - #!+sb-doc - "like %SP-STRING-COMPARE, only backwards" (let ((len1 (- end1 start1)) (len2 (- end2 start2))) (declare (fixnum len1 len2)) @@ -102,16 +93,16 @@ be simple strings." `(char-code (char-ref ,index)))) ,@body)))) +;;; The codes of the characters of STRING from START to END are used +;;; as indices into the TABLE, which is a U-Vector of 8-bit bytes. +;;; When the number picked up from the table bitwise ANDed with MASK +;;; is non-zero, the current index into the STRING is returned. +;;; +;;; (This corresponds to SCANC on the Vax.) (defun %sp-find-character-with-attribute (string start end table mask) (declare (type (simple-array (unsigned-byte 8) (256)) table) (type (or simple-string system-area-pointer) string) (fixnum start end mask)) - #!+sb-doc - "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask - The codes of the characters of String from Start to End are used as indices - into the Table, which is a U-Vector of 8-bit bytes. When the number picked - up from the table bitwise ANDed with Mask is non-zero, the current - index into the String is returned. The corresponds to SCANC on the Vax." (maybe-sap-maybe-string (string) (do ((index start (1+ index))) ((>= index end) nil) @@ -119,9 +110,8 @@ be simple strings." (unless (zerop (logand (aref table (byte-ref index)) mask)) (return index))))) +;;; like %SP-FIND-CHARACTER-WITH-ATTRIBUTE, only sdrawkcaB (defun %sp-reverse-find-character-with-attribute (string start end table mask) - #!+sb-doc - "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." (declare (type (or simple-string system-area-pointer) string) (fixnum start end mask) (type (array (unsigned-byte 8) (256)) table)) @@ -132,12 +122,10 @@ be simple strings." (unless (zerop (logand (aref table (byte-ref index)) mask)) (return index))))) +;;; Search STRING for the CHARACTER from START to END. If the +;;; character is found, the corresponding index into STRING is +;;; returned, otherwise NIL is returned. (defun %sp-find-character (string start end character) - #!+sb-doc - "%SP-Find-Character String, Start, End, Character - Searches String for the Character from Start to End. If the character is - found, the corresponding index into String is returned, otherwise NIL is - returned." (declare (fixnum start end) (type (or simple-string system-area-pointer) string) (base-char character)) @@ -148,15 +136,13 @@ be simple strings." (when (char= (char-ref index) character) (return index))))) +;;; Search STRING for CHARACTER from END to START. If the character is +;;; found, the corresponding index into STRING is returned, otherwise +;;; NIL is returned. (defun %sp-reverse-find-character (string start end character) (declare (type (or simple-string system-area-pointer) string) (fixnum start end) (base-char character)) - #!+sb-doc - "%SP-Reverse-Find-Character String, Start, End, Character - Searches String for Character from End to Start. If the character is - found, the corresponding index into String is returned, otherwise NIL is - returned." (maybe-sap-maybe-string (string) (do ((index (1- end) (1- index)) (terminus (1- start))) @@ -165,14 +151,13 @@ be simple strings." (if (char= (char-ref index) character) (return index))))) +;;; Return the index of the first character between START and END +;;; which is not CHAR= to CHARACTER, or NIL if there is no such +;;; character. (defun %sp-skip-character (string start end character) (declare (type (or simple-string system-area-pointer) string) (fixnum start end) (base-char character)) - #!+sb-doc - "%SP-Skip-Character String, Start, End, Character - Returns the index of the first character between Start and End which - is not Char= to Character, or NIL if there is no such character." (maybe-sap-maybe-string (string) (do ((index start (1+ index))) ((= index end) nil) @@ -180,14 +165,12 @@ be simple strings." (if (char/= (char-ref index) character) (return index))))) +;;; Return the index of the last character between START and END which +;;; is not CHAR= to CHARACTER, or NIL if there is no such character. (defun %sp-reverse-skip-character (string start end character) (declare (type (or simple-string system-area-pointer) string) (fixnum start end) (base-char character)) - #!+sb-doc - "%SP-Skip-Character String, Start, End, Character - Returns the index of the last character between Start and End which - is not Char= to Character, or NIL if there is no such character." (maybe-sap-maybe-string (string) (do ((index (1- end) (1- index)) (terminus (1- start))) @@ -196,12 +179,9 @@ be simple strings." (if (char/= (char-ref index) character) (return index))))) +;;; Search for the substring of STRING1 specified in STRING2. Return +;;; an index into STRING2, or NIL if the substring wasn't found. (defun %sp-string-search (string1 start1 end1 string2 start2 end2) - #!+sb-doc - "%SP-String-Search String1, Start1, End1, String2, Start2, End2 - Searches for the substring of String1 specified in String2. - Returns an index into String2 or NIL if the substring wasn't - found." (declare (simple-string string1 string2)) (do ((index2 start2 (1+ index2))) ((= index2 end2) nil) diff --git a/src/code/misc-aliens.lisp b/src/code/misc-aliens.lisp new file mode 100644 index 0000000..bcebb22 --- /dev/null +++ b/src/code/misc-aliens.lisp @@ -0,0 +1,18 @@ +;;;; assorted alien definitions + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!IMPL") + +(declaim (inline memmove)) +(def-alien-routine ("memmove" memmove) void + (dest (* char)) + (src (* char)) + (n unsigned-int)) diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 6815d1d..7b44fae 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -16,7 +16,7 @@ ;;; The HOST structure holds the functions that both parse the ;;; pathname information into structure slot entries, and after ;;; translation the inverse (unparse) functions. -(sb!xc:defstruct (host (:constructor nil)) +(def!struct (host (:constructor nil)) (parse (required-argument) :type function) (unparse (required-argument) :type function) (unparse-host (required-argument) :type function) @@ -25,7 +25,7 @@ (unparse-enough (required-argument) :type function) (customary-case (required-argument) :type (member :upper :lower))) -(sb!xc:defstruct (logical-host +(def!struct (logical-host (:include host (:parse #'parse-logical-namestring) (:unparse #'unparse-logical-namestring) @@ -49,7 +49,7 @@ ;;; the various magic tokens that are allowed to appear in pretty much ;;; all pathname components -(sb!xc:deftype component-tokens () ; FIXME: rename to PATHNAME-COMPONENT-TOKENS +(sb!xc:deftype pathname-component-tokens () '(member nil :unspecific :wild)) (sb!xc:defstruct (pathname (:conc-name %pathname-) @@ -63,16 +63,16 @@ ;; the host (at present either a UNIX or logical host) (host nil :type (or host null)) ;; the name of a logical or physical device holding files - (device nil :type (or simple-string component-tokens)) + (device nil :type (or simple-string pathname-component-tokens)) ;; a list of strings that are the component subdirectory components (directory nil :type list) ;; the filename - (name nil :type (or simple-string pattern component-tokens)) + (name nil :type (or simple-string pattern pathname-component-tokens)) ;; the type extension of the file - (type nil :type (or simple-string pattern component-tokens)) + (type nil :type (or simple-string pattern pathname-component-tokens)) ;; the version number of the file, a positive integer (not supported ;; on standard Unix filesystems) - (version nil :type (or integer component-tokens (member :newest)))) + (version nil :type (or integer pathname-component-tokens (member :newest)))) ;;; Logical pathnames have the following format: ;;; diff --git a/src/code/stream.lisp b/src/code/stream.lisp index cccdba4..a179402 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -413,12 +413,13 @@ ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the ;;; number of bytes read. ;;; -;;; Note: CMU CL's version of this had a special interpretation of EOF-ERROR-P -;;; which SBCL does not have. (In the EOF-ERROR-P=NIL case, CMU CL's version -;;; would return as soon as any data became available.) This could be useful -;;; behavior for things like pipes in some cases, but it wasn't being used in -;;; SBCL, so it was dropped. If we ever need it, it could be added later as a -;;; new variant N-BIN method (perhaps N-BIN-ASAP?) or something. +;;; Note: CMU CL's version of this had a special interpretation of +;;; EOF-ERROR-P which SBCL does not have. (In the EOF-ERROR-P=NIL +;;; case, CMU CL's version would return as soon as any data became +;;; available.) This could be useful behavior for things like pipes in +;;; some cases, but it wasn't being used in SBCL, so it was dropped. +;;; If we ever need it, it could be added later as a new variant N-BIN +;;; method (perhaps N-BIN-ASAP?) or something. (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t)) (declare (type lisp-stream stream) (type index numbytes start) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index e10d251..37cff3e 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -453,11 +453,11 @@ #!+sb-doc "Makes a new pathname from the component arguments. Note that host is a host-structure or string." - (declare (type (or string host component-tokens) host) - (type (or string component-tokens) device) - (type (or list string pattern component-tokens) directory) - (type (or string pattern component-tokens) name type) - (type (or integer component-tokens (member :newest)) version) + (declare (type (or string host pathname-component-tokens) host) + (type (or string pathname-component-tokens) device) + (type (or list string pattern pathname-component-tokens) directory) + (type (or string pattern pathname-component-tokens) name type) + (type (or integer pathname-component-tokens (member :newest)) version) (type (or pathname-designator null) defaults) (type (member :common :local) case)) (let* ((defaults (when defaults diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index a78cf36..9f0026c 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -247,6 +247,33 @@ ;;;; primitive translator for BYTE-BLT (def-primitive-translator byte-blt (src src-start dst dst-start dst-end) + + ;; new version + ;; + ;; FIXME: CMU CL had a hairier implementation of this. It had the + ;; small problem that it didn't work for large (>16M) values of + ;; SRC-START or DST-START. However, it might have been more + ;; efficient. In particular, I haven't checked how much the foreign + ;; function call costs us here. My guess is that if the overhead is + ;; acceptable for SQRT and COS, it's acceptable here, but this + ;; should probably be checked. -- WHN + (once-only ((dst-start dst-start)) + `(flet ((sap (thing) + (etypecase thing + (system-area-pointer thing) + ((simple-unboxed-array (*)) (vector-sap thing))))) + (declare (inline sap)) + (without-gcing + (memmove (sap+ (sap ,dst) ,dst-start) + (sap+ (sap ,src) ,src-start) + (- ,dst-end ,dst-start))))) + + ;; REMOVEME when new version works + ;; + ;; old version, had overflow problems because it converts byte + ;; indices to bit indices, which is not good when GENESIS is trying + ;; to read into a byte vector which represents the cold image (>16M bytes) + #+nil `(let ((src ,src) (src-start (* ,src-start sb!vm:byte-bits)) (dst ,dst) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index d6352fb..339db89 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3318,7 +3318,7 @@ ;;;; N-arg arithmetic and logic functions are associated into two-arg ;;;; versions, and degenerate cases are flushed. -;;; Left-associate First-Arg and More-Args using Function. +;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. (declaim (ftype (function (symbol t list) list) associate-arguments)) (defun associate-arguments (function first-arg more-args) (let ((next (rest more-args)) diff --git a/src/compiler/x86/sap.lisp b/src/compiler/x86/sap.lisp index 052b427..b9e6bcd 100644 --- a/src/compiler/x86/sap.lisp +++ b/src/compiler/x86/sap.lisp @@ -76,6 +76,12 @@ ;;;; SAP-INT and INT-SAP +;;; The function SAP-INT is used to generate an integer corresponding +;;; to the system area pointer, suitable for passing to the kernel +;;; interfaces (which want all addresses specified as integers). The +;;; function INT-SAP is used to do the opposite conversion. The +;;; integer representation of a SAP is the byte offset of the SAP from +;;; the start of the address space. (define-vop (sap-int) (:args (sap :scs (sap-reg) :target int)) (:arg-types system-area-pointer) @@ -85,7 +91,6 @@ (:policy :fast-safe) (:generator 1 (move int sap))) - (define-vop (int-sap) (:args (int :scs (unsigned-reg) :target sap)) (:arg-types unsigned-num) diff --git a/src/runtime/ldso-stubs.S b/src/runtime/ldso-stubs.S index eacfdb2..772bd15 100644 --- a/src/runtime/ldso-stubs.S +++ b/src/runtime/ldso-stubs.S @@ -95,6 +95,7 @@ ldso_stub__ ## fct: ; \ LDSO_STUBIFY(lseek) LDSO_STUBIFY(lstat) LDSO_STUBIFY(malloc) + LDSO_STUBIFY(memmove) LDSO_STUBIFY(mkdir) LDSO_STUBIFY(open) LDSO_STUBIFY(opendir) @@ -515,7 +516,6 @@ ldso_stub__ ## fct: ; \ /* LDSO_STUBIFY(memcpy) */ /* LDSO_STUBIFY(memfrob) */ /* LDSO_STUBIFY(memmem) */ -/* LDSO_STUBIFY(memmove) */ /* LDSO_STUBIFY(memset) */ /* LDSO_STUBIFY(mkdir) */ /* LDSO_STUBIFY(mkfifo) */ diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 8b2eeaa..12a5946 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -172,6 +172,8 @@ ("code/target-c-call" :not-host) ("code/target-allocate" :not-host) + ("code/misc-aliens" :not-host) ; needs DEF-ALIEN-ROUTINE from target-alieneval + ("code/array" :not-host) ("code/target-sxhash" :not-host) diff --git a/version.lisp-expr b/version.lisp-expr index c895cb4..0a87c61 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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.11.26" +"0.6.11.27"