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-serv1906 Modified Files: cons.lisp Log Message: Tiny comment tweak. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2007/02/22 21:23:04 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2008/04/27 19:30:27 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.17 2007/02/22 21:23:04 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.18 2008/04/27 19:30:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -80,7 +80,7 @@ (define-primitive-function fast-cdr-ebx () "This is the actual CDR code. -Cons cell is in EBX, which is preserved." +Cons cell is in EBX, which is preserved. Result in EAX." (with-inline-assembly (:returns :eax) (:leal (:ebx -1) :ecx) (:testb 3 :cl)

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-serv1813 Modified Files: characters.lisp Log Message: Add some missing char-foo functions. --- /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2008/03/15 20:57:27 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2008/04/27 19:30:12 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 5 19:05:01 2001 ;;;; -;;;; $Id: characters.lisp,v 1.5 2008/03/15 20:57:27 ffjeld Exp $ +;;;; $Id: characters.lisp,v 1.6 2008/04/27 19:30:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,6 +29,9 @@ (:jne '(:sub-program (not-a-character) (:int 66))) (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax))) +(defun char-int (c) + (char-code c)) + (defun code-char (code) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) code) @@ -138,7 +141,9 @@ (defun char-equal (first-character &rest more-characters) (numargs-case - (1 (x) (declare (ignore x)) t) + (1 (x) + (declare (ignore x)) + t) (2 (x y) (char= (char-upcase x) (char-upcase y))) (t (first-character &rest more-characters) @@ -148,6 +153,71 @@ (unless (char= f (char-upcase c)) (return nil))))))) +(defun char-not-equal (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (not (char= (char-upcase x) (char-upcase y)))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (not (apply #'char-equal first-character more-characters))))) + +(defun char-lessp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (char< (char-upcase x) + (char-upcase y))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (let ((x (char-upcase first-character))) + (dolist (y more-characters t) + (unless (char< x (setf x (char-upcase y))) + (return nil))))))) + +(defun char-not-lessp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (not (char< (char-upcase x) + (char-upcase y)))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (not (apply #'char-lessp first-character more-characters))))) + +(defun char-greaterp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (char> (char-upcase x) + (char-upcase y))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (let ((x (char-upcase first-character))) + (dolist (y more-characters t) + (unless (char> x (setf x (char-upcase y))) + (return nil))))))) + +(defun char-not-greaterp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (not (char> (char-upcase x) + (char-upcase y)))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (not (apply #'char-greaterp first-character more-characters))))) + (defun standard-char-p (c) "CLHS 2.1.3 Standard Characters" (or (char<= #\A (char-upcase c) #\Z) @@ -217,3 +287,13 @@ (char= character #\Return) (char= character #\Tab) (char= character #\Linefeed))) + +(defun character (c) + (etypecase c + (character c) + ((string 1) + (char c 0)) + (symbol + (character (symbol-name c))))) + +

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-serv1287 Modified Files: arithmetic-macros.lisp Log Message: Fix constant-folding for logand. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/04/21 19:29:17 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/04/27 19:26:14 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.22 2008/04/21 19:29:17 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.23 2008/04/27 19:26:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -305,22 +305,28 @@ finally (return (if (= -1 folded-constant) non-constants (cons folded-constant non-constants)))))) - (case (length constant-folded-integers) - (0 0) - (1 (first constant-folded-integers)) - (2 (cond - ((typep (first constant-folded-integers) - '(unsigned-byte 32)) - (let ((x (first constant-folded-integers))) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte ,(integer-length x))) - (:compile-form (:result-mode :untagged-fixnum-ecx) - ,(second constant-folded-integers)) - (:andl ,x :ecx)))) - (t `(no-macro-call logand - ,(first constant-folded-integers) - ,(second constant-folded-integers))))) - (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers)) + (cond + ((null constant-folded-integers) + 0) + ((null (rest constant-folded-integers)) + (first constant-folded-integers)) + ((eql 0 (first constant-folded-integers)) + `(progn ,@(rest constant-folded-integers) 0)) + ((null (cddr constant-folded-integers)) + (cond + ((typep (first constant-folded-integers) + '(unsigned-byte 32)) + (let ((x (first constant-folded-integers))) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte ,(integer-length x))) + (:compile-form (:result-mode :untagged-fixnum-ecx) + ,(second constant-folded-integers)) + (:andl ,x :ecx)))) + (t `(no-macro-call logand + ,(first constant-folded-integers) + ,(second constant-folded-integers))))) + (t `(logand (logand ,(first constant-folded-integers) + ,(second constant-folded-integers)) ,@(cddr constant-folded-integers)))))) (define-compiler-macro logior (&whole form &rest integers &environment env) @@ -410,7 +416,7 @@ (t form))) (define-compiler-macro ldb (&whole form &environment env bytespec integer) - (let ((bytespec (movitz::movitz-macroexpand bytespec env))) + (let ((bytespec (movitz-macroexpand bytespec env))) (if (not (and (consp bytespec) (eq 'byte (car bytespec)))) form `(ldb%byte ,(second bytespec) ,(third bytespec) ,integer))))

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv659 Modified Files: storage-types.lisp Log Message: Remove old movitz-eql. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/12 16:26:56 1.64 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/27 19:23:25 1.65 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.64 2008/04/12 16:26:56 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.65 2008/04/27 19:23:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -237,13 +237,6 @@ (print-unreadable-object (x stream) (format stream "MOVITZ-CHARACTER: ~S" (movitz-char x)))) -(defun movitz-eql (x y) - (if (and (typep x 'movitz-immediate-object) - (typep y 'movitz-immediate-object)) - (= (movitz-immediate-value x) - (movitz-immediate-value y)) - (eq x y))) - ;;; Code element (define-binary-class movitz-code (movitz-immediate-object)

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv576 Modified Files: special-operators-cl.lisp Log Message: Fix eval-when for :compile-toplevel, must actually be top-level. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/11 22:09:39 1.53 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2008/04/27 19:23:14 1.54 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.53 2007/04/11 22:09:39 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.54 2008/04/27 19:23:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -992,7 +992,8 @@ :top-level-p top-level-p :form body) (compiler-values ())) - (when (member :compile-toplevel situations) + (when (and (member :compile-toplevel situations) + top-level-p) (with-compilation-unit () (dolist (toplevel-form (translate-program body :muerte.cl :cl :when :eval

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32667 Modified Files: parse.lisp Log Message: Fix bug in decode-normal-lambda-list. --- /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 21:09:47 1.9 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/27 19:22:42 1.10 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.9 2008/04/21 21:09:47 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.10 2008/04/27 19:22:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,9 +23,7 @@ (defun parse-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the list of non-declaration forms, ~ second the list of declaration-specifiers." - (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol) - (pop forms)) - if (declare-form-p (car forms) declare-symbol) + (loop if (declare-form-p (car forms) declare-symbol) append (cdr (pop forms)) into declarations else return (values forms declarations))) @@ -45,7 +43,7 @@ (pop lambda-list) (pop lambda-list))) (env-var nil) - (operator-var (gensym)) + (operator-var (gensym "operator-")) (destructuring-lambda-list (do ((l lambda-list) (r nil)) @@ -58,7 +56,7 @@ (push x r))))) (ignore-env-var (when (not env-var) - (gensym)))) + (gensym "ignore-env-")))) (values destructuring-lambda-list whole-var (or env-var @@ -208,14 +206,14 @@ (auxes (nreverse (getf results (aux))))) (when (> (length rests) 1) (error "There can only be one &REST formal parameter.")) - (let ((maxargs (and (null rests) ; max num. of arguments, or nil. - (null keys) - (not allow-other-keys-p) - (+ (length requireds) - (length optionals)))) - (minargs (length requireds)) - (keys-p (not (eq :missing - (getf results (key) :missing))))) + (let* ((keys-p (not (eq :missing ; &key present? + (getf results (key) :missing)))) + (maxargs (and (null rests) ; max num. of arguments, or nil. + (not keys-p) + (not allow-other-keys-p) + (+ (length requireds) + (length optionals)))) + (minargs (length requireds))) (return (values requireds optionals (first rests) @@ -223,14 +221,14 @@ auxes allow-other-keys-p minargs - (unless keys-p - maxargs) + maxargs edx-var (cond - ((or (eql maxargs minargs) - (eq :no-key (getf results (key) :no-key))) + ((or (not keys-p) + (eql maxargs minargs)) nil) - ((assert (not maxargs))) + ((assert (not maxargs) () + "Weird maxargs ~S for ~S." maxargs lambda-list)) ((evenp (+ (length requireds) (length optionals))) :even) (t :odd))

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv30486 Modified Files: packages.lisp Log Message: more muerte symbols. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/04/21 19:46:02 1.60 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/04/27 19:20:06 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.60 2008/04/21 19:46:02 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.61 2008/04/27 19:20:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1236,6 +1236,10 @@ #:parse-docstring-declarations-and-body #:parse-macro-lambda-list #:compute-function-block-name + #:movitz-macroexpand + #:movitz-macroexpand-1 + #:decode-optional-formal + #:decode-keyword-formal #:movitz-accessor #:%object-lispval @@ -1395,6 +1399,10 @@ muerte::parse-macro-lambda-list muerte::unfold-circular-list muerte::compute-function-block-name + muerte::movitz-macroexpand + muerte::movitz-macroexpand-1 + muerte::decode-optional-formal + muerte::decode-keyword-formal ))

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv30109 Modified Files: image.lisp Log Message: indent. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/21 19:45:51 1.123 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/27 19:18:16 1.124 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.123 2008/04/21 19:45:51 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.124 2008/04/27 19:18:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1240,15 +1240,13 @@ 'package) (movitz-read (ensure-package (string :common-lisp) :muerte.common-lisp))) (loop for symbol being the hash-key of (image-oblist *image*) - as lisp-package = (symbol-package symbol) - as package-name = (and lisp-package - (movitz-package-name (package-name lisp-package) symbol)) -;;; do (when (string= symbol :method) -;;; (warn "XXXX ~S ~S ~S" symbol lisp-package package-name)) - when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) - (setf (movitz-symbol-package (movitz-read symbol)) - (movitz-read movitz-package)))) + as lisp-package = (symbol-package symbol) + as package-name = (and lisp-package + (movitz-package-name (package-name lisp-package) symbol)) + when package-name + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) + (setf (movitz-symbol-package (movitz-read symbol)) + (movitz-read movitz-package)))) movitz-packages))))

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29953 Modified Files: eval.lisp Log Message: Don't coerce to function. --- /project/movitz/cvsroot/movitz/eval.lisp 2007/03/11 21:18:40 1.12 +++ /project/movitz/cvsroot/movitz/eval.lisp 2008/04/27 19:17:17 1.13 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.12 2007/03/11 21:18:40 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.13 2008/04/27 19:17:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,10 +76,17 @@ ((muerte.cl:quote) t) ((muerte.cl:not) (movitz-constantp (second form))) - ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) (every (lambda (sub-form) (movitz-constantp sub-form env)) - (cdr form))))) + (cdr form))) + ((muerte.cl:coerce) + (and (= 3 (length form)) + (every (lambda (sub-form) + (movitz-constantp sub-form env)) + (cdr form)) + (not (member (movitz-eval (third form) env) + '(muerte.cl:function))))))) (and compiler-macro-function (not (movitz-env-get (car form) 'notinline nil env)) (not (eq form compiler-macro-expansion))

1 0

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

27 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29743 Modified Files: environment.lisp Log Message: indent. --- /project/movitz/cvsroot/movitz/environment.lisp 2008/03/15 20:44:53 1.23 +++ /project/movitz/cvsroot/movitz/environment.lisp 2008/04/27 19:16:16 1.24 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.23 2008/03/15 20:44:53 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.24 2008/04/27 19:16:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -332,28 +332,28 @@ (let ((expander (movitz-macro-function (car movitz-form) env))) (if (not expander) (values movitz-form nil) - (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env) - :muerte.cl :cl) - t)))) + (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env) + :muerte.cl :cl) + t)))) (symbol (let ((binding (movitz-binding movitz-form env))) (if (not (typep binding 'symbol-macro-binding)) (values movitz-form nil) - (values (translate-program (funcall *movitz-macroexpand-hook* - (macro-binding-expander binding) - movitz-form env) - :muerte.cl :cl) - t)))) + (values (translate-program (funcall *movitz-macroexpand-hook* + (macro-binding-expander binding) + movitz-form env) + :muerte.cl :cl) + t)))) (t (values movitz-form nil))))) (defun movitz-macroexpand (form &optional env) (let ((global-expanded-p nil)) (loop while - (multiple-value-bind (expansion expanded-p) - (movitz-macroexpand-1 form env) - (when expanded-p - (setf form expansion) - (setf global-expanded-p expanded-p)))) + (multiple-value-bind (expansion expanded-p) + (movitz-macroexpand-1 form env) + (when expanded-p + (setf form expansion) + (setf global-expanded-p expanded-p)))) (values form global-expanded-p))) (define-symbol-macro *movitz-global-environment*

1 0