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     (and (typep e 'simple-error)
  12          (search "overwriting old FUN-INFO"
  13                  (simple-condition-format-control e))))
  14
  15   (defmacro %deffoldable (func argument-types return-type)
  16     `(handler-bind (((satisfies defknown-redefinition-error-p) #'continue))
  17        (sb-c:defknown ,func ,argument-types ,return-type (sb-c:foldable)))))
  18
  19 #-(or sbcl)
  20 (defmacro %deffoldable (&rest args)
  21   (declare (ignore args)))
  22
  23 (defun constantp (form &optional env)
  24   (cl:constantp (if (symbolp form)
  25                     (macroexpand form env)
  26                     form)
  27                 env))
  28
  29 (defun constant-form-value (form &optional env)
  30   (declare (ignorable env))
  31   #+clozure
  32   (ccl::eval-constant form)
  33   #+sbcl
  34   (sb-int:constant-form-value form env)
  35   #-(or clozure sbcl)
  36   (eval form))
  37
  38 (defmacro deffoldable (func &optional
  39                        (argument-types (list t))
  40                        (return-type t))
  41   (alexandria:with-gensyms (form env args)
  42     `(eval-when (:compile-toplevel :load-toplevel :execute)
  43        (%deffoldable ,func ,argument-types ,return-type)
  44        (define-compiler-macro ,func (&whole ,form &rest ,args
  45                                             &environment ,env)
  46          (declare (ignore ,args))
  47          (if (constantp ,form ,env)
  48              (constant-form-value ,form ,env)
  49              ,form)))))