April 2008 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6432 Modified Files: typep.lisp Log Message: Add bit-vector-p. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/21 19:43:57 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/27 19:45:43 1.60 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.59 2008/04/21 19:43:57 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.60 2008/04/27 19:45:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -601,6 +601,8 @@ (or (eq xdim '*) (eql xdim adim))) dimension-spec (array-dimensions x))))))) +(defun bit-vector-p (x) + (typep x 'bit-vector)) (defun arrayp (x) (typep x 'array))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6366 Modified Files: strings.lisp Log Message: Fix bug in string> & friends. --- /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/21 19:43:30 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/27 19:45:33 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 17:05:25 2001 ;;;; -;;;; $Id: strings.lisp,v 1.5 2008/04/21 19:43:30 ffjeld Exp $ +;;;; $Id: strings.lisp,v 1.6 2008/04/27 19:45:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,7 +52,11 @@ (return nil))))) (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) - (not (string-equal string1 string2 :start1 start1 :end1 end1 :start2 start2 :end2 end2))) + (not (string-equal string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2))) (defun string (name) (typecase name @@ -104,25 +108,6 @@ (t (setf between-words-p (not (char-alpha-p c))) (char-downcase c)))))))) -(defun string%<= (string1 string2 result= start1 end1 start2 end2) - (let ((mismatch (mismatch string1 string2 - :start1 start1 - :end1 end1 - :start2 start2 - :end2 end2 - :test #'char=))) - (cond - ((not mismatch) - (when result= - (or end1 (length string1)))) - ((>= mismatch (or end1 (length string1))) - mismatch) - ((>= mismatch (or end2 (length string2))) - nil) - (t (when (char< (char string1 mismatch) - (char string2 mismatch)) - mismatch))))) - (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) "=> mismatch-index" (let ((mismatch (mismatch string1 string2 @@ -134,12 +119,14 @@ (cond ((not mismatch) nil) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char< (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) (defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) @@ -153,12 +140,14 @@ (cond ((not mismatch) (or end1 (length string1))) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char<= (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) (defun string> (string1 string2 result= start1 end1 start2 end2) @@ -172,12 +161,14 @@ (cond ((not mismatch) nil) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char> (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) (defun string>= (string1 string2 result= start1 end1 start2 end2) @@ -191,10 +182,12 @@ (cond ((not mismatch) (or end1 (length string1))) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char>= (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6179 Modified Files: sequences.lisp Log Message: Add various foo-if and foo-if-not operators. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/21 19:28:46 1.41 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/27 19:44:55 1.42 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.41 2008/04/21 19:28:46 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.42 2008/04/27 19:44:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1078,7 +1078,7 @@ (when (test item (key (car p))) (incf n))))))))))) -(defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) +(defun count-if (predicate sequence &key (start 0) end (key 'identity) from-end) (numargs-case (2 (predicate sequence) (with-funcallable (predicate) @@ -1098,7 +1098,9 @@ (when (predicate (sequence-ref i)) (incf count))) count)))))) - (t (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) + (t (predicate sequence &key (start 0) end (key 'identity) from-end) + (when from-end + (error "count-if from-end not implemented.")) (let ((start (check-the index start))) (with-funcallable (predicate) (with-funcallable (key) @@ -1122,6 +1124,32 @@ (vector (error "vector count-if not implemented."))))))))) +(defun count-if-not (predicate sequence &key (start 0) end (key 'identity) from-end) + (numargs-case + (2 (predicate sequence) + (with-funcallable (predicate) + (do-sequence-dispatch sequence + (list + (let ((count 0)) + (declare (index count)) + (dolist (x sequence) + (when (not (predicate x)) + (incf count))) + count)) + (vector + (with-subvector-accessor (sequence-ref sequence) + (let ((count 0)) + (declare (index count)) + (dotimes (i (length sequence)) + (when (not (predicate (sequence-ref i))) + (incf count))) + count)))))) + (t (predicate sequence &rest keys) + (apply #'count-if + (complement predicate) + sequence + keys)))) + (macrolet ((every-some-body () "This function body is shared between every and some." @@ -2009,6 +2037,10 @@ (return sequence))))) ((error 'program-error)))))))))) +(defun substitute-if-not (newitem predicate sequence &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'substitute-if newitem (complement predicate) sequence keyargs)) + (defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'nsubstitute-if newitem (complement predicate) sequence keyargs))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5962 Modified Files: packages.lisp Log Message: Add package-used-by-list. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/23 18:47:46 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/27 19:43:37 1.17 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.16 2008/04/23 18:47:46 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.17 2008/04/27 19:43:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -249,8 +249,32 @@ (apropos-symbol symbol string))))) (values)) +(defun package-used-by-list (package) + "Return a list of all packages that use package." + (let ((package (find-package package))) + (let ((used-by-list nil)) + (maphash (lambda (name other-package) + (declare (ignore name)) + (when (member package + (package-object-use-list other-package) + :test #'eq) + (pushnew other-package used-by-list))) + *packages*) + used-by-list))) + +(defun list-all-packages () + (with-hash-table-iterator (p *packages*) + (do (packages) (nil) + (multiple-value-bind (more k v) + (p) + (declare (ignore k)) + (when (not more) + (return packages)) + (push v packages))))) + + (defmacro with-package-iterator ((name package-list-form &rest symbol-types) &body body) `(macrolet ((,name () '(warn "with-package-iterator not implemented." (values nil nil nil nil)))) - ,@body)) \ No newline at end of file + ,@body))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5879 Modified Files: more-macros.lisp Log Message: Add movitz-macroexpand/-1 as macros. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/19 12:44:40 1.45 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/27 19:43:18 1.46 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.45 2008/04/19 12:44:40 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.46 2008/04/27 19:43:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -580,4 +580,9 @@ (declare (ignore ignore)) 'compiler-macro name) - \ No newline at end of file + +(defmacro movitz-macroexpand (&rest args) + `(macroexpand ,@args)) + +(defmacro movitz-macroexpand-1 (&rest args) + `(macroexpand-1 ,@args))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5697 Modified Files: los-closette-compiler.lisp Log Message: Remember to decode lambda formals. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2008/04/12 16:47:18 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2008/04/27 19:42:26 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.22 2008/04/12 16:47:18 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.23 2008/04/27 19:42:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1003,6 +1003,7 @@ (defun canonicalize-defgeneric-option (option) (case (car option) + (declare nil) (:generic-function-class (list ':generic-function-class `(movitz-find-class ',(cadr option)))) @@ -1507,7 +1508,7 @@ (defun compute-primary-emfun (methods) (if (null methods) nil - (let ((next-emfun (compute-primary-emfun (cdr methods)))) + (let ((next-emfun (compute-primary-emfun (cdr methods)))) '(lambda (args) (funcall (method-function (car methods)) args next-emfun))))) @@ -1526,8 +1527,10 @@ (let* ((block-name (compute-function-block-name name)) (analysis (analyze-lambda-list lambda-list)) (lambda-variables (append (getf analysis :required-args) - (getf analysis :optional-args) - (getf analysis :key-args) + (mapcar #'decode-optional-formal + (getf analysis :optional-args)) + (mapcar #'decode-keyword-formal + (getf analysis :key-args)) (when (getf analysis :rest-var) (list (getf analysis :rest-var))))) (required-variables (subseq lambda-variables

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5415 Modified Files: loop.lisp Log Message: Get loop working in run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/04/17 19:30:43 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/04/27 19:41:42 1.10 @@ -66,17 +66,17 @@ (provide :muerte/loop :load-priority 1) -#+movitz -(progn - (defmacro movitz-macroexpand (&rest args) - `(macroexpand ,@args)) - (defmacro movitz-macroexpand-1 (&rest args) - `(macroexpand-1 ,@args)) - (eval-when (:compile-toplevel) - (defmacro movitz-macroexpand (&rest args) - `(movitz::movitz-macroexpand ,@args)) - (defmacro movitz-macroexpand-1 (&rest args) - `(movitz::movitz-macroexpand-1 ,@args)))) +;; #+movitz +;; (progn +;; (defmacro movitz-macroexpand (&rest args) +;; `(macroexpand ,@args)) +;; (defmacro movitz-macroexpand-1 (&rest args) +;; `(macroexpand-1 ,@args)) +;; (eval-when (:compile-toplevel) +;; (defmacro movitz-macroexpand (&rest args) +;; `(movitz::movitz-macroexpand ,@args)) +;; (defmacro movitz-macroexpand-1 (&rest args) +;; `(movitz::movitz-macroexpand-1 ,@args)))) ;;;This is the "current" loop context in use when we are expanding a ;;;loop. It gets bound on each invocation of LOOP. @@ -271,48 +271,48 @@ (head-var tail-var &optional user-head-var) form) (declare #+LISPM (ignore head-var user-head-var)) ;use locatives, unconditionally update through the tail. - (setq form (movitz-macroexpand form env)) - (flet ((cdr-wrap (form n) - (declare (fixnum n)) - (do () ((<= n 4) (setq form `(,(case n - (1 'cdr) - (2 'cddr) - (3 'cdddr) - (4 'cddddr)) - ,form))) - (setq form `(cddddr ,form) n (- n 4))))) - (let ((tail-form form) (ncdrs nil)) - ;;Determine if the form being constructed is a list of known length. - (when (consp form) - (cond ((eq (car form) 'list) - (setq ncdrs (1- (length (cdr form)))) - ;;@@@@ Because the last element is going to be RPLACDed, - ;; we don't want the cdr-coded implementations to use - ;; cdr-nil at the end (which would just force copying - ;; the whole list again). - #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) - ((member (car form) '(list* cons)) - (when (and (cddr form) (member (car (last form)) '(nil 'nil))) - (setq ncdrs (- (length (cdr form)) 2)))))) - (let ((answer - (cond ((null ncdrs) - `(when (setf (cdr ,tail-var) ,tail-form) - (setq ,tail-var (last (cdr ,tail-var))))) - ((< ncdrs 0) (return-from loop-collect-rplacd nil)) - ((= ncdrs 0) - ;;@@@@ Here we have a choice of two idioms: - ;; (rplacd tail (setq tail tail-form)) - ;; (setq tail (setf (cdr tail) tail-form)). - ;;Genera and most others I have seen do better with the former. - `(rplacd ,tail-var (setq ,tail-var ,tail-form))) - (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) - ncdrs)))))) - ;;If not using locatives or something similar to update the user's - ;; head variable, we've got to set it... It's harmless to repeatedly set it - ;; unconditionally, and probably faster than checking. - #-LISPM (when user-head-var - (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) - answer)))) + (let ((form (movitz-macroexpand form env))) + (flet ((cdr-wrap (form n) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) + (let ((tail-form form) (ncdrs nil)) + ;;Determine if the form being constructed is a list of known length. + (when (consp form) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form)))) + ;;@@@@ Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) + (let ((answer + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;;@@@@ Here we have a choice of two idioms: + ;; (rplacd tail (setq tail tail-form)) + ;; (setq tail (setf (cdr tail) tail-form)). + ;;Genera and most others I have seen do better with the former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) + ncdrs)))))) + ;;If not using locatives or something similar to update the user's + ;; head variable, we've got to set it... It's harmless to repeatedly set it + ;; unconditionally, and probably faster than checking. + #-LISPM (when user-head-var + (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) + answer))))) (defmacro loop-collect-answer (head-var &optional user-head-var)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4943 Modified Files: integers.lisp Log Message: Improved /=. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/21 19:40:32 1.127 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/27 19:41:10 1.128 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.127 2008/04/21 19:40:32 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.128 2008/04/27 19:41:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -309,14 +309,23 @@ (define-number-relational /= /=%2op nil :defun-p nil) -(defun /= (&rest numbers) - (declare (dynamic-extent numbers)) - (do ((p (cdr numbers) (cdr p))) - ((null p) t) - (do ((v numbers (cdr v))) - ((eq p v)) - (when (= (car p) (car v)) - (return-from /= nil))))) +(defun /= (first-number &rest more-numbers) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (/=%2op x y)) + (t (first-number &rest more-numbers) + (declare (dynamic-extent more-numbers)) + (dolist (y more-numbers) + (when (= first-number y) + (return nil))) + (do ((p more-numbers (cdr p))) + ((null p) t) + (dolist (q (cdr p)) + (when (= (car p) q) + (return nil))))))) ;;;;

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3529 Modified Files: environment.lisp Log Message: Trace and untrace macros. --- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/21 19:39:24 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/27 19:40:25 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.17 2008/04/21 19:39:24 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.18 2008/04/27 19:40:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,6 +108,15 @@ wrapper))) (values)) +(defmacro trace (&rest names) + (if (null names) + `(mapcar #'car *trace-map*) + `(progn + ,@(mapcar (lambda (name) + `(do-trace ',name)) + names) + (values)))) + (defun do-untrace (name) (let ((map (assoc name *trace-map*))) (assert map () "~S is not traced." name) @@ -119,6 +128,16 @@ (delete name *trace-map* :key 'car)))) (values)) +(defmacro untrace (&rest names) + (if (null names) + '(do () ((null muerte::*trace-map*)) + (do-untrace (caar muerte::*trace-map*))) + `(progn + ,@(mapcar (lambda (name) + `(do-untrace ',name)) + names) + (values)))) + (defun time-skew-measure (mem x-lo x-hi) (declare (ignore mem)) (multiple-value-bind (y-lo y-hi)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 27 Apr '08

27 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2754 Modified Files: defmacro-bootstrap.lisp Log Message: improved defmacro. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/21 19:38:48 1.4 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/27 19:37:08 1.5 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-bootstrap.lisp,v 1.4 2008/04/21 19:38:48 ffjeld Exp $ +;;;; $Id: defmacro-bootstrap.lisp,v 1.5 2008/04/27 19:37:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,9 +17,12 @@ (`(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))))) + (let ((movitz-package-name (movitz::movitzify-package-name name))) + `(progn + (eval-when (:compile-toplevel) + (in-package ,movitz-package-name)) + (eval-when (:execute) + (set '*package* (find-package ',movitz-package-name)))))) (in-package #:muerte) @@ -37,7 +40,7 @@ (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator) (parse-macro-lambda-list lambda-list) (let* ((block-name (compute-function-block-name name)) - (extras (gensym)) + (extras (gensym "extras-")) (form-var (or whole-var (gensym "form-")))) (cond @@ -50,12 +53,13 @@ (block ,block-name (numargs-case (2 (&edx edx &optional ,form-var ,env-var) + (declare (ignore ,@ignore-env)) (verify-macroexpand-call edx ',name) (let () (declare ,@declarations) ,@real-body)) (t (&edx edx &optional ,form-var ,env-var &rest ,extras) - (declare (ignore ,form-var ,extras)) + (declare (ignore ,form-var ,extras ,@ignore-env)) (verify-macroexpand-call edx ',name t)))) :type :macro-function)) (t `(make-named-function ,name @@ -65,12 +69,13 @@ (block ,block-name (numargs-case (2 (&edx edx ,form-var ,env-var) + (declare (ignore ,@ignore-env)) (verify-macroexpand-call edx ',name) (destructuring-bind ,destructuring-lambda-list ,form-var (declare (ignore ,@ignore-operator) ,@declarations) ,@real-body)) (t (&edx edx &optional ,form-var ,env-var &rest ,extras) - (declare (ignore ,form-var ,extras)) + (declare (ignore ,form-var ,extras ,@ignore-env)) (verify-macroexpand-call edx ',name t)))) :type :macro-function)))))))

1 0