CMLDESTRUCT

(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "16-May-90 13:05:47" {DSK}<usr>local>lde>lispcore>sources>CMLDESTRUCT.;2
 2660   

      changes to%:  (VARS CMLDESTRUCTCOMS)

      previous date%: "29-Apr-87 11:30:49" {DSK}<usr>local>lde>lispcore>sources>CMLDESTRUCT.;1)


(* ; "
Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLDESTRUCTCOMS)

(RPAQQ CMLDESTRUCTCOMS
 ((FUNCTIONS DESTRUCTURING-BIND DESTRUCTURING-SETQ 
                                   EXPAND-DESTRUCTURING-BIND)
                            
                            (* ;; "Arrange for the correct compiler to be used.")


                            (PROP FILETYPE CMLDESTRUCT)))

(DEFMACRO DESTRUCTURING-BIND
 (PATTERN FORM &BODY BODY &ENVIRONMENT ENV)
   (EXPAND-DESTRUCTURING-BIND PATTERN FORM BODY ENV))

(DEFMACRO DESTRUCTURING-SETQ
 (VARS VALUE)
   [IF
 (NULL VARS)
       THEN
 VALUE
     ELSEIF
 (NLISTP VARS)
       THEN
 `(SETQ ,VARS ,VALUE)
     ELSEIF
 (NULL (CDR VARS))
       THEN
 `(DESTRUCTURING-SETQ ,(CAR VARS)
                        (CAR ,VALUE))
     ELSEIF
 (LISTP VALUE)
       THEN
 [LET ((DV (GENSYM)))
                     `(LET ((,DV ,VALUE))
                           (DESTRUCTURING-SETQ ,(CAR VARS)
                                  (CAR ,DV))
                           (DESTRUCTURING-SETQ ,(CDR VARS)
                                  (CDR ,DV]
     ELSE
 `(PROGN (DESTRUCTURING-SETQ ,(CAR VARS)
                             (CAR ,VALUE))
                      (DESTRUCTURING-SETQ ,(CDR VARS)
                             (CDR ,VALUE])

(CL:DEFUN EXPAND-DESTRUCTURING-BIND
 (PATTERN FORM BODY ENVIRONMENT)

(* ;;; "A compiled function so that circularity of MULTIPLE-VALUE-BIND isn't caught.  DO NOT try to run with this function interpreted!")


   [LET ((WHOLE-VAR (GENSYM)))
        (CL:MULTIPLE-VALUE-BIND (CODE DECLARATIONS)
               (PARSE-DEFMACRO PATTERN WHOLE-VAR BODY 'DESTRUCTURING-BIND ENVIRONMENT :PATH WHOLE-VAR
                      :DOC-STRING-ALLOWED NIL)
               (CL:ASSERT (EQ (CAR CODE)
                              'LET*)
                      NIL "BUG: PARSE-DEFMACRO didn't return a LET* form.")
               `(,'LET* ((,WHOLE-VAR ,FORM)
                         ,@(CADR CODE))
                       ,@DECLARATIONS
                       ,@(CDDR CODE])



(* ;; "Arrange for the correct compiler to be used.")



(PUTPROPS CMLDESTRUCT
 FILETYPE
 CL:COMPILE-FILE)
(PUTPROPS CMLDESTRUCT COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP