destructuring

destructuring.lisp

;; -*- mode: lisp; package: destructuring; -*-

;;; destructuring-bind.l 
;; 
;; Copyright (c) 1980, Massachusetts Institute of Technology 
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are 
;; met:
;; Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; Neither the names of the Massachusetts Institute of Technology nor
;; the names of its contributors may be used to endorse or promote 
;; products derived from this software without specific prior written
;; permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:
;;
;; * MIT CADR Lispマシンのdestructuring-bindの定義をxyzzyに移植したものです。
;;   元は、>lispm2>defmac.lispで定義されています。
;;
;; * Common Lispのdestructuring-bindと概ね一緒ですが、&list-ofという引数が取
;;   れます。&list-ofは次の引数がリストでないとエラーになります。
;;

;; defpackage 
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((package (or (find-package "DESTRUCTURING")
		     (make-package "DESTRUCTURING" :use '("LISP")))))
    (shadow 'destructuring-bind)
    (export (mapcar #'(lambda (symbol-name) (intern symbol-name package))
		    '("DESTRUCTURING-BIND" "&LIST-OF")) package)
    package))

(in-package :destructuring)

(defun memq (item list)
  (member item list :test #'eq))

(defun ncons (obj)
  (list obj))

;; =======================================================================================
(defparameter defmacro-&body-flag nil)
(defparameter optional-specified-flags nil)
(defparameter *varlist* nil)
(defparameter *vallist* nil)

;; Put together the various bindings and the body.
;; The VARS are bound sequentially since their initializations may depend
;; on each other (in left-to-right fashion).
(defun defmacro2 (vars vals flags body)
  (cond (flags `((lambda ,flags ,(defmacro2 vars vals nil body))
                 . ,(make-list (length flags))))
        (vars `((lambda (,(car vars)) ,(defmacro2 (cdr vars) (cdr vals) nil body))
                ,(car vals)))
        ((cdr body) `(progn . ,body))
        (t (car body))))

(defmacro destructuring-bind (variables data &body body)
  (let (*varlist* *vallist* optional-specified-flags defmacro-&body-flag)
    (defmacro-&mumble-cheveux variables data 0 variables)
    (defmacro2 (nreverse *varlist*) (nreverse *vallist*) optional-specified-flags body)))

;; STATE is 0 for mandatory args, 1 for optional args, 2 for rest args, 3 for aux vars.
;; If it is 4 or more, the 4 bit signifies &LIST-OF and the low two bits
;; are as usual.
;; PATH is the form which, using CAR and CDR, would extract the part of the macro arg
;; which corresponds to this arg and the following args at the same level.
;; Thus, a simple arg would be set to `(CAR ,PATH).
;; PATTERN is the rest of the arglist at this level.
;; We push arg names on *VARLIST* and their appropriate values on *VALLIST*.
;; We return a pair describing what we know, so far, about how many args the macro wants:
;; the car is the number of required args, and the cdr is the
;; maximum allowed number of args, or nil if any number are allowed.
(defun defmacro-&mumble-cheveux (pattern path state epat)
       (cond ((null pattern) (cons 0 0))
             ((atom pattern)
              (cond ((> state 1) (error "~s -- bad pattern to defmacro." epat))
                    (t (defmacro-cheveux pattern path)
                       (ncons 0))))
             ((eq (car pattern) '&optional)
              (cond ((> state 0) (error "~s -- bad pattern to defmacro." epat))
                    (t (defmacro-&mumble-cheveux (cdr pattern) path 1 epat))))
             ((memq (car pattern) '(&rest &body))
              (and (eq (car pattern) '&body)
                   (setq defmacro-&body-flag t))
              (cond ((> state 1) (error "~s -- bad pattern to defmacro." epat))
                    (t (defmacro-&mumble-cheveux (cdr pattern) path 2 epat))))
             ((eq (car pattern) '&aux)
              (cond ((> state 2) (error "~s -- bad pattern to defmacro." epat))
                    (t (defmacro-&mumble-cheveux (cdr pattern) path 3 epat))))
             ((eq (car pattern) '&list-of)
              (cond ((< state 3)
                     (defmacro-&mumble-cheveux (cdr pattern) path (+ 4 state) epat))
                    (t (error "~s -- bad pattern to defmacro." epat))))
             ((= state 0)
              (defmacro-cheveux (car pattern) (list 'car path))
              (defmacro-required
               (defmacro-&mumble-cheveux (cdr pattern) (list 'cdr path) 0 epat)))
             ((= state 1)
              (cond ((atom (car pattern))
                     (defmacro-cheveux (car pattern)
                                       `(cond (,path (car ,path))
                                              (t nil))))
                    (t
                     (and (caddar pattern)
                          (push (caddar pattern) optional-specified-flags))
                     (defmacro-cheveux (caar pattern)
                                       `(cond (,path
                                               ,(and (caddar pattern)
                                                     `(setq ,(caddar pattern) t))
                                               (car ,path))
                                              (t ,(cadar pattern))))))
              (defmacro-optional
               (defmacro-&mumble-cheveux (cdr pattern) (list 'cdr path) 1 epat)))
             ((= state 2)
              (defmacro-cheveux (car pattern) path)
              (cond ((cdr pattern)
                     (and (or (atom (cdr pattern))
                              (not (eq (cadr pattern) '&aux)))
                          (error "~s -- bad pattern to defmacro." epat))
                     (defmacro-&mumble-cheveux (cddr pattern) path 3 epat)))
              (ncons 0))
             ((= state 3)
              (cond ((atom (car pattern))
                     (defmacro-cheveux (car pattern) nil))
                    (t (defmacro-cheveux (caar pattern) (cadar pattern))))
              (defmacro-&mumble-cheveux (cdr pattern) (list 'cdr path) 3 epat))
             ((= state 4)                               ;&list-of not optional
              (defmacro-&list-of-cheveux (car pattern) `(car ,path))
              (defmacro-required
               (defmacro-&mumble-cheveux (cdr pattern) `(cdr ,path) 0 epat)))
             ((= state 5)                               ;&list-of optional
              (and (atom (car pattern)) (error "~s -- bad pattern to defmacro." epat))
              (and (caddar pattern)
                   (push (caddar pattern) optional-specified-flags))
              (defmacro-&list-of-cheveux (caar pattern)
                                         `(cond (,path
                                                 ,(and (caddar pattern)
                                                       `(setq ,(caddar pattern) t))
                                                 (car ,path))
                                                (t ,(cadar pattern))))
              (defmacro-optional
               (defmacro-&mumble-cheveux (cdr pattern) `(cdr ,path) 1 epat)))
             ((= state 6)
              (defmacro-&list-of-cheveux (car pattern) path)
              (cond ((cdr pattern)
                     (and (or (atom (cdr pattern))
                              (not (eq (cadr pattern) '&aux)))
                          (error "~s -- bad pattern to defmacro." epat))
                     (defmacro-&mumble-cheveux (cddr pattern) path 3 epat)))
              (ncons 0))
             ))

(defun defmacro-&list-of-cheveux (pattern path)
  (setq *vallist*
        (let (*vallist* (vals *vallist*))
          (defmacro-cheveux pattern 'x)
          (do ((nvals (nreverse *vallist*) (cdr nvals))
               (vals vals
                     (cons `(mapcar (function
                                      (lambda (x) ,(car nvals)))
                                    ,path)
                           vals)))
              ((null nvals) vals)))))

(defun defmacro-cheveux (pattern path)
       (cond ((null pattern))
             ((atom pattern)
              (setq *varlist* (cons pattern *varlist*))
              (setq *vallist* (cons path *vallist*)))
             (t 
              (defmacro-cheveux (car pattern) (list 'car path))
              (defmacro-cheveux (cdr pattern) (list 'cdr path)))))

(defun defmacro-optional (pair)
       (cond ((null (cdr pair)) pair)
             (t (rplacd pair (1+ (cdr pair))))))

(defun defmacro-required (pair)
       (cond ((null (cdr pair)) (rplaca pair (1+ (car pair))))
             (t (rplaca (rplacd pair (1+ (cdr pair))) (1+ (car pair))))))

;;; destructuring-bind.l ends here