Skip to content
Snippets Groups Projects
Commit d6a0826f authored by ram's avatar ram
Browse files

Export SYSTEM-AREA-POINTER from ALIEN for consistency.

Export MAKE-ALIEN and FREE-ALIEN from ALIEN.
Export ALIEN-VALUE-TYPE from ALIEN-INTERNALS so that TYPE-OF can use it.
Changed ALIEN-VALUE printer to be less verbose.
Implemented %MAKE-ALIEN and FREE-ALIEN using malloc/free.  Changed MAKE-ALIEN
to accept an alien-type object as well as an Alien type descriptor.
Now that we've implemented FREE-ALIEN, finalize the Aliens created by
interpreted WITH-ALIEN. 
Added an (OPTIMIZE-INTERFACE (SAFETY 2)) declaration on %CAST so that we get a
better type error message.
parent 38e0574b
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.20 1992/03/04 09:05:53 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.21 1992/03/04 17:50:58 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -19,16 +19,16 @@ ...@@ -19,16 +19,16 @@
(use-package "SYSTEM") (use-package "SYSTEM")
(export '(alien * array struct union enum function integer signed unsigned (export '(alien * array struct union enum function integer signed unsigned
boolean values single-float double-float boolean values single-float double-float system-area-pointer
def-alien-type def-alien-variable sap-alien def-alien-type def-alien-variable sap-alien
extern-alien with-alien slot deref addr cast alien-sap alien-size extern-alien with-alien slot deref addr cast alien-sap alien-size
alien-funcall def-alien-routine)) alien-funcall def-alien-routine make-alien free-alien))
(in-package "ALIEN-INTERNALS") (in-package "ALIEN-INTERNALS")
(in-package "ALIEN") (in-package "ALIEN")
(export '(alien alien-value parse-alien-type unparse-alien-type (export '(alien alien-value alien-value-type parse-alien-type
alien-type-= alien-subtype-p alien-typep unparse-alien-type alien-type-= alien-subtype-p alien-typep
def-alien-type-class def-alien-type-translator def-alien-type-method def-alien-type-class def-alien-type-translator def-alien-type-method
invoke-alien-type-method invoke-alien-type-method
...@@ -1321,7 +1321,7 @@ ...@@ -1321,7 +1321,7 @@
(defun %print-alien-value (value stream depth) (defun %print-alien-value (value stream depth)
(declare (ignore depth)) (declare (ignore depth))
(print-unreadable-object (value stream) (print-unreadable-object (value stream)
(funcall (formatter "Alien-Value of type ~S: #x~8,'0X") (funcall (formatter "Alien ~S at #x~8,'0X")
stream stream
(unparse-alien-type (alien-value-type value)) (unparse-alien-type (alien-value-type value))
(sap-int (alien-value-sap value))))) (sap-int (alien-value-sap value)))))
...@@ -1351,9 +1351,11 @@ ...@@ -1351,9 +1351,11 @@
(defmacro make-alien (type &optional size) (defmacro make-alien (type &optional size)
"Allocate an alien of type TYPE and return an alien pointer to it. If SIZE "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE
is supplied, how it is interpreted depends on TYPE. If TYPE is an array is supplied, how it is interpreted depends on TYPE. If TYPE is an array
type, SIZE is used as the first dimension for the allocated array. If type, SIZE is used as the first dimension for the allocated array. If TYPE
TYPE is not an array, then SIZE is the number of elements to allocate." is not an array, then SIZE is the number of elements to allocate. The
(let ((alien-type (parse-alien-type type))) memory is allocated using ``malloc'', so it can be passed to foreign
functions which use ``free''."
(let ((alien-type (if (alien-type-p type) type (parse-alien-type type))))
(multiple-value-bind (multiple-value-bind
(size-expr element-type) (size-expr element-type)
(if (alien-array-type-p alien-type) (if (alien-array-type-p alien-type)
...@@ -1390,17 +1392,18 @@ ...@@ -1390,17 +1392,18 @@
;;; area pointer to it. ;;; area pointer to it.
;;; ;;;
(defun %make-alien (bits) (defun %make-alien (bits)
(declare (ignore bits)) (declare (type kernel:index bits) (optimize-interface (safety 2)))
nil) (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
(ash (the kernel:index (+ bits 7)) -3)))
;;; FREE-ALIEN -- public ;;; FREE-ALIEN -- public
;;; ;;;
(defun free-alien (alien) (defun free-alien (alien)
"Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated
by MAKE-ALIEN." by MAKE-ALIEN or ``malloc''."
(let ((sap (alien-sap alien))) (alien-funcall (extern-alien "free" (function (values) system-area-pointer))
(declare (ignore sap)) (alien-sap alien))
nil)) nil))
;;;; The SLOT operator ;;;; The SLOT operator
...@@ -1598,7 +1601,6 @@ ...@@ -1598,7 +1601,6 @@
(defun make-local-alien (info) (defun make-local-alien (info)
(let ((alien (eval `(make-alien ,(local-alien-info-type info))))) (let ((alien (eval `(make-alien ,(local-alien-info-type info)))))
#+nil
(finalize info #'(lambda () (free-alien alien))) (finalize info #'(lambda () (free-alien alien)))
alien)) alien))
...@@ -1687,6 +1689,7 @@ ...@@ -1687,6 +1689,7 @@
(defun %cast (alien target-type) (defun %cast (alien target-type)
(declare (type alien-value alien) (declare (type alien-value alien)
(type alien-type target-type) (type alien-type target-type)
(optimize-interface (safety 2))
(optimize (inhibit-warnings 3))) (optimize (inhibit-warnings 3)))
(if (or (alien-pointer-type-p target-type) (if (or (alien-pointer-type-p target-type)
(alien-array-type-p target-type) (alien-array-type-p target-type)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment