Advertisement
Guest User

Untitled

a guest
Dec 1st, 2018
236
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.47 KB | None | 0 0
  1. (in-package "CL-USER")
  2.  
  3. (eval-when (:compile-toplevel :load-toplevel :execute)
  4. (defun package-export-list (package)
  5. (let ((result '()))
  6. (with-package-iterator (it package :external)
  7. (loop
  8. (multiple-value-bind (got-it symbol kind home) (it)
  9. (declare (ignore kind home))
  10. (if got-it
  11. (push symbol result)
  12. (return result))))))))
  13.  
  14.  
  15. (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CARRAY"
  16. (:use "CL")
  17. (:shadow "MAKE-ARRAY" "AREF" "ARRAY-DIMENSIONS" #|…|#)
  18. (:export "MAKE-ARRAY" "AREF" "ARRAY-DIMENSIONS" #|…|#))
  19.  
  20. (defpackage "CL-CARRAY"
  21. (:use "CL")
  22. (:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.CARRAY"
  23. . #.(mapcar (function symbol-name)
  24. (package-export-list "COM.INFORMATIMAGO.COMMON-LISP.CARRAY")))
  25. (:export
  26. . #.(mapcar (function symbol-name)
  27. (package-export-list "COMMON-LISP"))))
  28.  
  29. (in-package "COM.INFORMATIMAGO.COMMON-LISP.CARRAY")
  30.  
  31. (defstruct (controlled-array
  32. (:constructor make-controlled-array (array element-type))
  33. (:conc-name %carray-))
  34. array
  35. element-type)
  36.  
  37. (defun make-array (dimensions &rest keys &key (element-type 't) &allow-other-keys)
  38. (make-controlled-array (apply (function cl:make-array) dimensions keys)
  39. element-type))
  40.  
  41. (defun aref (array &rest indices)
  42. (apply (function cl:aref) (%carray-array array) indices))
  43.  
  44. (defun (setf aref) (new-value array &rest indices)
  45. (if (typep new-value (%carray-element-type array))
  46. (setf (apply (function cl:aref) (%carray-array array) indices) new-value)
  47. (error 'type-error :datum new-value :expected-type (%carray-element-type array))))
  48.  
  49. (defun array-dimensions (array)
  50. (cl:array-dimensions array))
  51.  
  52. (in-package "CL-USER")
  53. (defpackage "MY-PROGRAM"
  54. (:use "CL-CARRAY"))
  55. (in-package "MY-PROGRAM")
  56.  
  57. (let ((array (make-array 3
  58. :element-type '(integer 1 12)
  59. :initial-element 6)))
  60. (print (multiple-value-list (ignore-errors (setf (aref array 2) 100))))
  61. (print array)
  62. (setf (aref array 1) 7)
  63. (print array)
  64. (values))
  65.  
  66. ;; prints:
  67. ;; (nil #<type-error #x30203DD8ADDD>)
  68. ;; #S(com.informatimago.common-lisp.carray::controlled-array :array #(6 6 6) :element-type (integer 1 12))
  69. ;; #S(com.informatimago.common-lisp.carray::controlled-array :array #(6 7 6) :element-type (integer 1 12))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement