[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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 , at 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 , at ignore-env))
			      ,docstring
			      (block ,block-name
				(verify-macroexpand-call edx ',name)
				(destructuring-bind ,destructuring-lambda-list
				    ,form-var
				  (declare (ignore ,operator-var) , at declarations)
				  , at real-body))
			      :type :macro-function)))))