Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
227 lines (193 sloc) 8.03 KB
(in-package #:its)
(define (its byte) (bytespec)
(:position () `(byte-position ,bytespec))
(:size () `(byte-size ,bytespec))
(t (:position :size)))
(define (its arithmetic-error) (condition)
(:operation () `(arithmetic-error-operation ,condition))
(:operands () `(arithmetic-error-operands ,condition))
(t (:operation :operands)))
(define (its complex) (number)
(:real () `(realpart ,number))
(:imag () `(imagpart ,number))
(t (:real :imag))
(:conjugate () `(conjugate ,number)))
(define (its rational) (rational)
(:numerator () `(numerator ,rational))
(:denominator () `(denominator ,rational))
(t (:numerator :denominator)))
(define (its hash-table) (hash-table)
(:count () `(hash-table-count ,hash-table))
(:size () `(hash-table-size ,hash-table))
(:test () `(hash-table-test ,hash-table))
(:rehash-size () `(hash-table-rehash-size ,hash-table))
(:rehash-threshold () `(hash-table-rehash-threshold ,hash-table))
(gethash (key &optional default return-present-p)
(:expander (check-type return-present-p boolean)
(if return-present-p
(values (lambda (hash-table)
`(gethash ,key ,hash-table ,default))
2)
(lambda (hash-table)
`(values (gethash ,key ,hash-table ,default))))))
;; (setf gethash)
(remhash (key) `(remhash ,key ,hash-table)))
(define (its array) (array)
(bit (&rest subscripts) `(bit ,array ,@subscripts))
;; (setf bit)
(sbit (&rest subscripts) `(sbit ,array ,@subscripts))
;; (setf sbit)
(aref (&rest subscripts) `(aref ,array ,@subscripts))
;; (setf aref)
(row-major-aref (index) `(row-major-aref ,array ,index))
;; (setf row-major-aref)
(array-dimension (axis-number) `(array-dimension ,array ,axis-number))
(:dimensions () `(array-dimensions ,array))
(array-displacement ()
(:expander (values (lambda (array)
`(array-displacement ,array))
2)))
(:displaced-to () `(identity (array-displacement ,array)))
(:displaced-index-offset () `(nth-value 1 (array-displacement ,array)))
(:element-type () `(array-element-type ,array))
(:fill-pointer-p () `(array-has-fill-pointer-p ,array))
(array-in-bounds-p (&rest subscripts) `(array-in-bounds-p ,array ,@subscripts))
(:rank () `(array-rank ,array))
(array-row-major-index (&rest subscripts) `(array-row-major-index ,array ,@subscripts))
(:total-size () `(array-total-size ,array)))
(define (its array) (vector)
(:fill-pointer () `(fill-pointer ,vector))
;; (setf :fill-pointer)
(svref (index) `(svref ,vector ,index))
;; (setf svref)
(length () `(length ,vector)))
(define (its array) (string)
(char (index) `(char ,string ,index))
;; (setf char)
(schar (index) `(schar ,string ,index))
;; (setf schar)
)
(define (its echo-stream) (echo-stream)
(:input-stream () `(echo-stream-input-stream ,echo-stream))
(:output-stream () `(echo-stream-output-stream ,echo-stream))
(t (:input-stream :output-stream)))
(define (its synonym-stream) (synonym-stream)
(:symbol () `(synonym-stream-symbol ,synonym-stream)))
(define (its two-way-stream) (two-way-stream)
(:input-stream () `(two-way-stream-input-stream ,two-way-stream))
(:output-stream () `(two-way-stream-output-stream ,two-way-stream))
(t (:input-stream :output-stream)))
(define (its stream) (stream)
(:element-type () `(stream-element-type ,stream))
(:external-format () `(stream-external-format ,stream)))
(define (its stream-error) (condition)
(:stream () `(stream-error-stream ,condition)))
(define (its readtable) (readtable)
(:case () `(readtable-case ,readtable))
;; (setf :case)
)
(define (its pathname) (pathname)
(:host (&key (case :local)) `(pathname-host ,pathname :case ,case))
(:device (&key (case :local)) `(pathname-device ,pathname :case ,case))
(:directory (&key (case :local)) `(pathname-directory ,pathname :case ,case))
(:name (&key (case :local)) `(pathname-name ,pathname :case ,case))
(:type (&key (case :local)) `(pathname-type ,pathname :case ,case))
(:version () `(pathname-version ,pathname))
(t (:host :device :directory :name :type :version)))
(define (its package-error) (condition)
(:package () `(package-error-package ,condition)))
(define (its package) (package-designator)
(:name () `(package-name ,package-designator))
(:nicknames () `(package-nicknames ,package-designator))
(:shadowing-symbols () `(package-shadowing-symbols ,package-designator))
(:use-list () `(package-use-list ,package-designator))
(:used-by-list () `(package-used-by-list ,package-designator)))
(define (its symbol) (symbol)
(:name () `(symbol-name ,symbol))
(:package () `(symbol-package ,symbol))
(:value () `(symbol-value ,symbol))
;; (setf :value)
(:function () `(symbol-function ,symbol))
;; (setf :function)
(:plist () `(symbol-plist ,symbol))
;; (setf :plist)
)
(define (its sequence) (sequence)
(elt (index) `(elt ,sequence ,index))
;; (setf elt)
)
(define (its cell-error) (condition)
(:name () `(cell-error-name ,condition)))
(define (its simple-condition) (condition)
(:format-control () `(simple-condition-format-control ,condition))
(:format-arguments () `(simple-condition-format-arguments ,condition))
(t (:format-control :format-arguments)))
(define (its type-error) (condition)
(:datum () `(type-error-datum ,condition))
(:expected-type () `(type-error-expected-type ,condition))
(t (:datum :expected-type)))
(define (its unbound-slot) (condition)
(:instance () `(unbound-slot-instance ,condition)))
(define (its restart) (restart)
(:name () `(restart-name ,restart)))
(define (its :lisp-implementation) (ignored)
(:type () (declare (ignore ignored)) '(lisp-implementation-type))
(:version () (declare (ignore ignored)) '(lisp-implementation-version))
(t (:type :version)))
(define (its :machine) (ignored)
(:instance () (declare (ignore ignored)) '(machine-instance))
(:type () (declare (ignore ignored)) '(machine-type))
(:version () (declare (ignore ignored)) '(machine-version))
(t (:instance :type :version)))
(define (its method) (method)
(:qualifiers () `(method-qualifiers ,method)))
(define (its cons) (cons)
(:car () `(car ,cons))
;; (setf :car)
(:cdr () `(cdr ,cons))
;; (setf :cdr)
(t (:car :cdr)))
(define (its list) (list)
(:first () `(first ,list))
;; (setf :first)
(:rest () `(rest ,list))
;; (setf :rest)
(t (:first :rest))
(:second () `(second ,list))
(:third () `(third ,list))
(:fourth () `(fourth ,list))
(:fifth () `(fifth ,list))
(:sixth () `(sixth ,list))
(:seventh () `(seventh ,list))
(:eighth () `(eighth ,list))
(:ninth () `(ninth ,list))
(:tenth () `(tenth ,list))
(nth (n) `(nth ,n ,list))
;; (setf nth)
(nthcdr (n) `(nthcdr ,n ,list)))
(defun %slot-value-like-expand (operator slot-name further-slot-names)
(if further-slot-names
(let ((slot-names (cons slot-name further-slot-names)))
(values (lambda (object)
`(values ,@(mapcar (lambda (slot-name)
`(,operator ,object ,slot-name))
slot-names)))
(length slot-names)))
(lambda (object)
`(,operator ,object ,slot-name))))
(define (its t) ()
(slot-value (slot-name &rest further-slot-names)
(:expander (%slot-value-like-expand 'slot-value slot-name further-slot-names)))
;; (setf slot-value)
(slot-exists-p (slot-name &rest further-slot-names)
(:expander (%slot-value-like-expand 'slot-exists-p slot-name further-slot-names)))
(slot-boundp (slot-name &rest further-slot-names)
(:expander (%slot-value-like-expand 'slot-boundp slot-name further-slot-names))))
;; decode-universal-time?
;; Currently no easy way of defining higher-order kinds.
(setf (defsys:locate *kind-definitions* 'values)
(make-instance 'access-specifier-definition
:name 'values
:lambda-list '(&rest specifiers)
:expander (lambda (&rest specifiers)
(%expand-args *kind-definitions* specifiers))))