Browse code
chore: various tweaks
- improve eldoc for defclass+
- indentation changes
- add flag-sym to retry-once
Edward Langley authored on 23/11/2022 22:36:58Showing 2 changed files
| ... | ... |
@@ -22,62 +22,69 @@ |
| 22 | 22 |
initializer-syms))))) |
| 23 | 23 |
|
| 24 | 24 |
(defmacro defclass+ (name (&rest super) &body (direct-slots &rest options)) |
| 25 |
- (let* ((initargs (append (mapcan (lambda (class) |
|
| 26 |
- (typecase class |
|
| 27 |
- (cons (mapcar (lambda (it) |
|
| 28 |
- (list it nil)) |
|
| 29 |
- (cadr class))) |
|
| 30 |
- (t nil))) |
|
| 31 |
- super) |
|
| 32 |
- (mapcan (lambda (slot) |
|
| 33 |
- (alexandria:ensure-list |
|
| 34 |
- (alexandria:when-let ((initarg (getf (cdr slot) |
|
| 35 |
- :initarg))) |
|
| 36 |
- (fw.lu:prog1-bind |
|
| 37 |
- (it (list |
|
| 38 |
- (list (make-symbol (symbol-name initarg)) |
|
| 39 |
- (eq :missing |
|
| 40 |
- (getf (cdr slot) |
|
| 41 |
- :initform |
|
| 42 |
- :missing))))))))) |
|
| 43 |
- direct-slots)))) |
|
| 44 |
- (destructuring-bind (required optional) |
|
| 45 |
- (loop for it in initargs |
|
| 46 |
- if (second it) collect (first it) into required |
|
| 47 |
- else collect (first it) into optional |
|
| 48 |
- finally (return (list required |
|
| 49 |
- optional))) |
|
| 50 |
- (let ((passed-args (mapcar (lambda (it) |
|
| 51 |
- (make-symbol (concatenate 'string |
|
| 52 |
- (symbol-name it) |
|
| 53 |
- "-P"))) |
|
| 54 |
- optional))) |
|
| 55 |
- `(progn (defclass ,name |
|
| 56 |
- ,(mapcar (lambda (it) |
|
| 57 |
- (typecase it |
|
| 58 |
- (cons (car it)) |
|
| 59 |
- (t it))) |
|
| 60 |
- super) |
|
| 61 |
- ,direct-slots |
|
| 62 |
- ,@options) |
|
| 63 |
- (defun ,name (,@required ,@(when optional |
|
| 64 |
- (list* '&optional |
|
| 65 |
- (mapcar (lambda (it it-p) |
|
| 66 |
- `(,it nil ,it-p)) |
|
| 67 |
- optional |
|
| 68 |
- passed-args)))) |
|
| 69 |
- (declare (optimize (speed 3) (debug 0))) |
|
| 70 |
- ,(if optional |
|
| 71 |
- (let ((heads (reverse (inits optional)))) |
|
| 72 |
- `(cond ,@(mapcar (lambda (it it-p) |
|
| 73 |
- `(,it-p (fw.lu:new ',name ,@required ,@it))) |
|
| 74 |
- heads |
|
| 75 |
- passed-args) |
|
| 76 |
- (t (fw.lu:new ',name ,@required)))) |
|
| 77 |
- `(fw.lu:new ',name ,@required ,@optional)))))))) |
|
| 25 |
+ (let (constructor-type defclass-options) |
|
| 26 |
+ (mapc (lambda (option) |
|
| 27 |
+ (case (car option) |
|
| 28 |
+ ((:constructor-type) (setf constructor-type (cadr option))) |
|
| 29 |
+ (t (push option defclass-options)))) |
|
| 30 |
+ options) |
|
| 31 |
+ (let* ((initargs (append (mapcan (lambda (class) |
|
| 32 |
+ (typecase class |
|
| 33 |
+ (cons (mapcar (lambda (it) |
|
| 34 |
+ (list it nil)) |
|
| 35 |
+ (cadr class))) |
|
| 36 |
+ (t nil))) |
|
| 37 |
+ super) |
|
| 38 |
+ (mapcan (lambda (slot) |
|
| 39 |
+ (alexandria:ensure-list |
|
| 40 |
+ (alexandria:when-let ((initarg (getf (cdr slot) |
|
| 41 |
+ :initarg))) |
|
| 42 |
+ (fw.lu:prog1-bind |
|
| 43 |
+ (it (list |
|
| 44 |
+ (list (intern (symbol-name initarg)) |
|
| 45 |
+ (eq :missing |
|
| 46 |
+ (getf (cdr slot) |
|
| 47 |
+ :initform |
|
| 48 |
+ :missing))))))))) |
|
| 49 |
+ direct-slots)))) |
|
| 50 |
+ (destructuring-bind (required optional) |
|
| 51 |
+ (loop for it in initargs |
|
| 52 |
+ if (second it) collect (first it) into required |
|
| 53 |
+ else collect (first it) into optional |
|
| 54 |
+ finally (return (list required |
|
| 55 |
+ optional))) |
|
| 56 |
+ (let ((passed-args (mapcar (lambda (it) |
|
| 57 |
+ (intern (concatenate 'string |
|
| 58 |
+ (symbol-name it) |
|
| 59 |
+ "-P"))) |
|
| 60 |
+ optional))) |
|
| 61 |
+ `(progn (defclass ,name |
|
| 62 |
+ ,(mapcar (lambda (it) |
|
| 63 |
+ (typecase it |
|
| 64 |
+ (cons (car it)) |
|
| 65 |
+ (t it))) |
|
| 66 |
+ super) |
|
| 67 |
+ ,direct-slots |
|
| 68 |
+ ,@(nreverse defclass-options)) |
|
| 69 |
+ (defun ,name (,@required ,@(when optional |
|
| 70 |
+ (list* '&optional |
|
| 71 |
+ (mapcar (lambda (it it-p) |
|
| 72 |
+ `(,it nil ,it-p)) |
|
| 73 |
+ optional |
|
| 74 |
+ passed-args)))) |
|
| 75 |
+ (declare (optimize (speed 3) (debug 1))) |
|
| 76 |
+ ,(if optional |
|
| 77 |
+ (let ((heads (reverse (inits optional)))) |
|
| 78 |
+ `(cond ,@(mapcar (lambda (it it-p) |
|
| 79 |
+ `(,it-p (fw.lu:new ',name ,@required ,@it))) |
|
| 80 |
+ heads |
|
| 81 |
+ passed-args) |
|
| 82 |
+ (t (fw.lu:new ',name ,@required)))) |
|
| 83 |
+ `(fw.lu:new ',name ,@required ,@optional))))))))) |
|
| 78 | 84 |
|
| 79 | 85 |
(defun-ct %constructor-name (class) |
| 80 |
- (format nil "~a-~a" '#:make class)) |
|
| 86 |
+ (let ((*print-case* (readtable-case *readtable*))) |
|
| 87 |
+ (format nil "~a-~a" '#:make class))) |
|
| 81 | 88 |
|
| 82 | 89 |
(defmacro make-constructor (class &rest args) |
| 83 | 90 |
(destructuring-bind (class &optional (constructor-name (intern (%constructor-name class)))) |
| ... | ... |
@@ -346,12 +346,11 @@ |
| 346 | 346 |
(defun ,name ,args |
| 347 | 347 |
,@body))) |
| 348 | 348 |
|
| 349 |
-(defmacro retry-once (&body body) |
|
| 350 |
- (alexandria:with-gensyms (flag) |
|
| 351 |
- `(let ((,flag t)) |
|
| 349 |
+(defmacro retry-once ((flag-sym) &body body) |
|
| 350 |
+ `(let ((,flag-sym t)) |
|
| 352 | 351 |
(tagbody |
| 353 | 352 |
start |
| 354 | 353 |
,@body |
| 355 |
- (when ,flag |
|
| 356 |
- (setf ,flag nil) |
|
| 357 |
- (go start)))))) |
|
| 354 |
+ (when ,flag-sym |
|
| 355 |
+ (setf ,flag-sym nil) |
|
| 356 |
+ (go start))))) |