[Small-cl-src] with-static-types

[Peter Wilson]

;;;; WITH-STATIC-TYPES macro
;;; A shorthand macro for specifying inline static types (the type x) without
;;; cluttering the code. As usual for static typing, avoid using it until
;;; fairly late in the optimization phase of your coding.
;;;
;;; This code has not been used anywhere besides the examples below and may
;;; still have undiscovered bugs.
;;;
;;; Be aware of name collisions between functions and variables. The macro
;;; currently only supports one namespace.
;;;
;;; TODO: Handle special forms in the body. Or at least LET.
;;; TODO: When handling LET, insert declarations for variables.
;;; TODO: Handle macros in the body. Probably just macroexpand them.
;;; TODO: Remove compile-time dependency on ITERATE package.
;;; 


(defpackage #:with-static-types 
  (:use #:cl)
  (:export #:with-static-types))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (in-package #:with-static-types)
  (require "iterate")
  (use-package '#:iterate))


(defun make-ring (x)
  "Create a circular list containing x."
  (let ((c (cons x nil)))
    (setf (cdr c) c)))


(defun lookup-type (typed-functions sym)
  "Deduce the type of sym using the typed-functions alist.
   Returns: t  value-or-return-type  argument-types"
  (flet ((assert-length=2 (x)
           (unless (eq (cddr x) nil)
             (error "WITH-STATIC-TYPES: Not expecting more than one
argument after ~S"
                    (car x)))))
    (let ((found (assoc sym typed-functions)))
      (if found
        (destructuring-bind (found return-type . args) found
          (let ((arg-types 
                  (if args 
                    (case (car args)
                      ((:argument-types :args)
                       (assert-length=2 args) (cadr args))
                      ((:all-arguments-type :arg)
                       (assert-length=2 args) (make-ring (cadr args)))
                      (t (if (> (list-length args) 1)
                           args
                           (make-ring (car args)))))
                    (make-ring return-type))))
            (return-from lookup-type (values found return-type arg-types))))
        nil))))

(defun apply-arg-types (typed-functions arg-types form)
"Construct (the)'s for the arguments in form using the typespecs in arg-types."
  (flet ((recurse (form) (list 'with-static-types typed-functions form)))
    (list* (car form)
           (iter (for (arg . a-rest) on (cdr form))
                 (for (type . t-rest) on arg-types)
                 (collect (list 'the type (recurse arg)))
                 (when (and (null t-rest) (not (null a-rest)))
                   (warn "WITH-STATIC-TYPES: More arguments than types
for~& form: ~S~& types: ~S"
                         form arg-types)
                   (dolist (a a-rest) (collect (recurse a))))))))

(defun with-types-helper (typed-functions body)
  (flet ((recurse (form) (list 'with-static-types typed-functions form)))
    (iter (for form in body)
          (if (consp form)
            (multiple-value-bind (found return-type arg-types)
                                 (lookup-type typed-functions (car form))
              (if found
                (collect (list 'the return-type
                               (apply-arg-types typed-functions
arg-types form)))
                ;TODO handle specials and macros here
                (collect (list* (car form) (mapcar #'recurse (cdr form))))))

            (multiple-value-bind (found return-type)
                                 (lookup-type typed-functions form)
              (if found
                (collect (list 'the return-type form))
                (collect form)))))))

(defmacro with-static-types (function-typespecs &body body)
"Insert type declarations around calls to specific functions.
Also happens to work with variables.
  
Usage: WITH-STATIC-TYPES ( spec ... ) body-form ...
 spec => ( sym result-and-arg-type )
       | ( sym result-type all-arg-type )
       | ( sym result-type arg-type-1 arg-type-2 ... )
       | ( sym result-type :ALL-ARGUMENTS-TYPE all-arg-type )
       | ( sym result-type :ARG all-arg-type )
       | ( sym result-type :ARGUMENT-TYPES ( arg-type-1 arg-type-2 ... ) )
       | ( sym result-type :ARGS ( arg-type-1 arg-type-2 ... ) )
Examples:
    (WITH-STATIC-TYPES ((+ FIXNUM)) (+ 1 2))
    --> (PROGN (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2))))
    ==> 3
    
    (WITH-STATIC-TYPES ((+ FIXNUM)
                 (/ RATIONAL FIXNUM))
                (/ 3 (+ 2 2)))
    --> (PROGN
          (THE RATIONAL
               (/ (THE FIXNUM 3) 
                  (THE FIXNUM 
                       (THE FIXNUM 
                            (+ (THE FIXNUM 1) 
                               (THE FIXNUM 2)))))))
    ==> 3/4
    
    (WITH-STATIC-TYPES ((+ FIXNUM)
                 (/ RATIONAL FIXNUM FIXNUM))
                (/ 3 (+ 2 2) 17))
    WARNING: WITH-STATIC-TYPES: More arguments than types for
     form: (/ 3 (+ 2 2) 17)
     types: (FIXNUM FIXNUM)
    --> (PROGN (THE RATIONAL
                    (/ (THE FIXNUM 3) 
                       (THE FIXNUM
                            (THE FIXNUM
                                 (+ (THE FIXNUM 1) 
                                    (THE FIXNUM 2))))
                       17)))
    ==> 3/68

    (WITH-STATIC-TYPES ((x FIXNUM)) x)
    --> (PROGN (THE FIXNUM x))
    ==> Undefined variable x
"
  (if body (list* 'progn (with-types-helper function-typespecs body))
    (warn "WITH-STATIC-TYPES: Null body. types: ~S" function-typespecs)))