(defun hexstr (thing)
(/noshow0 "entering HEXSTR")
(let ((addr (get-lisp-obj-address thing))
- (str (make-string 10)))
+ (str (make-string 10 :element-type 'base-char)))
(/noshow0 "ADDR and STR calculated")
(setf (char str 0) #\0
(char str 1) #\x)
'fixnum)
(t
'integer)))
+ ((subtypep raw-result 'simple-string)
+ `(simple-base-string ,(length object)))
+ ((subtypep raw-result 'string) 'base-string)
((some (lambda (type) (subtypep raw-result type))
'(array character list symbol))
raw-result)
(start start)
(end (%check-vector-sequence-bounds string start end)))
(unless *read-from-string-spares*
- (push (internal-make-string-input-stream "" 0 0)
- *read-from-string-spares*))
+ (push (make-string-input-stream "" 0 0) *read-from-string-spares*))
(let ((stream (pop *read-from-string-spares*)))
- (setf (string-input-stream-string stream) string)
+ (setf (string-input-stream-string stream)
+ (coerce string '(simple-array character (*))))
(setf (string-input-stream-current stream) start)
(setf (string-input-stream-end stream) end)
(unwind-protect
(declare (simple-string s))
(let ((n (length s)))
;; Blast the string into place.
- (sb-kernel:copy-to-system-area (the simple-string s)
+ (sb-kernel:copy-to-system-area (the simple-base-string
+ ;; FIXME
+ (coerce s 'simple-base-string))
(* sb-vm:vector-data-offset
sb-vm:n-word-bits)
string-sap 0
;;; stream.
(defun copy-descriptor-to-stream (descriptor stream cookie)
(incf (car cookie))
- (let ((string (make-string 256))
+ (let ((string (make-string 256 :element-type 'base-char))
handler)
(setf handler
(sb-sys:add-fd-handler
;; Use /dev/null.
(multiple-value-bind
(fd errno)
- (sb-unix:unix-open "/dev/null"
+ (sb-unix:unix-open #.(coerce "/dev/null" 'base-string)
(case direction
(:input sb-unix:o_rdonly)
(:output sb-unix:o_wronly)
(dotimes (count
256
(error "could not open a temporary file in /tmp"))
- (let* ((name (format nil "/tmp/.run-program-~D" count))
+ (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string))
(fd (sb-unix:unix-open name
(logior sb-unix:o_rdwr
sb-unix:o_creat
(element-type (string-output-stream-element-type stream))
(result
(case element-type
- ;; Overwhelmingly common case; can be inlined.
+ ;; overwhelmingly common case: can be inlined
((character) (make-string length))
+ ;; slightly less common cases: inline it anyway
+ ((base-char standard-char)
+ (make-string length :element-type 'base-char))
(t (make-string length :element-type element-type)))))
;; For the benefit of the REPLACE transform, let's do this, so
;; that the common case isn't ludicrously expensive.
(etypecase result
((simple-array character (*))
(replace result (string-output-stream-string stream)))
+ (simple-base-string
+ (replace result (string-output-stream-string stream)))
((simple-array nil (*))
(replace result (string-output-stream-string stream))))
(setf (string-output-stream-index stream) 0
;;; the CLM, but they are required for the implementation of
;;; WITH-OUTPUT-TO-STRING.
+;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL),
+;;; ideally without destroying all hope of efficiency.
(deftype string-with-fill-pointer ()
'(and (vector character)
(satisfies array-has-fill-pointer-p)))
(if (= offset-current end)
(let* ((new-length (1+ (* current 2)))
(new-workspace (make-string new-length)))
- (declare (simple-string new-workspace))
- (%byte-blt workspace start
- new-workspace 0 current)
+ (declare (type (simple-array character (*)) new-workspace))
+ (replace new-workspace workspace
+ :start2 start :end2 offset-current)
(setf workspace new-workspace
offset-current current)
(set-array-header buffer workspace new-length
(let* ((new-length (+ (the fixnum (* current 2)) string-len))
(new-workspace (make-string new-length)))
(declare (type (simple-array character (*)) new-workspace))
- (%byte-blt workspace dst-start
- new-workspace 0 current)
- (setf workspace new-workspace)
- (setf offset-current current)
- (setf offset-dst-end dst-end)
- (set-array-header buffer
- workspace
- new-length
- dst-end
- 0
- new-length
- nil))
+ (replace new-workspace workspace
+ :start2 dst-start :end2 offset-current)
+ (setf workspace new-workspace
+ offset-current current
+ offset-dst-end dst-end)
+ (set-array-header buffer workspace new-length
+ dst-end 0 new-length nil))
(setf (fill-pointer buffer) dst-end))
- (%byte-blt string start
- workspace offset-current offset-dst-end)))
+ (replace workspace string
+ :start1 offset-current :start2 start :end2 end)))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
(let ((namestring (handler-case (namestring pathname)
(error nil))))
(if namestring
- (format stream "#P~S" namestring)
+ (format stream "#P~S" (coerce namestring '(simple-array character (*))))
(print-unreadable-object (pathname stream :type t)
(format stream
"~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
'single-stack
(* 2 (- stack-frame-size 6))))))
-
-
(define-alien-type-method (integer :result-tn) (type state)
(declare (ignore state))
(multiple-value-bind
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
;;; occure in the symbol table (for example, prepending an
;;; underscore).
(defun extern-alien-name (name)
- (declare (type simple-base-string name))
- ;; On the Alpha we don't do anything.
- name)
+ (declare (type string name))
+ ;; ELF ports currently don't need any prefix
+ (typecase name
+ (simple-base-string name)
+ (base-string (coerce name 'simple-base-string))
+ (t (handler-case (coerce name 'simple-base-string)
+ (type-error () (error "invalid external alien name: ~S" name))))))
\f
;;;; copying simple objects into the cold core
-(defun string-to-core (string &optional (gspace *dynamic*))
+(defun base-string-to-core (string &optional (gspace *dynamic*))
#!+sb-doc
- "Copy string into the cold core and return a descriptor to it."
+ "Copy STRING (which must only contain STANDARD-CHARs) into the cold
+core and return a descriptor to it."
;; (Remember that the system convention for storage of strings leaves an
;; extra null byte at the end to aid in call-out to C.)
(let* ((length (length string))
(make-fixnum-descriptor 0))
(write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
(write-wordindexed symbol sb!vm:symbol-name-slot
- (string-to-core name *dynamic*))
+ (base-string-to-core name *dynamic*))
(write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
symbol))
;; because that's the way CMU CL did it; I'm
;; not sure whether there's an underlying
;; reason. -- WHN 1990826
- (string-to-core "NIL" *dynamic*))
+ (base-string-to-core "NIL" *dynamic*))
(write-wordindexed des
(+ 1 sb!vm:symbol-package-slot)
result)
(let* ((cold-package (car cold-package-symbols-entry))
(symbols (cdr cold-package-symbols-entry))
(shadows (package-shadowing-symbols cold-package))
- (documentation (string-to-core (documentation cold-package t)))
+ (documentation (base-string-to-core (documentation cold-package t)))
(internal *nil-descriptor*)
(external *nil-descriptor*)
(imported-internal *nil-descriptor*)
(res *nil-descriptor*))
(dolist (u (package-use-list pkg))
(when (assoc u *cold-package-symbols*)
- (cold-push (string-to-core (package-name u)) use)))
+ (cold-push (base-string-to-core (package-name u)) use)))
(let* ((pkg-name (package-name pkg))
;; Make the package nickname lists for the standard packages
;; be the minimum specified by ANSI, regardless of what value
(t
(package-nicknames pkg)))))
(dolist (warm-nickname warm-nicknames)
- (cold-push (string-to-core warm-nickname) cold-nicknames)))
+ (cold-push (base-string-to-core warm-nickname) cold-nicknames)))
(cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
0.8))
(cold-push use res)
(cold-push (cold-intern :use) res)
- (cold-push (string-to-core (package-name pkg)) res)
+ (cold-push (base-string-to-core (package-name pkg)) res)
res))
\f
;;;; functions and fdefinition objects
(defun foreign-symbols-to-core ()
(let ((result *nil-descriptor*))
(maphash (lambda (symbol value)
- (cold-push (cold-cons (string-to-core symbol)
+ (cold-push (cold-cons (base-string-to-core symbol)
(number-to-core value))
result))
*cold-foreign-symbol-table*)
(let* ((len (clone-arg))
(string (make-string len)))
(read-string-as-bytes *fasl-input-stream* string)
- (string-to-core string)))
+ (base-string-to-core string)))
(clone-cold-fop (fop-vector)
(fop-small-vector)
+;;;; VOPs and other machine-specific support routines for call-out to C
+
+;;;; 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!VM")
(defun my-make-wired-tn (prim-type-name sc-name offset)
:result-tn
(alien-fun-type-result-type type)))))
-
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
-
(define-vop (alloc-number-stack-space)
(:info amount)
(:results (result :scs (sap-reg any-reg)))
;;; occure in the symbol table (for example, prepending an
;;; underscore). On the HPPA we just leave it alone.
(defun extern-alien-name (name)
- (declare (type simple-base-string name))
- name)
+ (declare (type string name))
+ ;; ELF ports currently don't need any prefix
+ (typecase name
+ (simple-base-string name)
+ (base-string (coerce name 'simple-base-string))
+ (t (handler-case (coerce name 'simple-base-string)
+ (type-error () (error "invalid external alien name: ~S" name))))))
+;;;; VOPs and other machine-specific support routines for call-out to C
+
+;;;; 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!VM")
(defun my-make-wired-tn (prim-type-name sc-name offset)
'single-int-carg-reg
(+ stack-frame-size 4))))))
-
(defstruct result-state
(num-results 0))
(alien-fun-type-result-type type)
(make-result-state))))))
-
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(immediate-constant "Immed"))))
(defun extern-alien-name (name)
- (declare (type simple-base-string name))
- name)
+ (declare (type string name))
+ ;; ELF ports currently don't need any prefix
+ (typecase name
+ (simple-base-string name)
+ (base-string (coerce name 'simple-base-string))
+ (t (handler-case (coerce name 'simple-base-string)
+ (type-error () (error "invalid external alien name: ~S" name))))))
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(immediate-constant "Immed"))))
\f
;;; The loader uses this to convert alien names to the form they
-;;; occur in the symbol table. This is ELF, so do nothing.
+;;; occur in the symbol table.
(defun extern-alien-name (name)
- (declare (type simple-base-string name))
- ;; Darwin is non-ELF, and needs a _ prefix
- #!+darwin (concatenate 'string "_" name)
- ;; The other (ELF) ports currently don't need any prefix
- #!-darwin name)
+ (declare (type string name))
+ ;; Darwin is non-ELF, and needs a _ prefix. The other (ELF) ports
+ ;; currently don't need any prefix.
+ (flet ((maybe-prefix (name)
+ #!+darwin (concatenate 'simple-base-string "_" name)
+ #!-darwin name))
+ (typecase name
+ (simple-base-string (maybe-prefix name))
+ (base-string (coerce (maybe-prefix name) 'simple-base-string))
+ (t
+ (handler-case (coerce (maybe-prefix name) 'simple-base-string)
+ (type-error ()
+ (error "invalid external alien name: ~S" name)))))))
(declare (ignore rtype))
(let* (,@lets
(res (make-string (truncate (the index (+ ,@all-lengths))
- sb!vm:n-byte-bits))))
+ sb!vm:n-byte-bits)
+ :element-type 'base-char)))
(declare (type index ,@all-lengths))
(let (,@(mapcar (lambda (name) `(,name 0)) starts))
(declare (type index ,@starts))
;;; occure in the symbol table (for example, prepending an
;;; underscore). On the SPARC, we don't prepend an underscore.
(defun extern-alien-name (name)
- (declare (type simple-base-string name))
- (concatenate 'string #+nil "_" name))
+ (declare (type string name))
+ ;; ELF ports currently don't need any prefix
+ (typecase name
+ (simple-base-string name)
+ (base-string (coerce name 'simple-base-string))
+ (t (handler-case (coerce name 'simple-base-string)
+ (type-error () (error "invalid external alien name: ~S" name))))))
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
;;; The loader uses this to convert alien names to the form they need in
;;; the symbol table (for example, prepending an underscore).
(defun extern-alien-name (name)
- (declare (type simple-base-string name))
+ (declare (type string name))
;; ELF ports currently don't need any prefix
- name)
+ (typecase name
+ (simple-base-string name)
+ (base-string (coerce name 'simple-base-string))
+ (t (handler-case (coerce name 'simple-base-string)
+ (type-error () (error "invalid external alien name: ~S" name))))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.16.21"
+"0.8.16.22"
projects / sbcl.git / commitdiff