;;;; 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)))