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 (defmacro %deffoldable (func argument-types return-type)
  10   `(sb-c:defknown ,func ,argument-types ,return-type (sb-c:foldable)
  11      :overwrite-fndb-silently t))
  12
  13 #-(or sbcl)
  14 (defmacro %deffoldable (&rest args)
  15   (declare (ignore args)))
  16
  17 (defun constantp (form &optional env)
  18   (cl:constantp (if (symbolp form)
  19                     (macroexpand form env)
  20                     form)
  21                 env))
  22
  23 (defun constant-form-value (form &optional env)
  24   (declare (ignorable env))
  25   #+clozure
  26   (ccl::eval-constant form)
  27   #+sbcl
  28   (sb-int:constant-form-value form env)
  29   #-(or clozure sbcl)
  30   (eval form))
  31
  32 (defmacro deffoldable (func &optional
  33                        (argument-types (list t))
  34                        (return-type t))
  35   (alexandria:with-gensyms (form env args)
  36     `(eval-when (:compile-toplevel :load-toplevel :execute)
  37        (%deffoldable ,func ,argument-types ,return-type)
  38        (define-compiler-macro ,func (&whole ,form &rest ,args
  39                                             &environment ,env)
  40          (declare (ignore ,args))
  41          (if (constantp ,form ,env)
  42              (constant-form-value ,form ,env)
  43              ,form)))))