Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 83 lines (70 sloc) 3.542 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
;;; -*- 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))
         (arguments (loop repeat (length lambda-list) collect (gensym))))
    `(,arguments
      ,@(when documentation `(,documentation))
      (let+ ,(mapcar #'list lambda-list arguments)
        ,@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))
Something went wrong with that request. Please try again.