Skip to content
Browse files

Add conditions and more type checks.

  • Loading branch information...
1 parent 512812b commit f13f0b6f57abb1a825deceb3c2d04c595441fa4c @Ramarren committed
Showing with 132 additions and 38 deletions.
  1. +2 −1 cffi-j.asd
  2. +57 −0 conditions.lisp
  3. +73 −37 wrapper.lisp
View
3 cffi-j.asd
@@ -8,4 +8,5 @@
:components ((:file "package")
(:file "bindings" :depends-on ("package" "jdll"))
(:file "jdll" :depends-on ("package"))
- (:file "wrapper" :depends-on ("package" "jdll" "bindings"))))
+ (:file "wrapper" :depends-on ("package" "jdll" "bindings" "conditions"))
+ (:file "conditions" :depends-on ("package"))))
View
57 conditions.lisp
@@ -0,0 +1,57 @@
+(in-package :cffi-j)
+
+(define-condition j-condition ()
+ ())
+
+(define-condition do-error (j-condition)
+ ((cmd :reader cmd-of :initarg :cmd)
+ (code :reader code-of :initarg :code))
+ (:report (lambda (c stream)
+ (format stream
+ "Error while executing J command:~s. Error code: ~a"
+ (cmd-of c)
+ (code-of c)))))
+
+(define-condition get-error (j-condition)
+ ((name :reader name-of :initarg :name)))
+
+(define-condition get-name-error (get-error)
+ ()
+ (:report (lambda (c stream)
+ (format stream
+ "Variable ~s is not a J-side noun."
+ (name-of c)))))
+
+(define-condition get-type-error (get-error)
+ ((type :reader noun-type-of :initarg :type))
+ (:report (lambda (c stream)
+ (format stream
+ "Can't retrieve noun ~a of type ~a"
+ (name-of c)
+ (noun-type-of c)))))
+
+(define-condition set-error (j-condition)
+ ((name :reader name-of :initarg :name)))
+
+(define-condition set-invalid-name (set-error)
+ ()
+ (:report (lambda (c stream)
+ (format stream "Name ~s is invalid." (name-of c)))))
+
+(define-condition set-non8bit-character (set-error)
+ ((char :reader char-of :initarg :char))
+ (:report (lambda (c stream)
+ (format stream "When setting variable ~s : Only 8-bit characters allowed. ~s is not."
+ (name-of c) (char-of c)))))
+
+(define-condition set-heterogeneous-array (set-error)
+ ((array :reader array-of :initarg :array))
+ (:report (lambda (c stream)
+ (format stream "When setting variable ~s : Arrays must have all elements of the same type."
+ (name-of c)))))
+
+(define-condition set-invalid-type (set-error)
+ ((type :reader noun-type-of :initarg :type))
+ (:report (lambda (c stream)
+ (format stream "When setting variable ~s : Type ~a cannot be encoded."
+ (name-of c) (noun-type-of c)))))
View
110 wrapper.lisp
@@ -11,16 +11,20 @@
(free-j *j*)
(setf *j* nil))
+(defun just-do (cmd)
+ (do-j *j* cmd))
+
(defun do (cmd)
"Execute J statement."
- (do-j *j* cmd))
+ (let ((code (just-do cmd)))
+ (if (zerop code)
+ :done
+ (error 'do-error :cmd cmd :code code))))
(defun cmd (cmd)
"Execute J statement and return the result. Will clobber `jdat` variable."
- (let ((do-code (do (format nil "jdat =: ~a" cmd))))
- (if (zerop do-code)
- (get-unsafe "jdat")
- :do-error)))
+ (do (format nil "jdat =: ~a" cmd))
+ (get-unsafe "jdat"))
(defun get-boxed (data array)
(declare (ignore data array))
@@ -28,14 +32,22 @@
(defun type-from-number (type-number)
(ecase type-number
- (1 :boolean)
- (2 :literal)
- (4 :integer)
- (8 :double)
- (16 :complex)
- (32 :boxed)
- (64 :extended-integer)
- (128 :rational)))
+ (1 :boolean)
+ (2 :literal)
+ (4 :integer)
+ (8 :double)
+ (16 :complex)
+ (32 :boxed)
+ (64 :extended-integer)
+ (128 :rational)
+ (1024 :sparse-boolean)
+ (2048 :sparse-literal)
+ (4096 :sparse-integer)
+ (8192 :sparse-floating-point)
+ (16384 :sparse-complex)
+ (32768 :sparse-boxed)
+ (65536 :symbol)
+ (131072 :unicode)))
(defun name-character (c)
(or (char<= #\a c #\z)
@@ -62,12 +74,16 @@
(shape :pointer)
(data :pointer))
(%get j name type rank shape data)
- (values (j-fix (mem-ref type :uint32)
- (mem-ref rank :uint32)
- (mem-ref shape :pointer)
- (mem-ref data :pointer))
- (type-from-number (mem-ref type :uint32))
- (mem-ref rank :uint32))))
+ (let ((noun-type (type-from-number (mem-ref type :uint32))))
+ (case noun-type
+ ((:boolean :literal :integer :double :complex :boxed :extended-integer)
+ (values (j-fix (mem-ref type :uint32)
+ (mem-ref rank :uint32)
+ (mem-ref shape :pointer)
+ (mem-ref data :pointer))
+ (type-from-number (mem-ref type :uint32))
+ (mem-ref rank :uint32)))
+ (otherwise (error 'get-type-error :name name :type noun-type))))))
(declaim (inline get-unsafe))
(defun get-unsafe (name)
@@ -76,7 +92,8 @@
(defun get (name)
"Get J variable `name`."
(if (eql (name-class name) :noun)
- (get-unsafe name)))
+ (get-unsafe name)
+ (error 'get-name-error :name name)))
(defun set-datum (datum data-ptr offset)
(etypecase datum
@@ -91,12 +108,13 @@
(mem-aref data-ptr :double (1+ (* 2 offset))) (coerce (imagpart datum) 'double-float)))))
(defun get-type-info (datum)
- (etypecase datum
+ (typecase datum
(boolean (values 1 :uint8))
(character (values 2 :uint8))
(integer (values 4 :uint32))
(float (values 8 :double))
- (complex (values 16 :double))))
+ (complex (values 16 :double))
+ (otherwise nil)))
(defun set-scalar (j name datum)
(with-foreign-objects ((type :uint32)
@@ -108,21 +126,31 @@
(setf (mem-ref data-ptr :pointer) f-data)
(%set j name type 0 (null-pointer) f-data)))))
+(defun array-typecheck (name data)
+ (unless (get-type-info (row-major-aref data 0))
+ (error 'set-invalid-type :name name :type (type-of (row-major-aref data 0))))
+ ;;check type consistency
+ (iter (for i from 0 below (reduce #'* (array-dimensions data)))
+ (for a next (get-type-info (row-major-aref data i)))
+ (for aa previous a)
+ (when (and (= a 2)
+ (not (<= 0 (char-code (row-major-aref data i)) 255)))
+ (error 'set-non8bit-character :name name :char (row-major-aref data i)))
+ (unless (or (first-iteration-p)
+ (= a aa))
+ (error 'set-heterogeneous-array :name name :array data))))
+
(defun set-array (j name data)
+ (array-typecheck name data)
(with-foreign-objects ((type :uint32)
(rank :uint32)
(shape-ptr :pointer)
(data-ptr :pointer))
- (assert (iter (for i from 0 below (reduce #'* (array-dimensions data)))
- (for a next (get-type-info (row-major-aref data i)))
- (for aa previous a)
- (unless (first-iteration-p)
- (always (= a aa)))))
(multiple-value-bind (type-number foreign-type) (get-type-info (row-major-aref data 0))
- (setf (mem-ref type :uint32) type-number)
- (setf (mem-ref rank :uint32) (array-rank data))
- (with-foreign-objects ((f-data foreign-type (reduce #'* (array-dimensions data)))
- (shape :uint32 (array-rank data)))
+ (setf (mem-ref type :uint32) type-number)
+ (setf (mem-ref rank :uint32) (array-rank data))
+ (with-foreign-objects ((f-data foreign-type (reduce #'* (array-dimensions data)))
+ (shape :uint32 (array-rank data)))
(iter (for i from 0 below (reduce #'* (array-dimensions data)))
(set-datum (row-major-aref data i) f-data i))
(setf (mem-ref data-ptr :pointer) f-data)
@@ -133,15 +161,23 @@
(%set j name type rank shape-ptr data-ptr)))))
(defun set-j (j name data)
- (etypecase data
- ((or complex float integer character boolean) (set-scalar j name data))
- (array (set-array j name data))
- (list (set-j j name (make-array (length data) :initial-contents data)))))
+ (typecase data
+ (character
+ (if (<= 0 (char-code data) 255)
+ (set-scalar j name data)
+ (error 'set-non8bit-character :name name :char data)))
+ ((or complex float integer boolean) (set-scalar j name data))
+ (array (if (zerop (array-rank data))
+ (set-j j name (aref data))
+ (set-array j name data)))
+ (list (set-j j name (make-array (length data) :initial-contents data)))
+ (otherwise (error 'set-invalid-type :name name :type (type-of data)))))
(defun set (name data)
"Set J variable `name` to `data`. Can be either and array or a scalar, of type integer, float, simple-char, complex. List will be coerced to arrays."
- (unless (eql (name-class name) :invalid)
- (set-j *j* (string name) data)))
+ (if (eql (name-class name) :invalid)
+ (error 'set-invalid-name :name name)
+ (set-j *j* (string name) data)))
(defun clear ()
"Clear J engine. This erases all names in current locale."

0 comments on commit f13f0b6

Please sign in to comment.
Something went wrong with that request. Please try again.