diff --git a/code/alieneval.lisp b/code/alieneval.lisp index e6a68fa4a66c4441cd7bfa279c81710bdd8dec61..ce165502a7c7183fa51640afb3f0ccb5b970b44d 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.24 1992/03/10 11:24:05 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.25 1992/03/10 12:52:31 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -38,6 +38,9 @@ alien-integer-type alien-integer-type-p alien-integer-type-signed alien-boolean-type alien-boolean-type-p alien-enum-type alien-enum-type-p + alien-float-type alien-float-type-p + alien-single-float-type alien-single-float-type-p + alien-double-float-type alien-double-float-type-p alien-pointer-type alien-pointer-type-p alien-pointer-type-to make-alien-pointer-type alien-array-type alien-array-type-p alien-array-type-element-type @@ -45,9 +48,10 @@ alien-record-type alien-record-type-p alien-record-type-fields alien-record-field alien-record-field-p alien-record-field-name alien-record-field-type alien-record-field-offset - alien-function-type alien-function-type-p + alien-function-type alien-function-type-p make-alien-function-type alien-function-type-result-type alien-function-type-arg-types alien-values-type alien-values-type-p alien-values-type-values + *values-type-okay* %set-slot %slot-addr %set-deref %deref-addr @@ -79,6 +83,9 @@ alien-integer-type alien-integer-type-p alien-integer-type-signed alien-boolean-type alien-boolean-type-p alien-enum-type alien-enum-type-p + alien-float-type alien-float-type-p + alien-single-float-type alien-single-float-type-p + alien-double-float-type alien-double-float-type-p alien-pointer-type alien-pointer-type-p alien-pointer-type-to make-alien-pointer-type alien-array-type alien-array-type-p alien-array-type-element-type @@ -86,9 +93,10 @@ alien-record-type alien-record-type-p alien-record-type-fields alien-record-field alien-record-field-p alien-record-field-name alien-record-field-type alien-record-field-offset - alien-function-type alien-function-type-p + alien-function-type alien-function-type-p make-alien-function-type alien-function-type-result-type alien-function-type-arg-types alien-values-type alien-values-type-p alien-values-type-values + *values-type-okay* %set-slot %slot-addr %set-deref %deref-addr @@ -136,7 +144,6 @@ (include nil :type (or null alien-type-class)) (unparse nil :type (or null function)) (type= nil :type (or null function)) - ;; subtypep? (lisp-rep nil :type (or null function)) (alien-rep nil :type (or null function)) (extract-gen nil :type (or null function)) @@ -145,7 +152,8 @@ (deport-gen nil :type (or null function)) ;; Cast? (arg-tn nil :type (or null function)) - (result-tn nil :type (or null function))) + (result-tn nil :type (or null function)) + (subtypep nil :type (or null function))) (defun %print-alien-type-class (type-class stream depth) (declare (ignore depth)) @@ -164,12 +172,12 @@ (if old (setf (alien-type-class-include old) include) (setf (gethash name *alien-type-classes*) - (make-alien-type-class :include include))))) + (make-alien-type-class :name name :include include))))) (defconstant method-slot-alist '((:unparse . alien-type-class-unparse) (:type= . alien-type-class-type=) - ;; subtypep? + (:subtypep . alien-type-class-subtypep) (:lisp-rep . alien-type-class-lisp-rep) (:alien-rep . alien-type-class-alien-rep) (:extract-gen . alien-type-class-extract-gen) @@ -461,19 +469,8 @@ subtype of (* t), and any array type first dimension will match (array <eltype> nil ...). Otherwise, the two types have to be ALIEN-TYPE-=." - (typecase type1 - (alien-pointer-type - (and (alien-pointer-type-p type2) - (or (null (alien-pointer-type-to type2)) - (alien-type-= type1 type2)))) - (alien-array-type - (and (alien-array-type-p type2) - (let ((dims (alien-array-type-dimensions type2))) - (or (and dims (null (first dims))) - (alien-type-= type1 type2))))) - (t - (alien-type-= type1 type2)))) - + (or (eq type1 type2) + (invoke-alien-type-method :subtypep type1 type2))) (defun alien-typep (object type) "Return T iff OBJECT is an alien of type TYPE." @@ -544,6 +541,9 @@ (declare (ignore type1 type2)) t) +(def-alien-type-method (root :subtypep) (type1 type2) + (alien-type-= type1 type2)) + (def-alien-type-method (root :lisp-rep) (type) (declare (ignore type)) nil) @@ -834,39 +834,39 @@ ;;;; The SAP type -(def-alien-type-class (sap)) +(def-alien-type-class (system-area-pointer)) (def-alien-type-translator system-area-pointer () - (make-alien-sap-type :bits vm:word-bits)) + (make-alien-system-area-pointer-type :bits vm:word-bits)) -(def-alien-type-method (sap :unparse) (type) +(def-alien-type-method (system-area-pointer :unparse) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (sap :lisp-rep) (type) +(def-alien-type-method (system-area-pointer :lisp-rep) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (sap :alien-rep) (type) +(def-alien-type-method (system-area-pointer :alien-rep) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (sap :naturalize-gen) (type alien) +(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (sap :deport-gen) (type object) +(def-alien-type-method (system-area-pointer :deport-gen) (type object) (declare (ignore type)) object) -(def-alien-type-method (sap :extract-gen) (type sap offset) +(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset) (declare (ignore type)) `(sap-ref-sap ,sap (/ ,offset vm:byte-bits))) ;;;; the ALIEN-VALUE type. -(def-alien-type-class (alien-value :include sap)) +(def-alien-type-class (alien-value :include system-area-pointer)) (def-alien-type-method (alien-value :lisp-rep) (type) (declare (ignore type)) @@ -904,6 +904,16 @@ nil) (null to2)))) +(def-alien-type-method (pointer :subtypep) (type1 type2) + (and (alien-pointer-type-p type2) + (let ((to1 (alien-pointer-type-to type1)) + (to2 (alien-pointer-type-to type2))) + (if to1 + (if to2 + (alien-subtype-p to1 to2) + t) + nil)))) + (def-alien-type-method (pointer :deport-gen) (type value) (values `(etypecase ,value @@ -968,6 +978,17 @@ (alien-type-= (alien-array-type-element-type type1) (alien-array-type-element-type type2)))) +(def-alien-type-method (array :subtypep) (type1 type2) + (and (alien-array-type-p type2) + (let ((dim1 (alien-array-type-dimensions type1)) + (dim2 (alien-array-type-dimensions type2))) + (and (= (length dim1) (length dim2)) + (or (and dim2 + (null (car dim2)) + (equal (cdr dim1) (cdr dim2))) + (equal dim1 dim2)) + (alien-subtype-p (alien-array-type-element-type type1) + (alien-array-type-element-type type2)))))) ;;;; The RECORD type. @@ -1133,7 +1154,6 @@ (alien-function-type-arg-types type2)))) - (def-alien-type-class (values) (values (required-argument) :type list)) @@ -1464,7 +1484,7 @@ by MAKE-ALIEN or ``malloc''." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) (alien-sap alien)) - nil)) + nil) ;;;; The SLOT operator