src/letmac.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (in-package :maxima)
  10 ;; Destructuring DEFUN must be added to this at some point.
  11
  12 (defvar *let-macro-vals* nil)
  13
  14 ;; Kludge to avoid warning that a different file is redefining
  15 ;; LET and LET*.  SI has LET and LET* externed, so there is no
  16 ;; "illegally defining" warning.
  17
  18 (defmacro destructuring-let (pairs &body body)
  19   (do ((pairs pairs (cdr pairs))
  20        (vars nil)
  21        (*let-macro-vals* nil)
  22        (tem))
  23       ((null pairs)
  24        (cond ((not (null vars))
  25               `(cl:let ,(nreverse (loop for v in vars
  26                                      for w in *let-macro-vals*
  27                                      collect (list v w)))
  28                 ,@body))
  29              ((null (cdr body))
  30               (car body))
  31              (t `(progn . ,body))))
  32     (cond ((atom (car pairs))
  33            (or (symbolp (car pairs))
  34                (error "Garbage found in `let' pattern: ~S" (car pairs)))
  35            (setq vars (cons (car pairs) vars))
  36            (setq *let-macro-vals* (cons nil *let-macro-vals*)))
  37           (t
  38            (setq tem vars)
  39            (setq vars (let-macro-get-vars (caar pairs) vars))
  40            (or (eq tem vars)
  41                (setq body (nconc (let-macro-hair (caar pairs)
  42                                                  (cadar pairs)
  43                                                  *let-macro-vals*)
  44                                  body)))))))
  45
  46 (defun let-macro-get-vars (pattern vars)
  47   (cond ((null pattern) vars)
  48         ((atom pattern)
  49          (or (symbolp pattern)
  50              (error "Garbage found in `let' pattern: ~S" pattern))
  51          (setq *let-macro-vals* (cons nil *let-macro-vals*))
  52          (cons pattern vars))
  53         (t (let-macro-get-vars (cdr pattern)
  54                                (let-macro-get-vars (car pattern) vars)))))
  55
  56 (defmacro desetq (&rest p)
  57   (do ((p p (cddr p))
  58        (body nil)
  59        (tem))
  60       ((null p)
  61        `(progn . ,body))
  62     (cond ((atom (cdr p))
  63            (error "Odd number of args to `desetq': ~S" p))
  64           ((atom (car p))
  65            (or (symbolp (car p))
  66                (error "Garbage found in `desetq' pattern: ~S" (car p)))
  67            (and (null (car p))
  68                 (error "Bad `desetq' pattern: ~S" (car p)))
  69            (setq body (nconc body `((setq ,(car p) ,(cadr p))))))
  70           (t
  71            (setq tem (cons nil nil))
  72            (setq body (nconc body
  73                              `((setq ,(let-macro-get-last-var (car p))
  74                                 . ,tem)
  75                                . ,(let-macro-hair (car p) (cadr p) tem))))))))
  76
  77
  78 (defun let-macro-get-last-var (pattern)
  79   (cond ((atom pattern) pattern)
  80         (t
  81          (or (let-macro-get-last-var (cdr pattern))
  82              (let-macro-get-last-var (car pattern))))))
  83
  84 (defun let-macro-hair (pattern code cell)
  85   (cond ((null pattern) nil)
  86         ((atom pattern)
  87          (rplaca cell code)
  88          nil)
  89         (t
  90          (let ((avar (let-macro-get-last-var (car pattern)))
  91                (dvar (let-macro-get-last-var (cdr pattern))))
  92            (cond ((null avar)
  93                   (if (null dvar)
  94                       nil
  95                       (let-macro-hair (cdr pattern) `(cdr ,code) cell)))
  96                  ((null dvar)
  97                   (let-macro-hair (car pattern) `(car ,code) cell))
  98                  (t
  99                   (rplaca cell code)
 100                   (let ((acell (cons nil nil))
 101                         (dcell (cons nil nil)))
 102                     (cons `(setq ,avar . ,acell)
 103                           (nconc (let-macro-hair (car pattern) `(car ,dvar) acell)
 104                                  (cons `(setq ,dvar . ,dcell)
 105                                        (let-macro-hair (cdr pattern) `(cdr ,dvar) dcell)))))))))))
 106
 107 (defmacro destructuring-let* (pairs &body body)
 108   (cond ((loop for v in pairs
 109                 always (or (symbolp v) (and (consp v) (symbolp (car v)))))
 110          `(cl:let* ,pairs ,@body))
 111         (t
 112          (do ((a (reverse pairs) (cdr a))
 113               (b body `((destructuring-let (,(car a)) . ,b))))
 114              ((null a)
 115               (cond ((null (cdr b)) (car b))
 116                     (t `(progn . ,b))))))))
 117