Skip to content

Instantly share code, notes, and snippets.

@commander-trashdin

commander-trashdin/default-types.lisp

Last active March 2, 2021 17:26
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save commander-trashdin/779e7e53f15b9e259048ce5b7ec0b4ca to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save commander-trashdin/779e7e53f15b9e259048ce5b7ec0b4ca to your computer and use it in GitHub Desktop.
Download ZIP
Important part of my util, that is about sane defaults for all types, including parametrized. Let's try to cover all of them, can be very useful.
Raw
default-types.lisp
(defparameter *default-impl* (make-hash-table))
(Defun %dimensions-comp (dimensions)
(cond ((eql '* dimensions) 0)
((listp dimensions) (mapcar (lambda (x) (if (eql '* x) 0 x)) dimensions))
(t dimensions)))
(defun default (type &optional environment)
(multiple-value-bind (item knownp) (gethash type *default-impl*)
(if knownp
item
(progn
(setf type (sb-ext:typexpand type environment))
(if (symbolp type)
(case type
((bit fixnum integer rational) 0)
((float double-float single-float long-float real) 0.0)
((number complex) #c(0 0))
((character base-char) #\Nul)
(standard-char #\a)
((symbol t) t)
(keyword :t)
(hash-table `(make-hash-table))
((list boolean atom null) nil)
(pathname #P"")
(function '(lambda (&rest args)
(declare (ignore args)
(optimize (speed 3) (safety 0) (debug 0) (space 0) (compilation-speed 0)))))
(vector '(make-array 0 :adjustable t))
(bit-vector '(make-array 0 :element-type 'bit :adjustable t))
(string '(make-array 0 :element-type 'character :adjustable t :initial-element #\Nul))
(simple-array (make-array 0)) ;;Maybe it should error here, since array dimension is nto specified?
;;What happens with just array? Or just sequence? I guess nothing
(simple-string '(make-array 0 :element-type 'character :initial-element #\Nul))
(simple-base-string '(make-array 0 :element-type 'base-char :initial-element #\Nul))
(otherwise
(cond ((subtypep type 'structure-object environment)
(list (intern (concatenate 'string "MAKE-" (string type)))))
((subtypep type 'standard-object environment)
`(make-instance ,type)))))
(destructuring-bind (main . rest) type
(case main
((mod unsigned-byte singned-byte) 0)
((integer eql member rational real float) (first rest))
(complex `(complex ,(default (first rest)) ,(default (first rest))))
(cons `(cons ,(default (first rest)) ,(default (first rest))))
(or (default (first rest)))
(vector `(make-array ',(if (= 2 (length rest))
(%dimensions-comp (second rest))
0)
:adjustable t
:element-type ',(or (first rest) t)
:initial-element ,(if (first rest)
(default (first rest))
0)))
(bit-vector `(make-array ,(or (first rest) 0) :element-type 'bit :adjustable t))
(string `(make-array ',(if (= 2 (length rest))
(%dimensions-comp (second rest))
0)
:element-type 'character
:adjustable t
:initial-element #\Nul))
(simple-array `(make-array ',(if (= 2 (length rest))
(%dimensions-comp (second rest))
0)
:element-type ',(or (first rest) t)
:initial-element ,(if (first rest)
(default (first rest))
0)))
(simple-string `(make-array ',(if (= 2 (length rest))
(%dimensions-comp (second rest))
0)
:element-type 'character
:initial-element #\Nul))
(simple-base-string `(make-array ',(if (= 2 (length rest))
(%dimensions-comp (second rest))
0)
:element-type 'base-char
:initial-element #\Nul))
(array `(make-array ',(if (= 2 (length rest))
(%dimensions-comp (second rest))
0)
:element-type ',(or (first rest) t)
:initial-element ,(if (first rest)
(default (first rest))
0))))))))))
;;; Examples of usage as well as other util stuff below
(defmacro deftuple (name &rest slots)
`(progn
(defstruct ,name
,@(loop :for (type . rest) :in slots
:collect `(,(first rest)
,(or (second rest) (default type))
:type ,type)))
(declaim (inline ,name))
; (ftype (function (&optional ,@(mapcar #'first slots)) ;;It seems this only adds redundant type checks
; (values ,name &optional)
; ,name))
(defun ,name (&optional ,@(mapcar (lambda (slot) `(,(second slot) ,(or (third slot) (default (first slot)))))
slots))
(,(intern (concatenate 'string "MAKE-" (string name)))
,@(loop :for (type name . rest) :in slots
:collect (intern (string name) "KEYWORD")
:collect name)))))
;; Here's how that simplified defintion looks like
;; (deftuple pair
;; (fixnum x)
;; (string y "asdf")))
;; Shortcuts for make-array, because life is too short to write it down every time
(declaim (inline arr))
(defun arr (dimensions type &optional initial)
(make-array dimensions :element-type type :initial-element (or initial (default type))))
(define-compiler-macro arr (&whole form dimensions type &optional initial &environment env)
(if (constantp type env)
`(make-array ,dimensions :element-type ,type
:initial-element ,(or initial (default (eval type) env)))
form))
(declaim (inline vec))
(defun vec (dimensions type &optional initial)
(make-array dimensions :element-type type
:initial-element (or initial (default type))
:adjustable t :fill-pointer 0))
(define-compiler-macro vec (&whole form dimensions type &optional initial &environment env)
(if (constantp type env)
`(make-array ,dimensions :element-type ,type
:initial-element ,(or initial (default (eval type) env))
:adjustable t :fill-pointer 0)
form))
;; This is only useful of course if you need ALL of them to be default,
;; otherwise it just doesn't work
(defmacro typelet (bindings &body body)
`(let ,(loop :for (type . names) :in bindings
:appending (loop :for name :in names
:collect `(,name ,(default type))))
(declare ,@(loop :for (type . names) :in bindings
:collect `(type ,type ,@names)))
,@body))
;; This doesn't have to do anything with the rest, but I put it here anyway
(defmacro bind* (bindings &body body)
(labels ((rec (bindings)
(if bindings
(destructuring-bind (bind . rest) bindings
(assert (and (listp bind) (= 2 (length bind))))
(destructuring-bind (names values) bind
(if (symbolp names)
`(let ((,names ,values))
,(rec rest))
`(multiple-value-bind ,names ,values
,(rec rest)))))
`(progn ,@body))))
(rec bindings)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment