src/base/deffoldable.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Declaring forms as foldable(pure)
   4 ;;;
   5
   6 (in-package :iolib.base)
   7
   8 #+sbcl
   9 (progn
  10   (defun defknown-redefinition-error-p (e)
  11     (declare (optimize speed))
  12     (and (typep e 'simple-error)
  13          (search "overwriting old FUN-INFO"
  14                  (the string (simple-condition-format-control e)))))
  15
  16   (deftype defknown-redefinition-error ()
  17     '(satisfies defknown-redefinition-error-p))
  18
  19   (defmacro %deffoldable (func argument-types return-type)
  20     `(handler-bind ((defknown-redefinition-error #'continue))
  21        (sb-c:defknown ,func ,argument-types ,return-type (sb-c:foldable)))))
  22
  23 #-(or sbcl)
  24 (defmacro %deffoldable (&rest args)
  25   (declare (ignore args)))
  26
  27 (defun constantp (form &optional environment)
  28   (cl:constantp (cond ((symbolp form)
  29                        (macroexpand form environment))
  30                       (t form))
  31                 environment))
  32
  33 (defmacro deffoldable (func &optional
  34                        (argument-types (list t))
  35                        (return-type t))
  36   (alexandria:with-gensyms (form env args)
  37     `(eval-when (:compile-toplevel :load-toplevel :execute)
  38        (%deffoldable ,func ,argument-types ,return-type)
  39        (define-compiler-macro ,func (&whole ,form &rest ,args
  40                                             &environment ,env)
  41          (declare (ignore ,args))
  42          (if (constantp ,form ,env)
  43              (eval ,form)
  44              ,form)))))