common_lisp/types.lisp

   1 (defpackage :types
   2   (:use :common-lisp)
   3   (:export :mal-value=
   4            ;; Accessors
   5            :mal-value
   6            :mal-type
   7            :mal-meta
   8            ;; Mal values
   9            :number
  10            :boolean
  11            :nil
  12            :string
  13            :symbol
  14            :keyword
  15            :list
  16            :vector
  17            :hash-map
  18            :any
  19            ;; Helpers
  20            :apply-unwrapped-values
  21            :switch-mal-type))
  22
  23 (in-package :types)
  24
  25 (defclass mal-type ()
  26   ((value :accessor mal-value :initarg :value)
  27    (meta :accessor mal-meta :initarg :meta)
  28    (type :accessor mal-type :initarg :type)))
  29
  30 (defmethod print-object ((obj mal-type) out)
  31   (with-slots (value type meta) obj
  32     (format out "#<mal ~a: ~a (~a)>" type value meta)))
  33
  34 (defun add-mal-meta (value meta)
  35   (setf (slot-value value 'meta) meta)
  36   value)
  37
  38 (defun mal-value= (value1 value2)
  39   (and (equal (mal-type value1) (mal-type value2))
  40        (equal (mal-value value1) (mal-value value2))))
  41
  42 (defun hash-mal-value (value)
  43   (sxhash (mal-value value)))
  44
  45 #+sbcl (sb-ext:define-hash-table-test mal-value= hash-mal-value)
  46 #+clisp (ext:define-hash-table-test mal-value= mal-value= hash-mal-value)
  47
  48 (defmacro define-mal-type (type)
  49   ;; Create a class for given type and a convenience constructor and also export
  50   ;; them
  51   (let ((name (intern (string-upcase (concatenate 'string
  52                                                   "mal-"
  53                                                   (symbol-name type)))))
  54         (constructor (intern (string-upcase (concatenate 'string
  55                                                          "make-mal-"
  56                                                          (symbol-name type))))))
  57     `(progn (defclass ,name (mal-type)
  58               ((type :accessor mal-type
  59                      :initarg :type
  60                      :initform ',type)))
  61
  62             (defun ,constructor (value &optional meta)
  63               (make-instance ',name
  64                              :value value
  65                              :meta meta))
  66
  67             (export ',name)
  68             (export ',constructor))))
  69
  70 (define-mal-type number)
  71 (define-mal-type symbol)
  72 (define-mal-type keyword)
  73 (define-mal-type string)
  74 (define-mal-type boolean)
  75 (define-mal-type list)
  76 (define-mal-type vector)
  77 (define-mal-type hash-map)
  78 (define-mal-type nil)
  79
  80 ;; Generic type
  81 (defvar any "any-type")
  82
  83 (defmacro switch-mal-type (ast &body forms)
  84   `(let ((type (types:mal-type ,ast)))
  85      (cond
  86        ,@(mapcar (lambda (form)
  87                    (list (if (or (equal (car form) t)
  88                                  (equal (car form) 'any))
  89                              t
  90                              (list 'equal (list 'quote (car form)) 'type))
  91                          (cadr form)))
  92                  forms))))
  93