(in-package :kira)
(defmacro eval-always (&body body)
"eval-when (:compile-toplevel :load-toplevel :execute)"
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@body))
(defun constant-form-p (form)
"Return true if FORM is a (bound) constant variable."
(and (symbolp form) (constantp form) (boundp form)))
(defun macro-eval (form &optional env)
(prog ((expansion form) expanded-p)
macro-eval-1
(when (self-evaluating-p expansion)
(return (values expansion t)))
(when (quoted-form-p expansion)
(return (values (cadr expansion) t)))
(multiple-value-setq (expansion expanded-p)
(macroexpand-1 expansion env))
(when expanded-p (go macro-eval-1))
(return (if (constant-form-p expansion)
(values (symbol-value expansion) t)
(values form nil)))))
(eval-always
(defmacro with-gensyms (variables &body body)
(loop for var in variables as name = (string var)
collect `(,var (gensym ',name)) into bindings
finally (return `(let ,bindings ,@body)))))
(defmacro rebinding (variables &body body)
(loop with prefix = (symbol-name '#:re)
for var in variables
for g = (gensym prefix)
for temp = `(gensym ,(string var))
collect `(,g ,temp) into gensyms
collect ``(,,g ,,var) into temps
collect `(,var ,g) into renames
finally (return `(let ,gensyms
`(let (,,.temps)
,(let ,renames
,@body))))))
(eval-always
(defmacro whereas (bindings &body body)
(flet ((make-single-level (var val x) `(let ((,var ,val)) (when ,var ,x))))
(let ((function #'(lambda (a b) (make-single-level (car a) (cadr a) b))))
(reduce function bindings :from-end t :initial-value `(locally ,@body))))))
(defun ensure-list (thing)
(unless (eq thing nil)
(if (atom thing)
(list thing)
thing)))
(defmacro load-time-package (package-name)
`(load-time-value (find-package ,package-name)))
(defun ensure-keyword (thing)
(when (or (not thing) (keywordp thing)) (return-from ensure-keyword thing))
(let ((keyword-name (if (symbolp thing) (string thing) (string-upcase thing))))
(values (intern keyword-name (load-time-package :keyword)))))
(defun ensure-package (package-name &rest package-options)
"Make package if non-existent. The default use-list is empty."
(or (find-package package-name) (let (*make-package-use-defaults*)
(apply #'make-package
package-name
package-options))))
(defun sans (plist &rest keys &aux (sans '()))
"Return PLIST with the given properties removed non-destructively."
(loop (let ((tail (nth-value 2 (get-properties plist keys))))
(cond ((null tail) (return (nreconc sans plist)))
(t (loop until (eq plist tail)
do (push (pop plist) sans)
(push (pop plist) sans)
finally (setq plist (cddr plist))))))))
(eval-always
(defun get-removal-macro-expansion (item place options environment function-name)
(multiple-value-bind (temps vals news writer reader) (get-setf-expansion place environment)
(let ((modification-form `(,function-name ,item ,reader ,@options)) (new (car news)))
(unless (endp (cdr news)) (error "Multiple values aren't supported."))
`(let* (,.(mapcar #'list temps vals) (,new ,modification-form))
,writer)))))
(defmacro deletef (item place &rest options &environment environment)
(get-removal-macro-expansion item place options environment 'delete))
(defmacro removef (item place &rest options &environment environment)
(get-removal-macro-expansion item place options environment 'remove))
(eval-always
(define-modify-macro coercef (&rest args) coerce)
(define-modify-macro reversef (&rest args) reverse)
(define-modify-macro nreversef (&rest args) nreverse)
(define-modify-macro appendf (&rest args) append)
(define-modify-macro nconcf (&rest args) nconc)
(define-modify-macro butlastf (&rest args) butlast)
(define-modify-macro nbutlastf (&rest args) nbutlast)
(define-modify-macro logiorf (&rest args) logior)
(define-modify-macro logxorf (&rest args) logxor)
(define-modify-macro sortf (&rest args) sort)
(define-modify-macro sansf (&rest args) sans)
(define-modify-macro absf (&rest args) abs)
(define-modify-macro maxf (&rest args) max)
(define-modify-macro minf (&rest args) min)
(define-modify-macro ashf (&rest args) ash))
(defmacro orf (place &rest forms &environment environment)
(multiple-value-bind (temps vals news writer reader) (get-setf-expansion place environment)
(let* ((new-form `(or ,@forms)) (set-form `(multiple-value-bind ,news ,new-form ,writer)))
`(let* (,.(mapcar #'list temps vals)) (or ,reader ,set-form)))))
(defmacro %get-collecting-context (name)
(error "Can't collect into: ~S." name))
(defmacro collecting (lists &body body &environment environment)
(let* ((list (if lists (car lists) (gensym (string 'anonymous-list))))
(list-name (when lists (pop lists)))
(context `(,list ,(gensym (string 'tail)))))
(unless list-name (setq body `(,@body ,list)))
(let ((next-macro-function (macro-function '%get-collecting-context environment)))
`(macrolet ((%get-collecting-context (name &environment internal-environment)
(when (eq name ',list-name) (return-from %get-collecting-context ',context))
(funcall ,next-macro-function `(%get-collecting-context ,name) internal-environment)))
(let ,context ,@(if lists `((collecting ,lists ,@body)) body))))))
(defmacro collect (new-element &key into &environment environment)
(destructuring-bind (list tail) (macroexpand-1 `(%get-collecting-context ,into) environment)
`(setq ,tail (if ,tail (setf (cdr ,tail) (list ,new-element)) (setq ,list (list ,new-element))))))
(defun make-collector ()
(collecting (anonymous-list)
#'(lambda (&optional (thing nil thing-supplied-p))
(cond ((not thing-supplied-p) anonymous-list)
(t (collect thing :into anonymous-list))))))
(defmacro defstruct* (name-and-options &rest description &aux documentation)
(when (stringp (car description)) (setq documentation (pop description)))
`(defstruct ,name-and-options ,@(when documentation (list documentation))
,.(loop for slot-definition in description
collect (if (atom slot-definition)
`(,slot-definition nil)
slot-definition))))
(eval-always
(defun parse-binding (binding &optional default-form)
(cond ((null binding) (values nil default-form))
((symbolp binding) (values binding default-form))
((cdr binding) (values (car binding) (cadr binding)))
(t (values (car binding) default-form)))))
(deftype array-index ()
`(integer 0 ,array-total-size-limit))
(defun check-vector-bounds (array start end &aux (rank (array-rank array)))
(let ((length (if (= (the array-rank rank) 1) (length array) (array-total-size array))))
(prog1 (prog1 (orf end length) (check-type start array-index) (check-type end array-index))
(locally (declare (type array-index start end))
(when (or (minusp start) (> start end) (> end (the array-index length)))
(error "Invalid bounding indexes for ~S: ~D, ~D." array start end))))))
(defmacro with-array-data (((vector array) . optional-bindings) &body body)
(destructuring-bind (&optional start-binding end-binding) optional-bindings
(multiple-value-bind (body declarations) (parse-body body nil nil)
(multiple-value-bind (start start-value) (parse-binding start-binding)
(multiple-value-bind (end end-value) (parse-binding end-binding)
(rebinding (array)
(with-gensyms (offset)
(let* ((optimize-settings '(declare (optimize (safety 0) (speed 3))))
(offset-specs `((type array-index ,offset) (ignorable ,offset)))
(bounds-check-form `(check-vector-bounds ,array ,start ,end))
(bounding-indexes (delete nil (list start end)))
(type-declaration `(declare (type array-index ,.bounding-indexes)))
(declarations `(,@declarations ,optimize-settings ,type-declaration))
(new-body `(,(if end `(setq ,end ,bounds-check-form) bounds-check-form))))
(dolist (bx bounding-indexes) (push `(setq ,bx (+ ,bx ,offset)) body))
(setq new-body (append new-body (list `(locally ,.declarations ,@body))))
`(multiple-value-bind (,vector ,offset) (array-data-and-offset ,array)
(declare (type (simple-array * (*)) ,vector)) (declare ,@offset-specs)
(let* (,@(if start `((,start ,start-value))) ,@(if end `((,end ,end-value))))
,@new-body))))))))))
(defun make-indirect-vector (displaced-to &key (start 0) end)
(let ((displaced-to-element-type (array-element-type displaced-to)))
(setq end (check-vector-bounds displaced-to start end))
(locally (declare (type array-index start end))
(make-array (the array-index (- end start))
:displaced-to displaced-to
:displaced-index-offset start
:element-type displaced-to-element-type))))
(defun make-bit-vector (size &optional (initial-element 0))
"Make bit vector of SIZE with the INITIAL-ELEMENT defaulting to zero."
(make-array size :initial-element initial-element :element-type 'bit))
(defun make-buffer (&optional (size 512) (element-type '(unsigned-byte 8)))
(make-array size :fill-pointer 0 :adjustable t :element-type element-type))
(defun reset-buffer (buffer)
"Zero fill-pointer and return BUFFER."
(setf (fill-pointer buffer) 0) buffer)
(defun print-escape-p ()
"True if printing escape characters."
(or *print-escape* *print-readably*))
(defun make-temporary-name (&optional (ut (get-universal-time)))
(let ((name (format nil "Kira-~36R~36R" (random (* 36 36)) ut)))
(make-pathname :name name :type "tmp" :defaults #p"kira:data;")))
(defun open-temporary-file (&rest options)
(appendf options '(:if-exists nil :direction :output))
(loop thereis (let ((pathname (make-temporary-name)))
(apply #'open pathname options))))
(defmacro with-temporary-file ((stream . options) &body body)
`(with-open-stream (,stream (open-temporary-file ,@options))
,@body))
(defmacro with-new-file ((stream pathname . options) &body body)
(setq options (copy-list options))
(loop for default-option in '((:if-does-not-exist . :create)
(:if-exists . :supersede)
(:direction . :output))
when (eq (getf options (car default-option) options) options)
do (setf (getf options (car default-option)) (cdr default-option))
finally (setq pathname `(ensure-directories-exist ,pathname))
(return `(with-open-file (,stream ,pathname ,.options)
,@body))))
(defun directory-name (pathname)
(let ((directory (pathname-directory pathname)))
(when (cdr directory) (car (last directory)))))
(defun typed-pathname (pathname)
"If the PATHNAME has no type, then make one with the :UNSPECIFIC type."
(symbol-macrolet ((default (load-time-value (make-pathname :type :unspecific))))
(if (pathname-type pathname) pathname (merge-pathnames pathname default))))
(defun open-log (pathname &rest options)
(appendf options '(:if-exists :append :if-does-not-exist :create))
(appendf options '(:direction :output :external-format :utf-8))
(apply #'open pathname options))
(defmacro with-open-log ((stream pathname &rest options) &body body)
`(with-open-stream (,stream (open-log ,pathname ,@options)) ,@body))
(defun log-condition (condition)
(let ((now (universal-time-string (get-universal-time))))
(with-open-log (stream "kira:data;error.log")
(format stream "~&[~A] ~A~%" now condition))))
(defun type-equal (type1 type2)
(and (subtypep type1 type2)
(subtypep type2 type1)))
(defstaticvar *mmap-alist* '()
"Alist of mapping -> truename.")
(defun mmap (pathname element-type &aux vector (truename (truename pathname)))
(let ((upgraded-element-type (upgraded-array-element-type element-type)))
(loop for mapping in *mmap-alist* when (equal (cdr mapping) truename)
do (unless (type-equal (array-element-type (car mapping)) upgraded-element-type)
(error "Existing vector ~S is incompatible with ~S." (car mapping) element-type))
(return (setq vector (car mapping)))
finally (setq vector (map-file-to-ivector truename upgraded-element-type))
(return-from mmap (caar (push (cons vector truename) *mmap-alist*))))
(unmap-ivector vector)
(let* ((new-displaced-vector
(map-file-to-ivector truename upgraded-element-type))
(size (array-total-size new-displaced-vector)))
(declare (type array-index size) (type (vector unsigned-byte) new-displaced-vector))
(multiple-value-bind (data offset) (array-displacement new-displaced-vector)
(adjust-array vector size :displaced-to data :displaced-index-offset offset)))))
(defun munmap (vector &aux (mapping (assoc vector *mmap-alist*)))
(unless mapping (error "Not mapped with ~S: ~S." 'mmap vector))
(prog1 (unmap-ivector vector) (deletef mapping *mmap-alist*)))
(defun get-mmap-displaced-vector (vector &optional (start 0) end)
(with-array-data ((underlying-data vector) (start start) (end end))
(loop with data-offset of-type array-index = 0 and data as (ivector) in *mmap-alist*
do (multiple-value-setq (data data-offset) (array-data-and-offset ivector))
when (eq data underlying-data) return (make-indirect-vector
ivector
:start (- start data-offset)
:end (- end data-offset)))))
(defmacro fail-safe (attempt &rest failure-forms)
(let* ((ok (gensym "OK")) (protected-form `(progn ,attempt (setq ,ok t))))
`(let (,ok) (unwind-protect ,protected-form (unless ,ok ,@failure-forms)))))
(defstatic +content-external-format+
'(:character-encoding :utf-8
:line-termination :crlf))
(defun file-string (pathname &key (external-format +content-external-format+))
(with-open-file (stream pathname :external-format external-format)
(loop with buffer = (make-buffer (file-length stream) 'character)
for start of-type array-index = (fill-pointer buffer)
do (setf (fill-pointer buffer) (array-total-size buffer))
(let ((end (read-sequence buffer stream :start start)))
(setf (fill-pointer buffer) (the array-index end)))
(unless (listen stream) (return-from file-string buffer))
(when (= (fill-pointer buffer) (array-total-size buffer))
(adjust-array buffer (ceiling (length buffer) 4/5))))))
(defmacro with-heap-ivector ((vector macptr size element-type) &body body)
`(multiple-value-bind (,vector ,macptr) (make-heap-ivector ,size ,element-type)
(unwind-protect (progn ,@body) (dispose-heap-ivector ,vector))))
(defun files-equal (pathname1 pathname2)
"Return true if both files exist, and they have identical contents."
(symbol-macrolet ((element-type '(unsigned-byte 8)) (buffer-size 8192))
(let ((size1 (file-data-size pathname1)) (size2 (file-data-size pathname2)))
(unless (and size1 size2 (eql size1 size2)) (return-from files-equal nil)))
(with-open-file (stream1 pathname1 :direction :input :element-type element-type)
(with-open-file (stream2 pathname2 :direction :input :element-type element-type)
(with-heap-ivector (buffer1 buffer-memory-1 buffer-size element-type)
(with-heap-ivector (buffer2 buffer-memory-2 buffer-size element-type)
(loop for position1 of-type fixnum = (read-sequence buffer1 stream1)
for position2 of-type fixnum = (read-sequence buffer2 stream2)
until (= position1 position2 0)
always (and (= position1 position2)
(zerop (#_memcmp buffer-memory-1
buffer-memory-2
position1))))))))))