- (let ((size (gensym))
- (storage (gensym))
- (stored-obj (gensym))
- (i (gensym)))
- `(let ((,stored-obj ,obj))
- (etypecase ,stored-obj
- (null
- (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
- (string
- (let* ((,size (length ,stored-obj))
- (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
- (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (alien:deref ,storage ,i)
- (char-code (char ,stored-obj ,i))))
- (setf (alien:deref ,storage ,size) 0))
- ,storage)))))
- #+sbcl
- (let ((size (gensym))
- (storage (gensym))
- (stored-obj (gensym))
- (i (gensym)))
- `(let ((,stored-obj ,obj))
- (etypecase ,stored-obj
- (null
- (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
- (string
- (let* ((,size (length ,stored-obj))
- (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
- (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (sb-alien:deref ,storage ,i)
- (char-code (char ,stored-obj ,i))))
- (setf (sb-alien:deref ,storage ,size) 0))
- ,storage)))))
- #+(or openmcl digitool)
- (let ((stored-obj (gensym)))
- `(let ((,stored-obj ,obj))
- (if (null ,stored-obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
- (ccl::%put-cstring ptr ,stored-obj)
- ptr))))
+ (etypecase str
+ (null
+ (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+ (string
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((size (length str))
+ (storage (alien:make-alien (alien:unsigned 8) (1+ size))))
+ (declare (fixnum size))
+ (setq storage (alien:cast storage (* (alien:unsigned 8))))
+ (dotimes (i size)
+ (declare (fixnum i))
+ (setf (alien:deref storage i)
+ (char-code (char str i))))
+ (setf (alien:deref storage size) 0)
+ storage))))
+
+ #+(and sbcl (not sb-unicode))
+ (etypecase str
+ (null
+ (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+ (string
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((size (length str))
+ (storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ size))))
+ (declare (fixnum i))
+ (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
+ (dotimes (i size)
+ (declare (fixnum i))
+ (setf (sb-alien:deref storage i)
+ (char-code (char str i))))
+ (setf (sb-alien:deref storage size) 0))
+ storage)))
+
+ #+(and sbcl sb-unicode)
+ (etypecase str
+ (null
+ (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+ (string
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((fe (or encoding *default-foreign-encoding*))
+ (ife (when fe (lookup-foreign-encoding fe))))
+ (if ife
+ (let* ((octets (sb-ext:string-to-octets str :external-format ife))
+ (size (length octets))
+ (storage (sb-alien:make-alien (sb-alien:unsigned 8) (+ size 2))))
+ (declare (fixnum size))
+ (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
+ (dotimes (i size)
+ (declare (fixnum i))
+ (setf (sb-alien:deref storage i) (svref octets i)))
+ ;; terminate with 2 nulls, maybe needed for some encodings
+ (setf (sb-alien:deref storage size) 0)
+ (setf (sb-alien:deref storage (1+ size)) 0)
+ storage)
+
+ (let* ((size (length str))
+ (storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ size))))
+ (declare (fixnum size))
+ (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
+ (dotimes (i size)
+ (declare (fixnum i))
+ (setf (sb-alien:deref storage i)
+ (char-code (char str i))))
+ (setf (sb-alien:deref storage size) 0)
+ storage))))))
+
+ #+(and openmcl openmcl-unicode-strings)
+ (if (null str)
+ +null-cstring-pointer+
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((fe (or encoding *default-foreign-encoding*))
+ (ife (when fe (lookup-foreign-encoding fe))))
+ (if ife
+ (let* ((octets (ccl:encode-string-to-octets str :external-format ife))
+ (size (length octets))
+ (ptr (new-ptr (+ size 2))))
+ (declare (fixnum size))
+ (dotimes (i size)
+ (declare (fixnum i))
+ (setf (ccl:%get-unsigned-byte ptr i) (svref octets i)))
+ (setf (ccl:%get-unsigned-byte ptr size) 0)
+ (setf (ccl:%get-unsigned-byte ptr (1+ size)) 0)
+ ptr)
+
+ (let ((ptr (new-ptr (1+ (length str)))))
+ (ccl::%put-cstring ptr str)
+ ptr)))))
+
+ #+(or digitool (and openmcl (not openmcl-unicode-strings)))
+ (if (null str)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length str)))))
+ (ccl::%put-cstring ptr str)
+ ptr))
+
+ #+(or allegro lispworks)
+ nil