X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=7e9b25e6b68a44a7e1c642572891990bea1553d9;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=c66e364fde4afd5c0f444e80b09d324a472a073c;hpb=3352db3a8b45bc544473915ef25a4708f386be36;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index c66e364..7e9b25e 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -35,22 +35,32 @@ ;;; guess the other. (eval-when (:compile-toplevel :load-toplevel :execute) (defun pick-lisp-and-alien-names (name) - (etypecase name - (string - (values (guess-lisp-name-from-alien-name name) name)) - (symbol - (values name (guess-alien-name-from-lisp-name name))) - (list - (unless (proper-list-of-length-p name 2) - (error "badly formed alien name")) - (values (cadr name) (car name)))))) + (flet ((oops () + (error "~@<~:IMalformed alien name. Acceptable formats are:~ + ~:@_ (\"alien_name\" LISP-NAME)~ + ~:@_ FOO-BAR - equivalent to (\"foo_bar\" FOO-BAR)~ + ~:@_ \"foo_bar\" - equivalent to (\"foo_bar\" FOO-BAR)~:@>"))) + (etypecase name + (string + (values (guess-lisp-name-from-alien-name name) + (coerce name 'simple-string))) + (symbol + (values name (guess-alien-name-from-lisp-name name))) + (list + (unless (and (proper-list-of-length-p name 2) + (symbolp (second name)) + (stringp (first name))) + (oops)) + (values (second name) (coerce (first name) 'simple-string))) + (t + (oops)))))) (defmacro define-alien-variable (name type &environment env) #!+sb-doc - "Define NAME as an external alien variable of type TYPE. NAME should be - a list of a string holding the alien name and a symbol to use as the Lisp - name. If NAME is just a symbol or string, then the other name is guessed - from the one supplied." + "Define NAME as an external alien variable of type TYPE. NAME should +be a list of a string holding the alien name and a symbol to use as +the Lisp name. If NAME is just a symbol or string, then the other name +is guessed from the one supplied." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (with-auxiliary-alien-types env (let ((alien-type (parse-alien-type type env))) @@ -68,7 +78,8 @@ (setf (info :variable :where-from lisp-name) :defined) (setf (info :variable :alien-info lisp-name) (make-heap-alien-info :type type - :sap-form `(foreign-symbol-sap ',alien-name t))))) + :alien-name alien-name + :datap t)))) (defun alien-value (symbol) #!+sb-doc @@ -80,16 +91,14 @@ variable is undefined." (defmacro extern-alien (name type &environment env) #!+sb-doc - "Access the alien variable named NAME, assuming it is of type TYPE. This - is SETFable." + "Access the alien variable named NAME, assuming it is of type TYPE. +This is SETFable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type env)) (datap (not (alien-fun-type-p alien-type)))) - `(%heap-alien ',(make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',alien-name ,datap))))) + `(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -144,13 +153,11 @@ variable is undefined." ,@body))))) (:extern (/show0 ":EXTERN case") - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',initial-value - ,datap)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) + `((symbol-macrolet + ((,symbol + (%alien-value + (foreign-symbol-sap ,initial-value ,datap) 0 ,alien-type))) + ,@body))) (:local (/show0 ":LOCAL case") (let* ((var (sb!xc:gensym "VAR")) @@ -399,9 +406,9 @@ null byte. (slot (deref alien) slot)) (alien-record-type (let ((field (slot-or-lose type slot))) - (extract-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field))))))) + (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field))))))) ;;; Deposit the value in the specified slot of the record ALIEN. If ;;; the ALIEN is really a pointer, DEREF it first. The compiler uses @@ -416,10 +423,10 @@ null byte. (%set-slot (deref alien) slot value)) (alien-record-type (let ((field (slot-or-lose type slot))) - (deposit-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field) - value)))))) + (setf (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field)) + value)))))) ;;; Compute the address of the specified slot and return a pointer to it. (defun %slot-addr (alien slot) @@ -489,19 +496,19 @@ null byte. (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (extract-alien-value (alien-value-sap alien) - offset - target-type))) + (%alien-value (alien-value-sap alien) + offset + target-type))) (defun %set-deref (alien value &rest indices) (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (deposit-alien-value (alien-value-sap alien) - offset - target-type - value))) + (setf (%alien-value (alien-value-sap alien) + offset + target-type) + value))) (defun %deref-addr (alien &rest indices) (declare (type alien-value alien) @@ -516,22 +523,22 @@ null byte. (defun %heap-alien (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (extract-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info))) + (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info))) (defun %set-heap-alien (info value) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (deposit-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info) - value)) + (setf (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info)) + value)) (defun %heap-alien-addr (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (%sap-alien (eval (heap-alien-info-sap-form info)) + (%sap-alien (heap-alien-info-sap info) (make-alien-pointer-type :to (heap-alien-info-type info)))) ;;;; accessing local aliens @@ -657,19 +664,19 @@ null byte. (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type)) value type)) -(defun extract-alien-value (sap offset type) +(defun %alien-value (sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce-to-interpreted-function (compute-extract-lambda type)) sap offset type)) -(defun deposit-alien-value (sap offset type value) +(defun (setf %alien-value) (value sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce-to-interpreted-function (compute-deposit-lambda type)) - sap offset type value)) + value sap offset type)) ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE