From ingvar at cathouse.bofh.se  Wed Jun 15 06:22:25 2005
From: ingvar at cathouse.bofh.se (Ingvar)
Date: Wed, 15 Jun 2005 07:22:25 +0100
Subject: [Small-cl-src] "Fast floats" macro(s)
Message-ID: <E1DiRIA-0000Ac-00@head.cathouse.bofh.se>

;;; There recently was a discussion about using arrays with suitably-declared
;;; element-type s to store floats without needing boxing and unboxing.
;;; This is obviously quite a hassle, as and when one wants to use.
;;;
;;; But, this is lisp and macros are (as always) ready to leap to the rescue.
;;; This code is Copyright Ingvar Mattsson, 2005 <ingvar at hexapodia.net>
;;; You are free to use and/or modify this code as you see fit, as long
;;; as this comment block is retained and modifications noted by at least
;;; the modifyer's name.
(defpackage #:net.hexapodia.fastfloats
  (:nicknames #:fastfloats)
  (:use #:cl)
  (:export #:double-float-let #:single-float-let :float-let))
(in-package #:net.hexapodia.fastfloats)

(defun float-let-expander (type initform body)
  (let ((syms (loop for spec in initform
		    for n from 0
		    if (symbolp spec)
		      collect (cons spec n)
		    else
		      collect (cons (car spec) n)))
	(inits (loop for spec in initform
		     unless (symbolp spec)
		       collect (list (gensym) spec)))
	(storage (gensym)))    
    `(let ,(loop for (sym spec) in inits
		 collect (list sym (cadr spec)))
       (let ((,storage (make-array ,(length syms)
				   :element-type ',type
				   :initial-element (coerce 0.0 ',type))))
	 (symbol-macrolet ,(loop for (sym . n) in syms
				 collect (list sym (list 'aref storage n)))
	   ; Init section
	   ,@(loop for (sym val) in inits
		   collect (list 'setf (car val) sym))
	   , at body)))))

(defmacro double-float-let (initform &body body)
  (float-let-expander 'double-float initform body))

(defmacro single-float-let (initform &body body)
  (float-let-expander 'single-float initform body))

(defmacro float-let (initform &body body)
  (float-let-expander *read-default-float-format* initform body))
;;; //Ingvar