diff --git a/README b/README new file mode 100644 index 0000000..746f059 --- /dev/null +++ b/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. + diff --git a/declarations.lisp b/declarations.lisp new file mode 100644 index 0000000..b5f9b2e --- /dev/null +++ b/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)) + + + + + + + + + diff --git a/let-star.lisp b/let-star.lisp new file mode 100644 index 0000000..1494383 --- /dev/null +++ b/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))))) + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..09ec386 --- /dev/null +++ b/package.lisp @@ -0,0 +1,7 @@ +(in-package :cl-user) + +(defpackage :x.let-star + (:use :common-lisp) + (:shadow common-lisp:let*) + (:export #:let*)) + diff --git a/x.let-star.asd b/x.let-star.asd new file mode 100644 index 0000000..219797d --- /dev/null +++ b/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"))) + + + +