changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/macs/collecting.lisp

changeset 698: 96958d3eb5b0
parent: 7c1383c08493
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; std/macs/collecting.lisp --- Collecting Macros
     2 
     3 ;; ported from CL-UTILITIES
     4 
     5 ;;; Code:
     6 (in-package :std/macs)
     7 
     8 ;; This should only be called inside of COLLECTING macros, but we
     9 ;; define it here to provide an informative error message and to make
    10 ;; it easier for SLIME (et al.) to get documentation for the COLLECT
    11 ;; function when it's used in the COLLECTING macro.
    12 (defun collect (thing)
    13   "Collect THING in the context established by the COLLECTING macro"
    14   (error "Can't collect ~S outside the context of the COLLECTING macro"
    15          thing))
    16 
    17 (defmacro collecting (&body body)
    18   "Collect things into a list forwards. Within the body of this macro,
    19 the COLLECT function will collect its argument into the list returned
    20 by COLLECTING."
    21   (with-gensyms (collector tail)
    22     `(let (,collector ,tail)
    23       (labels ((collect (thing)
    24                  (if ,collector
    25                      (setf (cdr ,tail)
    26                            (setf ,tail (list thing)))
    27                      (setf ,collector
    28                            (setf ,tail (list thing))))))
    29         ,@body)
    30       ,collector)))
    31 
    32 (defmacro with-collectors ((&rest collectors) &body body)
    33   "Collect some things into lists forwards. The names in COLLECTORS
    34 are defined as local functions which each collect into a separate
    35 list.  Returns as many values as there are collectors, in the order
    36 they were given."
    37   (%with-collectors-check-collectors collectors)
    38   (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
    39     `(let ,(loop for collector in collectors
    40                  for tail = (cdr (assoc collector gensyms-alist))
    41                  nconc (list collector tail))
    42       (labels ,(loop for collector in collectors
    43                      for tail = (cdr (assoc collector gensyms-alist))
    44                      collect `(,collector (thing)
    45                                (if ,collector
    46                                    (setf (cdr ,tail)
    47                                          (setf ,tail (list thing)))
    48                                    (setf ,collector
    49                                          (setf ,tail (list thing))))))
    50         ,@body)
    51       (values ,@collectors))))
    52 
    53 (defun %with-collectors-check-collectors (collectors)
    54   "Check that all of the COLLECTORS are symbols. If not, raise an error."
    55   (let ((bad-collector (find-if-not #'symbolp collectors)))
    56     (when bad-collector
    57       (error 'type-error
    58              :datum bad-collector
    59              :expected-type 'symbol))))
    60 
    61 (defun %with-collectors-gensyms-alist (collectors)
    62   "Return an alist mapping the symbols in COLLECTORS to gensyms"
    63   (mapcar #'cons collectors
    64           (mapcar (compose #'gensym
    65                            #'(lambda (x)
    66                                (format nil "~A-TAIL-" x)))
    67                   collectors)))