[movitz-cvs] CVS movitz/losp/muerte - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

17 Mar 2008


      Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv25010
Added Files:
    defmacro-bootstrap.lisp 
Log Message:
Working on making macros work.
--- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/03/17 08:00:46	NONE
+++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/03/17 08:00:46	1.1
;;;;------------------------------------------------------------------
;;;; 
;;;;    Copyright (C) 2008, Frode V. Fjeld
;;;; 
;;;; Filename:      defmacro-bootstrap.lisp
;;;; Author:        Frode Vatvedt Fjeld
;;;; Created at:    Wed Nov  8 18:44:57 2000
;;;; Distribution:  See the accompanying file COPYING.
;;;;                
;;;; $Id: defmacro-bootstrap.lisp,v 1.1 2008/03/17 08:00:21 ffjeld Exp $
;;;;                
;;;;------------------------------------------------------------------
(provide :muerte/defmacro-bootstrap)
(muerte::defmacro-compile-time muerte.cl:defmacro (name lambda-list &body macro-body)
  (`(muerte::defmacro-compile-time ,name ,lambda-list ,macro-body)))
(muerte.cl:defmacro muerte.cl:in-package (name)
  `(progn
     (eval-when (:compile-toplevel)
       (in-package ,(movitz::movitzify-package-name name)))))
(in-package #:muerte)
(defmacro defmacro/cross-compilation (name lambda-list &body body)
  `(progn
     (defmacro-compile-time ,name ,lambda-list ,body)
     ',name))
(defmacro defmacro (name lambda-list &body body)
  `(defmacro/cross-compilation ,name ,lambda-list ,@body))
(defmacro defmacro/runtime (name lambda-list &body body)
  (multiple-value-bind (real-body declarations docstring)
      (movitz::parse-docstring-declarations-and-body body 'cl:declare)
    (let* ((block-name (compute-function-block-name name))
       (ignore-var (gensym))
       (form-var (gensym "form-"))
       (env-var nil)
       (operator-var (gensym))
       (destructuring-lambda-list
        (do ((l lambda-list)
    	 (r nil))
    	((atom l)
    	 (cons operator-var
    	       (nreconc r l)))
          (let ((x (pop l)))
    	(if (eq x '&environment)
    	    (setf env-var (pop l))
    	    (push x r))))))
      (multiple-value-bind (env-var ignore-env)
      (if env-var
          (values env-var nil)
          (let ((e (gensym)))
    	(values e (list e))))
    `(make-named-function ,name
    		      (&edx edx &optional ,form-var ,env-var &rest ,ignore-var)
    		      ((ignore ,ignore-var ,@ignore-env))
    		      ,docstring
    		      (block ,block-name
    			(verify-macroexpand-call edx ',name)
    			(destructuring-bind ,destructuring-lambda-list
    			    ,form-var
    			  (declare (ignore ,operator-var) ,@declarations)
    			  ,@real-body))
    		      :type :macro-function)))))