(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "16-Oct-86 14:42:33" {eris}<lispcore>sources>cmlmacros.\;3
 9091   

      |previous| |date:| " 4-Sep-86 18:22:28" {eris}<lispcore>sources>cmlmacros.\;2)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint cmlmacroscoms)

(rpaqq cmlmacroscoms
 ((fns clispexpansion \\interlisp-nlambda-macro cl:macro-function cl:macroexpand 
                           cl:macroexpand-1 setf-macro-function)
                      (appendvars (compilermacroprops dmacro bytemacro macro 
                                         should-have-macro-function))
                      (prop macro *)
                      (initvars (*macroexpand-hook* 'cl:funcall))
                      (functions cl:macrolet)
                      (setfs cl:macro-function)
                      (prop filetype cmlmacros)
                      (declare\: donteval@load doeval@compile dontcopy compilervars
                             (addvars (nlama)
                                    (nlaml)
                                    (lama cl:macroexpand-1 cl:macroexpand)))))
(defineq

(clispexpansion

  (lambda (x env)
                                            (* |lmm| "29-Jul-86 03:34")

    (cl:block clispexpansion (cl:values (or (and (getprop (car x)
                                                        'clispword)
                                                 (resetvars ((clispflg nil))
                                                            (let ((nospellflg t)
                                                                  (vars nil)
                                                                  (cop (copy x)))
                                                                 (declare
 (cl:special nospellflg vars
                                                                                 ))
                                                             (* |make| \a |copy| |so| |dwim| 

                                                             |doesn't| |muck| |with| |it!|)

                                                                 (dwimify0? cop cop cop nil nil nil
                                                                        'varsbound)
                                                                 (return (gethash cop clisparray)))))
                                            (cl:return-from clispexpansion x))
                                    t))))

(\\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

  (lambda (x env)
                                            (* |Pavel| " 6-Jun-86 12:18")

          
          (* * "If the given symbol has a macro definition in either the given lexical environment or globally, return its expansion function, else NIL.")


    (let (md)
         (cl:etypecase env (environment                      (* 

                                                             "Interpreter/code-walker's environments")

                                  (cond
                                     ((setq md (assoc x (environment-macros env)))
                                      (destructuring-bind (name defmacro-args &rest defmacro-body)
                                             md
                                             (cl:multiple-value-bind (parsed-body parsed-declarations 
                                                                            parsed-docstring)
                                                    (parse-defmacro defmacro-args '$$macro-form 
                                                           defmacro-body name nil :environment
                                                           '$$macro-environment)
                                                    `(lambda ($$macro-form $$macro-environment)
                                                       ,@parsed-declarations
                                                       (cl:block ,name ,parsed-body)))))
                                     (t (cl:macro-function
 x (environment-parent env)))))
                (env                                         (* "New compiler's environments.")

                     (cl:multiple-value-bind (kind expn-fn)
                            (env-fboundp env x)
                            (cl:if (eq kind :macro)
                                   expn-fn
                                   (cl:macro-function
 x nil))))
                (null (cond
                         ((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))))))))

(cl:macroexpand

  (cl:lambda (form &optional env)
                            (* "Pavel" "16-May-86 19:07")

          
          (* * "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 (flag)
               (cl:multiple-value-setq (form flag)
                      (cl:macroexpand-1
 form env))
               (cl:unless flag (return (cl:values form nil)))
           cl:loop
               (cl:multiple-value-setq (form flag)
                      (cl:macroexpand-1
 form env))
               (cl:if flag (go cl:loop)
                      (return (cl:values form t))))))

(cl:macroexpand-1

  (cl:lambda (form &optional env &aux def)
                   (* "Pavel" "16-May-86 19:08")

          
          (* * "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 form)
                  (cl:symbolp (car form)))
             (let ((def (cl:macro-function
 (car form)
                               env)))
                  (cond
                     (def (|if|
 (neq form (setq form (cl:funcall *macroexpand-hook* def form env)))
                              |then|
 (cl:values form t)
                            |else|
 (cl:values form nil)))
                     (t (cl:values form nil)))))
            (t (cl:values form nil)))))

(setf-macro-function

  (lambda (x body)
                                           (* |jrb:| "21-Aug-86 17:42")

    (prog1 (cl:setf (get x 'macro-fn)
                  body)
           (and (getd x)
                (fmemb (argtype x)
                       '(0 2))
                (progn (printout t t "Warning: will soon do PUTD on " x " because it now is a macro")
                       )))))
)

(appendtovar compilermacroprops
 dmacro bytemacro macro should-have-macro-function)

(putprops * macro
 ((x . y)
                   'x))

(rpaq? *macroexpand-hook*
 'cl:funcall)
(defmacro cl:macrolet
 (macrodefs &body body &environment env) (walk-form (cons 'progn body)
                                                                     :environment
                                                                     (make-environment :macros 
                                                                            macrodefs :parent 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
 cl:macroexpand-1 cl:macroexpand)
)
(putprops cmlmacros copyright ("Xerox Corporation" 1986))
(declare\: dontcopy
  (filemap (nil (1146 8175 (clispexpansion 1156 . 2514) (\\interlisp-nlambda-macro 2516 . 2883) (
cl:macro-function 2885 . 5899) (cl:macroexpand 5901 . 6800) (cl:macroexpand-1 6802 . 7765) (
setf-macro-function 7767 . 8173)))))
stop