diff options
Diffstat (limited to 'third_party/lisp/alexandria/macros.lisp')
| -rw-r--r-- | third_party/lisp/alexandria/macros.lisp | 370 |
1 files changed, 0 insertions, 370 deletions
diff --git a/third_party/lisp/alexandria/macros.lisp b/third_party/lisp/alexandria/macros.lisp deleted file mode 100644 index 4364ad63b82a..000000000000 --- a/third_party/lisp/alexandria/macros.lisp +++ /dev/null @@ -1,370 +0,0 @@ -(in-package :alexandria) - -(defmacro with-gensyms (names &body forms) - "Binds a set of variables to gensyms and evaluates the implicit progn FORMS. - -Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL -STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL). - -Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL -should be bound to a symbol constructed using GENSYM with the string designated -by STRING-DESIGNATOR being its first argument." - `(let ,(mapcar (lambda (name) - (multiple-value-bind (symbol string) - (etypecase name - (symbol - (values name (symbol-name name))) - ((cons symbol (cons string-designator null)) - (values (first name) (string (second name))))) - `(,symbol (gensym ,string)))) - names) - ,@forms)) - -(defmacro with-unique-names (names &body forms) - "Alias for WITH-GENSYMS." - `(with-gensyms ,names ,@forms)) - -(defmacro once-only (specs &body forms) - "Constructs code whose primary goal is to help automate the handling of -multiple evaluation within macros. Multiple evaluation is handled by introducing -intermediate variables, in order to reuse the result of an expression. - -The returned value is a list of the form - - (let ((<gensym-1> <expr-1>) - ... - (<gensym-n> <expr-n>)) - <res>) - -where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order -to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of -evaluating the implicit progn FORMS within a special context determined by -SPECS. RES should make use of (reference) the intermediate variables. - -Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM). -Bare symbols are equivalent to the pair (SYMBOL SYMBOL). - -Each pair (SYMBOL INITFORM) specifies a single intermediate variable: - -- INITFORM is an expression evaluated to produce EXPR-i - -- SYMBOL is the name of the variable that will be bound around FORMS to the - corresponding gensym GENSYM-i, in order for FORMS to generate RES that - references the intermediate variable - -The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of -all the pairs are evaluated before binding SYMBOLs and evaluating FORMS. - -Example: - - The following expression - - (let ((x '(incf y))) - (once-only (x) - `(cons ,x ,x))) - - ;;; => - ;;; (let ((#1=#:X123 (incf y))) - ;;; (cons #1# #1#)) - - could be used within a macro to avoid multiple evaluation like so - - (defmacro cons1 (x) - (once-only (x) - `(cons ,x ,x))) - - (let ((y 0)) - (cons1 (incf y))) - - ;;; => (1 . 1) - -Example: - - The following expression demonstrates the usage of the INITFORM field - - (let ((expr '(incf y))) - (once-only ((var `(1+ ,expr))) - `(list ',expr ,var ,var))) - - ;;; => - ;;; (let ((#1=#:VAR123 (1+ (incf y)))) - ;;; (list '(incf y) #1# #1)) - - which could be used like so - - (defmacro print-succ-twice (expr) - (once-only ((var `(1+ ,expr))) - `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var))) - - (let ((y 10)) - (print-succ-twice (incf y))) - - ;;; >> - ;;; Expr: (INCF Y), Once: 12, Twice: 12" - (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) - (names-and-forms (mapcar (lambda (spec) - (etypecase spec - (list - (destructuring-bind (name form) spec - (cons name form))) - (symbol - (cons spec spec)))) - specs))) - ;; bind in user-macro - `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) - gensyms names-and-forms) - ;; bind in final expansion - `(let (,,@(mapcar (lambda (g n) - ``(,,g ,,(cdr n))) - gensyms names-and-forms)) - ;; bind in user-macro - ,(let ,(mapcar (lambda (n g) (list (car n) g)) - names-and-forms gensyms) - ,@forms))))) - -(defun parse-body (body &key documentation whole) - "Parses BODY into (values remaining-forms declarations doc-string). -Documentation strings are recognized only if DOCUMENTATION is true. -Syntax errors in body are signalled and WHOLE is used in the signal -arguments when given." - (let ((doc nil) - (decls nil) - (current nil)) - (tagbody - :declarations - (setf current (car body)) - (when (and documentation (stringp current) (cdr body)) - (if doc - (error "Too many documentation strings in ~S." (or whole body)) - (setf doc (pop body))) - (go :declarations)) - (when (and (listp current) (eql (first current) 'declare)) - (push (pop body) decls) - (go :declarations))) - (values body (nreverse decls) doc))) - -(defun parse-ordinary-lambda-list (lambda-list &key (normalize t) - allow-specializers - (normalize-optional normalize) - (normalize-keyword normalize) - (normalize-auxilary normalize)) - "Parses an ordinary lambda-list, returning as multiple values: - -1. Required parameters. - -2. Optional parameter specifications, normalized into form: - - (name init suppliedp) - -3. Name of the rest parameter, or NIL. - -4. Keyword parameter specifications, normalized into form: - - ((keyword-name name) init suppliedp) - -5. Boolean indicating &ALLOW-OTHER-KEYS presence. - -6. &AUX parameter specifications, normalized into form - - (name init). - -7. Existence of &KEY in the lambda-list. - -Signals a PROGRAM-ERROR is the lambda-list is malformed." - (let ((state :required) - (allow-other-keys nil) - (auxp nil) - (required nil) - (optional nil) - (rest nil) - (keys nil) - (keyp nil) - (aux nil)) - (labels ((fail (elt) - (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" - elt lambda-list)) - (check-variable (elt what &optional (allow-specializers allow-specializers)) - (unless (and (or (symbolp elt) - (and allow-specializers - (consp elt) (= 2 (length elt)) (symbolp (first elt)))) - (not (constantp elt))) - (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" - what elt lambda-list))) - (check-spec (spec what) - (destructuring-bind (init suppliedp) spec - (declare (ignore init)) - (check-variable suppliedp what nil)))) - (dolist (elt lambda-list) - (case elt - (&optional - (if (eq state :required) - (setf state elt) - (fail elt))) - (&rest - (if (member state '(:required &optional)) - (setf state elt) - (fail elt))) - (&key - (if (member state '(:required &optional :after-rest)) - (setf state elt) - (fail elt)) - (setf keyp t)) - (&allow-other-keys - (if (eq state '&key) - (setf allow-other-keys t - state elt) - (fail elt))) - (&aux - (cond ((eq state '&rest) - (fail elt)) - (auxp - (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" - elt lambda-list)) - (t - (setf auxp t - state elt)) - )) - (otherwise - (when (member elt '#.(set-difference lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux))) - (simple-program-error - "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" - elt lambda-list)) - (case state - (:required - (check-variable elt "required parameter") - (push elt required)) - (&optional - (cond ((consp elt) - (destructuring-bind (name &rest tail) elt - (check-variable name "optional parameter") - (cond ((cdr tail) - (check-spec tail "optional-supplied-p parameter")) - ((and normalize-optional tail) - (setf elt (append elt '(nil)))) - (normalize-optional - (setf elt (append elt '(nil nil))))))) - (t - (check-variable elt "optional parameter") - (when normalize-optional - (setf elt (cons elt '(nil nil)))))) - (push (ensure-list elt) optional)) - (&rest - (check-variable elt "rest parameter") - (setf rest elt - state :after-rest)) - (&key - (cond ((consp elt) - (destructuring-bind (var-or-kv &rest tail) elt - (cond ((consp var-or-kv) - (destructuring-bind (keyword var) var-or-kv - (unless (symbolp keyword) - (simple-program-error "Invalid keyword name ~S in ordinary ~ - lambda-list:~% ~S" - keyword lambda-list)) - (check-variable var "keyword parameter"))) - (t - (check-variable var-or-kv "keyword parameter") - (when normalize-keyword - (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))) - (cond ((cdr tail) - (check-spec tail "keyword-supplied-p parameter")) - ((and normalize-keyword tail) - (setf tail (append tail '(nil)))) - (normalize-keyword - (setf tail '(nil nil)))) - (setf elt (cons var-or-kv tail)))) - (t - (check-variable elt "keyword parameter") - (setf elt (if normalize-keyword - (list (list (make-keyword elt) elt) nil nil) - elt)))) - (push elt keys)) - (&aux - (if (consp elt) - (destructuring-bind (var &optional init) elt - (declare (ignore init)) - (check-variable var "&aux parameter")) - (progn - (check-variable elt "&aux parameter") - (setf elt (list* elt (when normalize-auxilary - '(nil)))))) - (push elt aux)) - (t - (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list))))))) - (values (nreverse required) (nreverse optional) rest (nreverse keys) - allow-other-keys (nreverse aux) keyp))) - -;;;; DESTRUCTURING-*CASE - -(defun expand-destructuring-case (key clauses case) - (once-only (key) - `(if (typep ,key 'cons) - (,case (car ,key) - ,@(mapcar (lambda (clause) - (destructuring-bind ((keys . lambda-list) &body body) clause - `(,keys - (destructuring-bind ,lambda-list (cdr ,key) - ,@body)))) - clauses)) - (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) - -(defmacro destructuring-case (keyform &body clauses) - "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND. -KEYFORM must evaluate to a CONS. - -Clauses are of the form: - - ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) - -The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE, -is selected, and FORMs are then executed with CDR of KEY is destructured and -bound by the DESTRUCTURING-LAMBDA-LIST. - -Example: - - (defun dcase (x) - (destructuring-case x - ((:foo a b) - (format nil \"foo: ~S, ~S\" a b)) - ((:bar &key a b) - (format nil \"bar: ~S, ~S\" a b)) - (((:alt1 :alt2) a) - (format nil \"alt: ~S\" a)) - ((t &rest rest) - (format nil \"unknown: ~S\" rest)))) - - (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" - (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" - (dcase (list :alt1 1)) ; => \"alt: 1\" - (dcase (list :alt2 2)) ; => \"alt: 2\" - (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" - - (defun decase (x) - (destructuring-case x - ((:foo a b) - (format nil \"foo: ~S, ~S\" a b)) - ((:bar &key a b) - (format nil \"bar: ~S, ~S\" a b)) - (((:alt1 :alt2) a) - (format nil \"alt: ~S\" a)))) - - (decase (list :foo 1 2)) ; => \"foo: 1, 2\" - (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" - (decase (list :alt1 1)) ; => \"alt: 1\" - (decase (list :alt2 2)) ; => \"alt: 2\" - (decase (list :quux 1 2 3)) ; =| error -" - (expand-destructuring-case keyform clauses 'case)) - -(defmacro destructuring-ccase (keyform &body clauses) - (expand-destructuring-case keyform clauses 'ccase)) - -(defmacro destructuring-ecase (keyform &body clauses) - (expand-destructuring-case keyform clauses 'ecase)) - -(dolist (name '(destructuring-ccase destructuring-ecase)) - (setf (documentation name 'function) (documentation 'destructuring-case 'function))) - - - |