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

(FILECREATED "28-Oct-91 11:45:00" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLMACROS.;4|
 12775  

      changes to%:  (FNS CL:MACRO-FUNCTION)

      previous date%: "18-Sep-90 17:33:42" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLMACROS.;3|)


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

(PRETTYCOMPRINT CMLMACROSCOMS)

(RPAQQ CMLMACROSCOMS

       [(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION 
             \INTERLISP-NLAMBDA-MACRO CL:MACRO-FUNCTION CL:MACROEXPAND CL:MACROEXPAND-1 
             SETF-MACRO-FUNCTION)
        (APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO))
        (ADDVARS (GLOBALVARS COMPILERMACROPROPS))
        (PROP MACRO *)
        (FUNCTIONS CL:MACROLET)
        (SETFS CL:MACRO-FUNCTION)
        (PROP FILETYPE CMLMACROS)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])
(DEFINEQ

(CLISPEXPANSION

  [LAMBDA (X ENV)
                                            (* ; "Edited  4-Dec-86 01:19 by lmm")

          
          (* ;; "the macro function for all CLISP words. Expand X as a clisp macro.")


    (CL:VALUES (do
 (LET ((NOSPELLFLG T)
                         (LISPXHIST NIL)
                         (VARS NIL)
                         (COP (COPY X)))
                        (DECLARE
 (CL:SPECIAL NOSPELLFLG VARS LISPXHIST))
                                                             (* ; 

                                                          "make a copy so dwim doesn't muck with it!")

                        [COND
                           ((GETPROP (CAR X)
                                   'CLISPWORD)
                            (DWIMIFY0? COP COP COP NIL NIL NIL 'VARSBOUND)
                            (COND
                               ((NOT (CL:EQUAL COP X))       (* ; "made a change")

                                (RETURN COP))
                               ((SETQ COP (GETHASH COP CLISPARRAY))
                                (RETURN COP]
                        (CL:CERROR "Try expanding again." "Can't CLISP expand expression ~S." X)))
           T])

(GLOBAL-MACRO-FUNCTION

  [LAMBDA (X ENV)
                                            (* ; "Edited 22-Apr-87 19:07 by Pavel")


    (LET (MD)
         (COND
            [(AND (TYPEP ENV 'COMPILER:ENV)
                  (CL:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
                         (COMPILER:ENV-FBOUNDP ENV X)
                         (AND (EQ KIND :MACRO)
                              EXPN-FN]
            ((GET X 'MACRO-FN))
            ((CL:SPECIAL-FORM-P X)
             NIL)
            [[AND [NOT (FMEMB (ARGTYPE X)
                              '(0 2]
                  (FIND
 PROP IN
 COMPILERMACROPROPS
                     SUCHTHAT
 (AND (SETQ MD (GETPROP X PROP))
                                   (NOT (OR (LITATOM MD)
                                            (FMEMB (CAR MD)
                                                   '(APPLY APPLY*]
             `(LAMBDA (FORM ENV)
                (MACROEXPANSION FORM ',MD]
            ((AND (NOT (GETD X))
                  (GETPROP X 'CLISPWORD))
             (FUNCTION CLISPEXPANSION))
            ((FMEMB (ARGTYPE X)
                    '(1 3))
             (FUNCTION \INTERLISP-NLAMBDA-MACRO])

(LOCAL-MACRO-FUNCTION

  [LAMBDA (X ENV)
                                            (* ; "Edited 13-Apr-87 11:16 by Pavel")

    (AND ENV (CL:TYPECASE ENV [ENVIRONMENT                   (* ; "Interpreter's environments")

                                     (LET ((FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS ENV)
                                                           X)))
                                          (AND FN-DEFN (EQ (CAR FN-DEFN)
                                                           :MACRO)
                                               (CDR FN-DEFN]
                    (COMPILER:ENV                            (* ; "Compiler's environments.")

                           (CL:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
                                  (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
                                  (AND (EQ KIND :MACRO)
                                       EXPN-FN])

(LOCAL-SYMBOL-FUNCTION

  [LAMBDA (X ENV)
                                            (* ; "Edited 31-Jul-87 18:06 by amd")


    (AND ENV (CL:TYPECASE ENV [ENVIRONMENT                   (* ; "Interpreter's environments")


                                     (LET ((FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS ENV)
                                                           X)))
                                          (AND FN-DEFN (EQ (CAR FN-DEFN)
                                                           :FUNCTION)
                                               (CDR FN-DEFN]
                    (COMPILER:ENV                            (* ; "Compiler's environments.")


                           (CL:MULTIPLE-VALUE-BIND (KIND FN)
                                  (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
                                  (AND (EQ KIND :FUNCTION)
                                       FN])

(\INTERLISP-NLAMBDA-MACRO

  [LAMBDA (X ENV)
                                            (* lmm " 7-May-86 17:24")

    `(CL:FUNCALL (FUNCTION ,(CAR X))
            ,@(SELECTQ (ARGTYPE (CAR X))
                  (1 (MAPCAR (CDR X)
                            (FUNCTION KWOTE)))
                  (3 (LIST (KWOTE (CDR X))))
                  (SHOULDNT])

(CL:MACRO-FUNCTION

  [CL:LAMBDA (CL::X CL::ENV)
                             (* ; "Edited 28-Oct-91 11:44 by jds")

         (AND (CL:SYMBOLP CL::X)
              (NOT (LOCAL-SYMBOL-FUNCTION
 CL::X CL::ENV))
              (OR (LOCAL-MACRO-FUNCTION
 CL::X CL::ENV)
                  (GLOBAL-MACRO-FUNCTION
 CL::X CL::ENV])

(CL:MACROEXPAND

  [CL:LAMBDA (CL::FORM &OPTIONAL CL::ENV)
                    (* ; "Edited 13-Feb-87 23:47 by Pavel")


(* ;;; "If FORM is a macro call, then the form is expanded until the result is not a macro. Returns as multiple values, the form after any expansion has been done and T if expansion was done, or NIL otherwise. Env is the lexical environment to expand in, which defaults to the null environment.")


         (PROG (CL::FLAG)
               (CL:MULTIPLE-VALUE-SETQ (CL::FORM CL::FLAG)
                      (CL:MACROEXPAND-1
 CL::FORM CL::ENV))
               (CL:UNLESS CL::FLAG (RETURN (CL:VALUES CL::FORM NIL)))
           CL:LOOP
               (CL:MULTIPLE-VALUE-SETQ (CL::FORM CL::FLAG)
                      (CL:MACROEXPAND-1
 CL::FORM CL::ENV))
               (CL:IF CL::FLAG (GO CL:LOOP)
                      (RETURN (CL:VALUES CL::FORM T])

(CL:MACROEXPAND-1

  [CL:LAMBDA (CL::FORM &OPTIONAL CL::ENV)
                    (* ; "Edited 13-Feb-87 23:49 by Pavel")


(* ;;; "If form is a macro, expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating whether the form was, in fact, a macro. Env is the lexical environment to expand in, which defaults to the null environment.")


         (COND
            [(AND (CL:CONSP CL::FORM)
                  (CL:SYMBOLP (CAR CL::FORM)))
             (LET ((CL::DEF (CL:MACRO-FUNCTION
 (CAR CL::FORM)
                                   CL::ENV)))
                  (COND
                     (CL::DEF (CL:IF [NOT (EQ CL::FORM (CL:SETQ CL::FORM (CL:FUNCALL 
                                                                                *MACROEXPAND-HOOK* 
                                                                                CL::DEF CL::FORM 
                                                                                CL::ENV]
                                     (CL:VALUES CL::FORM T)
                                     (CL:VALUES CL::FORM NIL)))
                     (T (CL:VALUES CL::FORM NIL]
            (T (CL:VALUES CL::FORM NIL])

(SETF-MACRO-FUNCTION

  [LAMBDA (X BODY)
                                           (* ; "Edited 13-Feb-87 13:26 by Pavel")

          
          (* ;; "the SETF function for MACRO-FUNCTION ")

          
          (* ;; "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!")


    (PROG1 (CL:SETF (GET X 'MACRO-FN)
                  BODY)
           (AND (GETD X)
                (SELECTQ (ARGTYPE X)
                    ((1 3)                                   (* ; 

                                                           "Leave Interlisp nlambda definition alone")

                         )
                    (PUTD X NIL])
)

(APPENDTOVAR COMPILERMACROPROPS
 DMACRO BYTEMACRO MACRO)

(ADDTOVAR GLOBALVARS
 COMPILERMACROPROPS)

(PUTPROPS *
 MACRO
 ((X . Y)
                           'X))

(DEFMACRO CL:MACROLET
 (CL::MACRODEFS &BODY CL::BODY &ENVIRONMENT CL::ENV)
   (DECLARE
 (SPECVARS *BYTECOMPILER-IS-EXPANDING*))

   (* ;; "This macro for the old interpreter and compiler only.  The new interpreter has a special-form definition.  When the new compiler is expanding, we simply return a disguised version of the form.")


   (IF
 (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*)
       THEN
 (LET ((CL::NEW-ENV (COMPILER::MAKE-CHILD-ENV CL::ENV)))
                     (DECLARE
 (CL:SPECIAL *BC-MACRO-ENVIRONMENT*))
                     [FOR
 CL::FN IN
 CL::MACRODEFS
                        DO
 (COMPILER::ENV-BIND-FUNCTION CL::NEW-ENV (CAR CL::FN)
                                      :MACRO
                                      (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO CL::FN]
                     (CL:SETQ *BC-MACRO-ENVIRONMENT* CL::NEW-ENV)
                     (CONS 'CL:LOCALLY CL::BODY))
     ELSEIF
 (TYPEP CL::ENV 'COMPILER:ENV)
       THEN
 `(SI::%%MACROLET ,CL::MACRODEFS ,@CL::BODY)
     ELSE

     (LET* ((CL::NEW-ENV (\MAKE-CHILD-ENVIRONMENT CL::ENV))
            (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV)))
           (FOR
 CL::FN IN
 CL::MACRODEFS
              DO
 (CL:SETQ CL::FUNCTIONS
                            (LIST* (CAR CL::FN)
                                   [CONS :MACRO `(CL:LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT
                                                                   )
                                                        (CL:BLOCK ,(CAR CL::FN)
                                                            ,(PARSE-DEFMACRO (CADR CL::FN)
                                                                    'SI::$$MACRO-FORM
                                                                    (CDDR CL::FN)
                                                                    (CAR CL::FN)
                                                                    NIL :ENVIRONMENT 
                                                                    'SI::$$MACRO-ENVIRONMENT))]
                                   CL::FUNCTIONS)))
           (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV)
                  CL::FUNCTIONS)
           (WALK-FORM (CONS 'CL:LOCALLY CL::BODY)
                  :ENVIRONMENT CL::NEW-ENV))))

(CL:DEFSETF CL:MACRO-FUNCTION
 SETF-MACRO-FUNCTION)

(PUTPROPS CMLMACROS
 FILETYPE
 CL:COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 )
)
(PRETTYCOMPRINT CMLMACROSCOMS)

(RPAQQ CMLMACROSCOMS

       [(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION 
             \INTERLISP-NLAMBDA-MACRO CL:MACRO-FUNCTION CL:MACROEXPAND CL:MACROEXPAND-1 
             SETF-MACRO-FUNCTION)
        (APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO))
        (ADDVARS (GLOBALVARS COMPILERMACROPROPS))
        (PROP MACRO *)
        (FUNCTIONS CL:MACROLET)
        (SETFS CL:MACRO-FUNCTION)
        (PROP FILETYPE CMLMACROS)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA CL:MACRO-FUNCTION])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 CL:MACRO-FUNCTION)
)
(PUTPROPS CMLMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1177 8960 (CLISPEXPANSION 1187 . 2423) (GLOBAL-MACRO-FUNCTION 2425 . 3605) (
LOCAL-MACRO-FUNCTION 3607 . 4543) (LOCAL-SYMBOL-FUNCTION 4545 . 5479) (\INTERLISP-NLAMBDA-MACRO 5481
 . 5842) (CL:MACRO-FUNCTION 5844 . 6184) (CL:MACROEXPAND 6186 . 7074) (CL:MACROEXPAND-1 7076 . 8276) (
SETF-MACRO-FUNCTION 8278 . 8958)))))
STOP