~remexre/nrutil

976e1eae908795a9e26147a5437ab4985a6998e7 — Nathan Ringo 7 months ago 4d096a2
Use defun/typed in the implementation of the rest.
1 files changed, 50 insertions(+), 51 deletions(-)

M main.lisp
M main.lisp => main.lisp +50 -51
@@ 6,6 6,52 @@
  (:export #:data-class #:dbg #:def-data-class #:defun/typed #:genint #:print-object-pretty #:tuple))
(in-package :nrutil/main)

(defmacro defun/typed (name args ret &body body)
  (check-type name symbol)
  (let (defun-args mode type-args)
    (iter
      (for arg in args)
      (etypecase arg
        ((eql &key)
         (unless (member mode '(nil))
           (error "Invalid use of &key"))
         (push '&key defun-args)
         (push '&key type-args)
         (setf mode '&key))
        ((member '(&optional &rest))
         (error "Not supported: ~s" arg))
        (symbol
          (ecase mode
            ((nil)
              (push arg defun-args)
              (push t type-args))
            ((&key)
              (let ((keyword-name (intern (symbol-name arg) "KEYWORD")))
                (push arg defun-args)
                (push `(,keyword-name t) type-args)))))
        (cons
          (ecase mode
            ((nil)
              (push (first arg) defun-args)
              (push (second arg) type-args))
            ((&key)
             (let (keyword-name var
                   (arg-type (car (last arg))))
               (etypecase (first arg)
                 (symbol
                   (setf keyword-name (intern (symbol-name (first arg)) "KEYWORD")
                         var (first arg)))
                 (cons
                   (setf keyword-name (caar arg)
                         var (cdar arg))))
               (push (list keyword-name arg-type) type-args)
               (push (butlast arg) defun-args)))))))
    (unless (and (consp ret) (eq (car ret) 'values))
      (setf ret `(values ,ret &optional)))
    `(progn
       (declaim (ftype (function ,(nreverse type-args) ,ret) ,name))
       (defun ,name ,(nreverse defun-args) ,@body))))

(deftype self-evaluating ()
  "The type of self-evaluating forms."
  '(or number character string bit-vector null keyword))


@@ 18,8 64,7 @@
  ()
  (:documentation "A mixin for printing object graphs READably."))

(declaim (ftype (function (data-class stream) (values &optional)) print-data-class-object-readably))
(defun print-data-class-object-readably (object stream)
(defun/typed print-data-class-object-readably ((object data-class) (stream stream)) null
  (let ((class (class-of object)))
    (pprint-logical-block (stream nil)
      (format stream "#.(~s '~s " 'make-instance (class-name class))


@@ 40,7 85,7 @@
              (write-char #\' stream))
            (write value :stream stream))))
      (write-char #\) stream)))
  (values))
  nil)

(defgeneric print-object-pretty (object stream)
  (:documentation "Pretty-prints an object. Used to override the print-object


@@ 55,7 100,7 @@
      (print-data-class-object-readably object stream)
      (print-object-pretty object stream)))

(defun merge-plist (a b)
(defun/typed merge-plist ((a list) (b list)) list
  "Merges two plists, preferring keys in B."
  (let ((values (make-hash-table)))
    (iter


@@ 126,7 171,7 @@
                      (make-instance ',name ,@field-kwargs))))))))

(defvar *genint-counter* 0)
(defun genint ()
(defun/typed genint () number
  (incf *genint-counter*))

(defmacro dbg (expr)


@@ 134,49 179,3 @@
    `(let ((,vals (multiple-value-list ,expr)))
       (format *debug-io* ,(format nil "~s =~~{ ~~s~~}~~%" expr) ,vals)
       (values-list ,vals))))

(defmacro defun/typed (name args ret &body body)
  (check-type name symbol)
  (let (defun-args mode type-args)
    (iter
      (for arg in args)
      (etypecase arg
        ((eql &key)
         (unless (member mode '(nil))
           (error "Invalid use of &key"))
         (push '&key defun-args)
         (push '&key type-args)
         (setf mode '&key))
        ((member '(&optional &rest))
         (error "Not supported: ~s" arg))
        (symbol
          (ecase mode
            ((nil)
              (push arg defun-args)
              (push t type-args))
            ((&key)
              (let ((keyword-name (intern (symbol-name arg) "KEYWORD")))
                (push arg defun-args)
                (push `(,keyword-name t) type-args)))))
        (cons
          (ecase mode
            ((nil)
              (push (first arg) defun-args)
              (push (second arg) type-args))
            ((&key)
             (let (keyword-name var
                   (arg-type (car (last arg))))
               (etypecase (first arg)
                 (symbol
                   (setf keyword-name (intern (symbol-name (first arg)) "KEYWORD")
                         var (first arg)))
                 (cons
                   (setf keyword-name (caar arg)
                         var (cdar arg))))
               (push (list keyword-name arg-type) type-args)
               (push (butlast arg) defun-args)))))))
    (unless (and (consp ret) (eq (car ret) 'values))
      (setf ret `(values ,ret &optional)))
    `(progn
       (declaim (ftype (function ,(nreverse type-args) ,ret) ,name))
       (defun ,name ,(nreverse defun-args) ,@body))))