| 1 | (in-package :named-readtables) |
|---|
| 2 | |
|---|
| 3 | (defmacro define-api (name lambda-list type-list &body body) |
|---|
| 4 | (flet ((parse-type-list (type-list) |
|---|
| 5 | (let ((pos (position '=> type-list))) |
|---|
| 6 | (assert pos () "You forgot to specify return type (`=>' missing.)") |
|---|
| 7 | (values (subseq type-list 0 pos) |
|---|
| 8 | `(values ,@(nthcdr (1+ pos) type-list) &optional))))) |
|---|
| 9 | (multiple-value-bind (body decls docstring) |
|---|
| 10 | (parse-body body :documentation t :whole `(define-api ,name)) |
|---|
| 11 | (multiple-value-bind (arg-typespec value-typespec) |
|---|
| 12 | (parse-type-list type-list) |
|---|
| 13 | (multiple-value-bind (reqs opts rest keys) |
|---|
| 14 | (parse-ordinary-lambda-list lambda-list) |
|---|
| 15 | (declare (ignorable reqs opts rest keys)) |
|---|
| 16 | `(progn |
|---|
| 17 | (declaim (ftype (function ,arg-typespec ,value-typespec) ,name)) |
|---|
| 18 | (locally |
|---|
| 19 | ;;; Muffle the annoying "&OPTIONAL and &KEY found in |
|---|
| 20 | ;;; the same lambda list" style-warning |
|---|
| 21 | #+sbcl (declare (sb-ext:muffle-conditions style-warning)) |
|---|
| 22 | (defun ,name ,lambda-list |
|---|
| 23 | ,docstring |
|---|
| 24 | |
|---|
| 25 | #+sbcl (declare (sb-ext:unmuffle-conditions style-warning)) |
|---|
| 26 | |
|---|
| 27 | ,@decls |
|---|
| 28 | |
|---|
| 29 | ;; SBCL will interpret the ftype declaration as |
|---|
| 30 | ;; assertion and will insert type checks for us. |
|---|
| 31 | #-sbcl |
|---|
| 32 | (progn |
|---|
| 33 | ;; CHECK-TYPE required parameters |
|---|
| 34 | ,@(loop for req-arg in reqs |
|---|
| 35 | for req-type = (pop type-list) |
|---|
| 36 | do (assert req-type) |
|---|
| 37 | collect `(check-type ,req-arg ,req-type)) |
|---|
| 38 | |
|---|
| 39 | ;; CHECK-TYPE optional parameters |
|---|
| 40 | ,@(loop initially (assert (or (null opts) |
|---|
| 41 | (eq (pop type-list) '&optional))) |
|---|
| 42 | for (opt-arg . nil) in opts |
|---|
| 43 | for opt-type = (pop type-list) |
|---|
| 44 | do (assert opt-type) |
|---|
| 45 | collect `(check-type ,opt-arg ,opt-type)) |
|---|
| 46 | |
|---|
| 47 | ;; CHECK-TYPE rest parameter |
|---|
| 48 | ,@(when rest |
|---|
| 49 | (assert (eq (pop type-list) '&rest)) |
|---|
| 50 | (let ((rest-type (pop type-list))) |
|---|
| 51 | (assert rest-type) |
|---|
| 52 | `((dolist (x ,rest) |
|---|
| 53 | (check-type x ,rest-type))))) |
|---|
| 54 | |
|---|
| 55 | ;; CHECK-TYPE key parameters |
|---|
| 56 | ,@(loop initially (assert (or (null keys) |
|---|
| 57 | (eq (pop type-list) '&key))) |
|---|
| 58 | for ((keyword key-arg) . nil) in keys |
|---|
| 59 | for (nil key-type) = (find keyword type-list :key #'car) |
|---|
| 60 | collect `(check-type ,key-arg ,key-type))) |
|---|
| 61 | |
|---|
| 62 | ,@body)))))))) |
|---|
