first commit

README

@@ -0,0 +1,67 @@
+X.LET-STAR is a binding utility for Common Lisp which currently combines:
+
+a) let*
+b) destructuring-bind
+c) multiple-value-bind
+d) with-slots
+e) "projection" of slot values of structure/object to normal values,
+   avoiding slot lookup every time the slot value is used in the scope
+   of let*
+
+It's trivially extendible with DEFINE-BINDER macro, and supports adding
+of customized declarations via DEFINE-DECLARATION-PROCESSING macro. 
+
+It's designed as drop-in replacement of common-list:let* (without any changes 
+in sources needed) and as almost drop-in replacement for metabang-bind.
+
+Main motivation for writing of this library was to get rid of metabang-bind 
+in my future libraries which is non-extendible, not nicely written, 
+has unreasonable complex codebase, generates spurious NILs in bodies after bindings
+(complicates metaprogramming) and still probably contain bugs.
+Just see it's code and compare it to X.LET-STAR
+
+X.LET-START shadows common-lisp:let* (since it's completely compatible with common-lisp:let*)
+To use the X.LET-STAR library, your defpackage should roughly look as:
+
+(defpackage :your-lib
+  (:use :common-lisp :x.let-star ...)
+  (:shadowing-import-from x.let-star let*) ;; the important line
+  ...)
+
+example:
+
+(let* (((d (e . f) &key (g :xxx)) '(:sdfg (:wert :dfg :tyu) :g 100))   ;; b)
+       ((:mval h i) (rem 1234 34))                                     ;; c)
+       ((:slot a (b-first b)) (make-xxx :a 123))                       ;; d)
+       ((:slotval (b-second b) c) (make-xxx :b 3245 :c 3456)))         ;; e)
+  (values d e f g h i a b-first b-second c))
+
+==>
+
+:SDFG
+:WERT
+(:DFG :TYU)
+100
+10
+NIL
+123
+NIL
+3245
+3456
+
+expansion:
+
+(DESTRUCTURING-BIND                                           ;; b)
+      (D (E . F) &KEY (G :XXX))                               ;; b)
+    '(:SDFG (:WERT :DFG :TYU) :G 100)                         ;; b)
+  (MULTIPLE-VALUE-BIND                                        ;; c)
+        (H I)                                                 ;; c)
+      (REM 1234 34)                                           ;; c)
+    (WITH-SLOTS (A (B-FIRST B)) (MAKE-XXX :A 123)             ;; d)
+      (LET ((#:VAL1041 (MAKE-XXX :B 3245 :C 3456)))           ;; e)
+        (LET ((B-SECOND (SLOT-VALUE #:VAL1041 'B)))           ;; e)
+          (LET ((C (SLOT-VALUE #:VAL1041 'C)))                ;; e)
+            (VALUES D E F G H I A B-FIRST B-SECOND C)))))))   
+
+More binders will be added in future as the need arises. 
+

declarations.lisp

@@ -0,0 +1,131 @@
+(in-package :x.let-star)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+  (defvar *declaration-specs* '())
+
+  ;; returns: hash-table var-name -> canonic declarations
+  ;;          not related body-declarations (optimize, ftype)
+  (defgeneric process-declaration (spec form))
+
+  (defmacro define-declaration-processing ((spec form) &body body)
+    (let ((spec-sym (gensym "SPEC")))
+      (when (member spec *declaration-specs*)
+        (error "~A declaration processing is already defined" spec))
+      `(progn
+         (push ',spec *declaration-specs*)
+         (defmethod process-declaration ((,spec-sym (eql ',spec)) ,form)
+           ,@body)))))
+
+(defparameter *lambda-list-markers* '(&key &body &rest &args &optional))
+
+(defun lambda-list-vars (list)
+  (let ((optional-or-key nil))
+    (mapcan (lambda (x)
+              (cond ((null x) nil)
+                    ((atom x) (list x))
+                    (t (lambda-list-vars x))))
+            (mapcar (lambda (x)
+                      (if (or (eq x '&optional) (eq x '&key))
+                          (prog1 nil (setf optional-or-key t))
+                          (unless (member x *lambda-list-markers*)
+                            (if optional-or-key
+                                (prog1 (if (consp x) (car x) x)
+                                  (setf optional-or-key nil))
+                                x))))
+                    (let ((last (last list)))
+                      (if (cdr last)
+                          (nconc (butlast list) (list (car last) (cdr last)))
+                          list))))))
+
+(defun strip-declarations (body &optional decls)
+  (if (and (consp (car body))
+           (eq (caar body) 'declare))
+      (strip-declarations (cdr body) (append decls (cdar body)))
+      (values body decls)))
+
+(defun merge-hash-tables (main-table other-table)
+  (maphash (lambda (key val0)
+             (let ((val (gethash key main-table)))
+               (setf (gethash key main-table)
+                     (nconc val (list val0)))))
+           other-table))
+
+(defun process-declarations (body)
+  (multiple-value-bind (body declarations)
+      (strip-declarations body)
+    (let ((variable-decls (make-hash-table :test #'eq)))
+      (if declarations
+          (let ((all-body-decls '()))
+            (dolist (declaration declarations)
+              (destructuring-bind (spec &rest form) declaration
+                (multiple-value-bind (canonic body-decls)
+                    (if (member spec *declaration-specs*)
+                        (process-declaration spec form)
+                        (process-declaration 'type declaration))
+                  (merge-hash-tables variable-decls canonic)
+                  (setf all-body-decls (nconc all-body-decls body-decls)))))
+            (values (if all-body-decls
+                        `((declare ,@all-body-decls) ,@body)
+                        body)
+                    variable-decls))
+          (values body variable-decls)))))
+
+(defun use-declaration (var variable-decls)
+  (prog1 (gethash var variable-decls)
+    (remhash var variable-decls)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun process-common-declaration (spec form &optional decl-form-fn)
+  (let ((canonic (make-hash-table :test #'eq))
+        (body-declarations '()))
+    (dolist (var form)
+      (let ((decl-form (or (and decl-form-fn
+                                (funcall decl-form-fn var))
+                           `(,spec ,var))))
+        (if (atom var)
+            (setf (gethash var canonic) decl-form)
+            (push decl-form body-declarations))))
+    (values canonic body-declarations)))
+
+(defun skip-declaration (spec form)
+  (values (make-hash-table :test #'eq)
+          (mapcar (lambda (var) `(,spec ,var)) form)))
+
+(define-declaration-processing (ignore form)
+  (process-common-declaration 'ignore form))
+
+(define-declaration-processing (ignorable form)
+  (process-common-declaration 'ignorable form))
+
+(define-declaration-processing (special form)
+  (process-common-declaration 'special form))
+
+(define-declaration-processing (dynamic-extent form)
+  (process-common-declaration 'dynamic-extent form))
+
+(define-declaration-processing (type form)
+  (destructuring-bind (type &rest vars) form
+    (process-common-declaration 'type vars (lambda (var) `(type ,type ,var)))))
+
+(define-declaration-processing (optimize form)
+  (skip-declaration 'optimize form))
+
+(define-declaration-processing (ftype form)
+  (skip-declaration 'ftype form))
+
+(define-declaration-processing (inline form)
+  (skip-declaration 'inline form))
+
+(define-declaration-processing (notinline form)
+  (skip-declaration 'notinline form))
+
+
+
+
+
+
+
+
+

let-star.lisp

@@ -0,0 +1,102 @@
+(in-package :x.let-star)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+  (defparameter *binder-specs* '())
+  (defgeneric expand-binding (spec var val decls body))
+
+  (flet ((parse-binding (form)
+           (if (atom form)
+               (values nil form nil nil)
+               (ecase (length form)
+                 (0 (values nil nil nil))
+                 (1 (values nil (first form) nil))
+                 (2 (destructuring-bind (var val) form
+                      (if (consp var)
+                          (if (member (car var) *binder-specs*)
+                              (values (car var) (cdr var) val)
+                              (values nil var val))
+                          (values nil var val))))))))
+
+    (defmacro let* ((&rest forms) &body body)
+      (multiple-value-bind (body variable-decls)
+          (process-declarations body)
+        (labels ((rec (forms)
+                   (destructuring-bind (form . forms) forms
+                     (multiple-value-bind (spec var val)
+                         (parse-binding form)
+                       (expand-binding spec
+                                       var
+                                       val
+                                       variable-decls
+                                       (if forms
+                                           (list (rec forms))
+                                           body))))))
+          (rec forms))))
+
+    (defmacro define-binder ((spec var val decls body) &body binder-body)
+      (let ((spec-sym (gensym "SPEC")))
+        `(progn
+           (pushnew ',spec *binder-specs*)
+           (defmethod expand-binding ((,spec-sym (eql ,spec)) ,var ,val ,decls ,body)
+             ,@binder-body))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-binder (nil (var (eql nil)) (val (eql nil)) decls body)
+  `(let ()
+     ,@body))
+
+(define-binder (nil var (val (eql nil)) decls body)
+  (let ((decl (use-declaration var decls)))
+    `(let (,var)
+       ,@(when decl `((declare ,@decl)))
+       ,@body)))
+
+(define-binder (nil (var list) val decls body)
+  (let ((decl (mapcan (lambda (x) (use-declaration x decls))
+                      (lambda-list-vars var))))
+    `(destructuring-bind ,var ,val
+       ,@(when decl `((declare ,@decl)))
+       ,@body)))
+
+(define-binder (nil var val decls body)
+  (let ((decl (use-declaration var decls)))
+    `(let ((,var ,val))
+       ,@(when decl `((declare ,@decl)))
+       ,@body)))
+
+(define-binder (:mval (var list) val decls body)
+  (let ((decl (mapcan (lambda (x) (use-declaration x decls))
+                      (lambda-list-vars var))))
+    `(multiple-value-bind ,var ,val
+       ,@(when decl `((declare ,@decl)))
+       ,@body)))
+
+(define-binder (:slot (var list) val decls body)
+  (let ((decl (mapcan (lambda (x) (use-declaration x decls))
+                      (lambda-list-vars var))))
+    `(with-slots ,var ,val
+       ,@(when decl `((declare ,@decl)))
+       ,@body)))
+
+(define-binder (:slotval (var list) val decls body)
+  (let ((val-sym (gensym "VAL")))
+    (labels ((rec (vars)
+               (destructuring-bind (var . rest) vars
+                 (multiple-value-bind (var-name slot-name)
+                     (cond ((atom var)
+                            (values var var))
+                           ((and (consp var) (eql (length var) 2))
+                            (values (car var) (cadr var)))
+                           (t
+                            (error "~A is invalid, expected VAR-NAME or (VAR-NAME SLOT-NAME)" var)))
+                   (let ((decl (use-declaration var-name decls)))
+                     `(let ((,var-name (slot-value ,val-sym ',slot-name)))
+                        ,@(when decl `((declare ,@decl)))
+                        ,@(if rest
+                              (list (rec rest))
+                              body)))))))
+      `(let ((,val-sym ,val))
+         ,(rec var)))))
+

package.lisp

@@ -0,0 +1,7 @@
+(in-package :cl-user)
+
+(defpackage :x.let-star
+  (:use :common-lisp)
+  (:shadow common-lisp:let*)
+  (:export #:let*))
+

x.let-star.asd

@@ -0,0 +1,11 @@
+(in-package :cl-user)
+
+(asdf:defsystem :x.let-star
+  :serial t
+  :components ((:file "package")
+               (:file "declarations")
+               (:file "let-star")))
+
+
+
+