90 lines
3.8 KiB
Common Lisp
90 lines
3.8 KiB
Common Lisp
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*-
|
|
|
|
(in-package #:let-plus)
|
|
|
|
(defun destructured-lambda-list-forms (lambda-list body)
|
|
"Return a list that can be spliced into function definitions (eg DEFUN, LAMBDA, FLET, LABELS).
|
|
|
|
The list starts with a lambda list, and is followed by a docstring (when provided), then a LET+ form that wraps declarations (when provided) and BODY.
|
|
|
|
Used internally, not exported."
|
|
(let+ (((&values body declarations documentation)
|
|
(parse-body body :documentation t))
|
|
((&values arguments bindings ignores)
|
|
(loop :for parameter :in lambda-list
|
|
:for argument = (gensym)
|
|
:collect argument :into arguments
|
|
:if (eq parameter '&ign) :collect argument :into ignores
|
|
:else :collect (list parameter argument) :into bindings
|
|
:finally (return (values arguments bindings ignores)))))
|
|
`(,arguments
|
|
,@(when documentation `(,documentation))
|
|
,@(when ignores `((declare (ignore ,@ignores))))
|
|
(let+ ,bindings
|
|
,@declarations
|
|
,@body))))
|
|
|
|
(define-let+-expansion (&flet+ (function-name lambda-list
|
|
&body function-body)
|
|
:uses-value? nil)
|
|
"&FLET that destructures its arguments using LET+."
|
|
`(let+ (((&flet ,function-name
|
|
,@(destructured-lambda-list-forms lambda-list function-body))))
|
|
,@body))
|
|
|
|
(define-let+-expansion (&labels+ (function-name lambda-list
|
|
&body function-body)
|
|
:uses-value? nil)
|
|
"&LABELS that destructures its arguments using LET+."
|
|
`(let+ (((&labels ,function-name
|
|
,@(destructured-lambda-list-forms lambda-list function-body))))
|
|
,@body))
|
|
|
|
(defmacro lambda+ (lambda-list &body body)
|
|
"LAMBDA that destructures its arguments using LET+."
|
|
`(lambda ,@(destructured-lambda-list-forms lambda-list body)))
|
|
|
|
(defmacro defun+ (name lambda-list &body body)
|
|
"DEFUN that destructures its arguments using LET+."
|
|
`(defun ,name ,@(destructured-lambda-list-forms lambda-list body)))
|
|
|
|
(defmacro define-structure-let+ ((name
|
|
&key (conc-name (symbolicate name #\-))
|
|
(r/w (symbolicate #\& name))
|
|
(r/o (symbolicate #\& name '#:-r/o)))
|
|
&rest slot-names)
|
|
"Define a LET+ expansion for accessing slots of a structure in a fixed order."
|
|
(let ((variable-name-pairs
|
|
(loop for slot-name in slot-names collect
|
|
``(,,slot-name ,',slot-name))))
|
|
`(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(define-let+-expansion (,r/w (,@slot-names))
|
|
,(format nil "LET+ form for slots of the structure ~A." name)
|
|
`(let+ (((&structure ,',conc-name ,,@variable-name-pairs) ,value))
|
|
,@body))
|
|
(define-let+-expansion (,r/o (,@slot-names))
|
|
,(format nil "LET+ form for slots of the structure ~A. Read-only."
|
|
name)
|
|
`(let+ (((&structure-r/o ,',conc-name ,,@variable-name-pairs)
|
|
,value))
|
|
,@body)))))
|
|
|
|
(define-let+-expansion (&fwrap (name))
|
|
"Wrap closure in the local function NAME. Calls to NAME will call the closure."
|
|
`(let+ (((&flet ,name (&rest arguments)
|
|
(apply ,value arguments))))
|
|
,@body))
|
|
|
|
(define-let+-expansion (&once-only specs :uses-value? nil)
|
|
"Expand to (ONCE-ONLY SPECS ...)."
|
|
`(once-only ,specs ,@body))
|
|
|
|
(define-let+-expansion (&with-gensyms names :uses-value? nil)
|
|
"Expand to (WITH-GENSYMS NAMES ...)."
|
|
`(with-gensyms ,names ,@body))
|
|
|
|
(define-let+-expansion (&complex (x y))
|
|
"Access real and imaginary part of the value. Read-only."
|
|
`(let ((,x (realpart ,value))
|
|
(,y (imagpart ,value)))
|
|
,@body))
|