(in-package "CL-USER")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun package-export-list (package)
    (let ((result '()))
      (with-package-iterator (it package :external)
        (loop
           (multiple-value-bind (got-it symbol kind home) (it)
             (declare (ignore kind home))
             (if got-it
                 (push symbol result)
                 (return result))))))))


(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CARRAY"
  (:use "CL")
  (:shadow "MAKE-ARRAY" "AREF" "ARRAY-DIMENSIONS" #|…|#)
  (:export "MAKE-ARRAY" "AREF" "ARRAY-DIMENSIONS" #|…|#))

(defpackage "CL-CARRAY"
  (:use "CL")
  (:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.CARRAY"
                          . #.(mapcar (function symbol-name)
                                      (package-export-list "COM.INFORMATIMAGO.COMMON-LISP.CARRAY")))
  (:export
   . #.(mapcar (function symbol-name)
               (package-export-list "COMMON-LISP"))))

(in-package "COM.INFORMATIMAGO.COMMON-LISP.CARRAY")

(defstruct (controlled-array
            (:constructor make-controlled-array (array element-type))
            (:conc-name %carray-))
  array
  element-type)

(defun make-array (dimensions &rest keys &key (element-type 't) &allow-other-keys)
  (make-controlled-array (apply (function cl:make-array) dimensions keys)
                         element-type))

(defun aref (array &rest indices)
  (apply (function cl:aref) (%carray-array array)  indices))

(defun (setf aref) (new-value array &rest indices)
  (if (typep new-value (%carray-element-type array))
      (setf (apply (function cl:aref)  (%carray-array array) indices) new-value)
      (error 'type-error :datum new-value :expected-type (%carray-element-type array))))

(defun array-dimensions (array)
  (cl:array-dimensions array))

(in-package "CL-USER")
(defpackage "MY-PROGRAM"
  (:use "CL-CARRAY"))
(in-package  "MY-PROGRAM")

(let ((array  (make-array 3
                          :element-type '(integer 1 12)
                          :initial-element 6)))
  (print (multiple-value-list (ignore-errors (setf (aref array 2) 100))))
  (print array)
  (setf (aref array 1) 7)
  (print array)
  (values))

;; prints:
;; (nil #<type-error #x30203DD8ADDD>)
;; #S(com.informatimago.common-lisp.carray::controlled-array :array #(6 6 6) :element-type (integer 1 12))
;; #S(com.informatimago.common-lisp.carray::controlled-array :array #(6 7 6) :element-type (integer 1 12))