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

Fixed some problems with interpreted alien access.

parent a009feb3
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.3 1990/08/24 18:09:34 wlott Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.4 1990/10/03 15:01:15 ram Exp $
;;; ;;;
;;; This file contains any the part of the Alien implementation that ;;; This file contains any the part of the Alien implementation that
;;; is not part of the compiler. ;;; is not part of the compiler.
...@@ -920,10 +920,10 @@ ...@@ -920,10 +920,10 @@
((:minimum smin) nil) ((:minimum smin) nil)
((:unit sunit) 32)) ((:unit sunit) 32))
&body (body decls)) &body (body decls))
(%with-alien sap offset ounit (%with-alien sap offset ounit
size sconst smin sunit size sconst smin sunit
',n-sap ',n-offset ',n-size ',n-sap ',n-offset ',n-size
body decls))) body decls)))
,@body))) ,@body)))
#-new-compiler #-new-compiler
(eval-when (compile) (eval-when (compile)
...@@ -945,10 +945,10 @@ ...@@ -945,10 +945,10 @@
`(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit)) `(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit))
(,',n-scaled-size (/ ,,n-size ,,sunit))) (,',n-scaled-size (/ ,,n-size ,,sunit)))
,',n-scaled-size ; Ignorable... ,',n-scaled-size ; Ignorable...
,@',(when sconst ,,@(when sconst
`((check= ,n-scaled-size ,sconst))) `(`(check= ,',n-scaled-size ,,sconst)))
,@',(when smin ,,@(when smin
`((check<= ,smin ,n-scaled-size))) `(`(check<= ,,smin ,',n-scaled-size)))
,,@body)))) ,,@body))))
); Eval-When (Compile Load Eval) ); Eval-When (Compile Load Eval)
...@@ -986,22 +986,24 @@ ...@@ -986,22 +986,24 @@
;;; ;;;
(defun %set-alien-access (alien lisp-type &optional (new-value nil nvp)) (defun %set-alien-access (alien lisp-type &optional (new-value nil nvp))
(declare (type alien-value alien)) (declare (type alien-value alien))
(let* ((lisp-type (if nvp lisp-type nil)) (multiple-value-bind (lisp-type new-value)
(new-value (if nvp new-value lisp-type)) (if nvp
(alien-type (alien-value-type alien)) (values lisp-type new-value)
(access (get-alien-access-method alien-type lisp-type)) (values nil lisp-type))
(n-sap (gensym)) (let* ((alien-type (alien-value-type alien))
(n-offset (gensym)) (access (get-alien-access-method alien-type lisp-type))
(n-size (gensym)) (n-sap (gensym))
(n-nval (gensym))) (n-offset (gensym))
(eval (n-size (gensym))
`(let ((,n-sap ',(alien-value-sap alien)) (n-nval (gensym)))
(,n-offset ',(alien-value-offset alien)) (eval
(,n-size ',(alien-value-size alien)) `(let ((,n-sap ',(alien-value-sap alien))
(,n-nval ,new-value)) (,n-offset ',(alien-value-offset alien))
,(funcall access n-sap n-offset n-size alien-type :write n-nval (,n-size ',(alien-value-size alien))
'(setf alien-access)))) (,n-nval ,new-value))
new-value)) ,(funcall access n-sap n-offset n-size alien-type :write n-nval
'(setf alien-access))))
new-value)))
;;;; Miscellaneous alien access methods: ;;;; Miscellaneous alien access methods:
......
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