July 2009 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv17183 Modified Files: functions.lisp Log Message: Add (setf funobj-type) and make-macro-function. --- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2006/05/02 20:01:46 1.31 +++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2009/07/19 18:58:33 1.32 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.31 2006/05/02 20:01:46 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.32 2009/07/19 18:58:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -79,6 +79,8 @@ (compiled-function (funobj-name edx)) (t '(unknown))))) +;; (when los0::*funbound-counter* +;; (incf (gethash function-name los0::*funbound-counter* 0))) (with-simple-restart (continue "Return NIL from ~S." function-name) (error 'undefined-function-call :name function-name @@ -92,7 +94,13 @@ (with-inline-assembly (:returns :untagged-fixnum-ecx) (:xorl :ecx :ecx) (:compile-form (:result-mode :eax) funobj) - (:movb (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:funobj-type)) :cl))) + (:movb (:eax (:offset movitz-funobj funobj-type)) :cl))) + +(defun (setf funobj-type) (type funobj) + (check-type funobj function) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj type) + (:movb :cl (:eax (:offset movitz-funobj funobj-type))))) (defun funobj-code-vector (funobj) (check-type funobj function) @@ -490,4 +498,16 @@ (defun fmakunbound (function-name) (setf (fdefinition function-name) - (load-global-constant unbound-function))) + (load-global-constant unbound-function)) + function-name) + +(defun make-macro-function (expander name) + "From a regular function, such as a (lambda (form env) ...), make a bona fide macro-function." + (let ((macro-function (install-funobj-name name + (lambda (&edx edx &optional form env (first-extra nil extras-p) &rest more-extras) + (declare (ignore first-extra more-extras)) + (verify-macroexpand-call edx name extras-p) + (funcall expander form env))))) + (setf (funobj-type macro-function) + #.(bt:enum-value 'movitz::movitz-funobj-type :macro-function)) + macro-function))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv17073 Modified Files: environment.lisp Log Message: Add *random-state* and gf documentation. --- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/27 19:40:25 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2009/07/19 18:57:48 1.19 @@ -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.18 2008/04/27 19:40:25 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.19 2009/07/19 18:57:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -189,4 +189,7 @@ (defstruct random-state state) +(defvar *random-state* #s(random-state :state 0)) +(defmethod documentation (x doc-type) + nil)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv16977 Modified Files: defmacro-runtime.lisp Log Message: Tweak defmacro. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/04/12 16:23:31 1.3 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2009/07/19 18:56:58 1.4 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-runtime.lisp,v 1.3 2008/04/12 16:23:31 ffjeld Exp $ +;;;; $Id: defmacro-runtime.lisp,v 1.4 2009/07/19 18:56:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -15,7 +15,7 @@ (provide :muerte/defmacro-runtime) -(defmacro defmacro (name lambda-list &body macro-body) +(defmacro/cross-compilation defmacro (name lambda-list &body macro-body) `(progn (defmacro/run-time ,name ,lambda-list ,@macro-body) (defmacro/compile-time ,name ,lambda-list ,macro-body)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv16782 Modified Files: conditions.lisp Log Message: Improved reporting of condition wrong-argument-count. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/21 19:31:54 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2009/07/19 18:54:32 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.28 2008/04/21 19:31:54 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.29 2009/07/19 18:54:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -179,7 +179,7 @@ :initarg :argument-count :reader condition-argument-count)) (:report (lambda (c s) - (format s "Function ~S ~:A received ~D arguments." + (format s "Function ~S ~:A received ~:[an incorrect number of~;~:*~D~] arguments." (funobj-name (condition-function c)) (funobj-lambda-list (condition-function c)) (condition-argument-count c)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv16602 Modified Files: complexes.lisp Log Message: Improved functions imagpart and realpart. --- /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp 2008/07/09 20:17:46 1.3 +++ /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp 2009/07/19 18:52:08 1.4 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: complexes.lisp,v 1.3 2008/07/09 20:17:46 ffjeld Exp $ +;;;; $Id: complexes.lisp,v 1.4 2009/07/19 18:52:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,8 +17,7 @@ (provide :muerte/complexes) -(defstruct (complex (:constructor make-complex-number) - (:conc-name #:||) +(defstruct (complex (:constructor make-complex (realpart imagpart)) (:predicate complexp)) realpart imagpart) @@ -28,5 +27,23 @@ (check-type imagpart real) (if (= 0 imagpart) realpart - (make-complex-number :realpart realpart - :imagpart imagpart))) + (make-complex realpart imagpart))) + +(defmethod print-object ((x complex) stream) + (format stream "#c(~W ~W)" + (complex-realpart x) + (complex-imagpart x))) + +(defun realpart (x) + (etypecase x + (complex + (complex-realpart x)) + (real + x))) + +(defun imagpart (x) + (etypecase x + (complex + (complex-imagpart x)) + (real + 0)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv16502 Modified Files: characters.lisp Log Message: Tweak char/= and char= for ansi-tests. --- /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2008/04/27 19:30:12 1.6 +++ /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2009/07/19 18:51:26 1.7 @@ -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.6 2008/04/27 19:30:12 ffjeld Exp $ +;;;; $Id: characters.lisp,v 1.7 2009/07/19 18:51:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,25 +53,23 @@ (defun char= (first-character &rest characters) (numargs-case (2 (x y) - (and (eql x y) 'pinglo)) + (eql x y)) (t (first-character &rest characters) (declare (dynamic-extent characters)) - (dolist (c characters 'dumbolo) + (dolist (c characters t) (unless (char= c first-character) (return nil)))))) (defun char/= (first-character &rest characters) (numargs-case + (1 (x) (declare (ignore x)) t) (2 (x y) (not (eql x y))) - (t (&rest characters) - (declare (dynamic-extent characters)) - (do ((p (cdr characters) (cdr p))) - ((null p) t) - (do ((v characters (cdr v))) - ((eq p v)) - (when (eql (car p) (car v)) - (return-from char/= nil))))))) - + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (do ((c first-character (pop more-characters))) + ((null more-characters) t) + (when (member c more-characters) + (return nil)))))) (defmacro/cross-compilation define-char-cmp (name mode not-branch) `(defun ,name (first-character &rest more-characters)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv16334 Modified Files: basic-macros.lisp Log Message: Improved ccase/ecase. Run-time define-symbol-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/07/09 20:08:52 1.77 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2009/07/19 18:49:22 1.78 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.77 2008/07/09 20:08:52 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.78 2009/07/19 18:49:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -348,16 +348,17 @@ ,@(mapcar (lambda (clause) (destructuring-bind (keys . forms) clause - (cond - ((or (eq keys 't) - (eq keys 'otherwise)) - `(t ,@forms)) - ((atom keys) - `((eql ,key-var ',keys) ,@forms)) - (t `((or ,@(mapcar (lambda (k) - `(eql ,key-var ',k)) - keys)) - ,@forms))))) + (let ((forms (or forms '(nil)))) + (cond + ((or (eq keys 't) + (eq keys 'otherwise)) + `(t ,@forms)) + ((not (listp keys)) + `((eql ,key-var ',keys) ,@forms)) + (t `((or ,@(mapcar (lambda (k) + `(eql ,key-var ',k)) + keys)) + ,@forms)))))) clauses))))) (define-compiler-macro case (keyform &rest clauses) @@ -374,19 +375,6 @@ `(compiled-case ,keyform ,@clauses)))))) (t `(compiled-case ,keyform ,@clauses)))) -(defmacro ecase (keyform &rest clauses) - (let ((ecase-var (gensym))) - `(let ((,ecase-var ,keyform)) - (case ,ecase-var - ,@clauses - (t (ecase-error ,ecase-var - ',(mapcan (lambda (clause) - (let ((x (car clause))) - (if (atom x) - (list x) - (copy-list x)))) - clauses))))))) - (define-compiler-macro asm-register (register-name) (if (member register-name '(:eax :ebx :ecx :untagged-fixnum-ecx :edx)) `(with-inline-assembly (:returns ,register-name) ()) @@ -549,16 +537,19 @@ (symbol-value movitz-name) movitz-value))) (declaim (muerte::constant-variable ,name)))) +(define-compile-time-variable *symbol-macros* (make-hash-table :test #'eq)) + (defmacro/cross-compilation define-symbol-macro (symbol expansion) (check-type symbol symbol "a symbol-macro symbol") `(progn (eval-when (:compile-toplevel) (movitz::movitz-env-add-binding nil (make-instance 'movitz::symbol-macro-binding - :name ',symbol - :expander (lambda (form env) - (declare (ignore form env)) - (movitz::translate-program ',expansion - :cl :muerte.cl))))) + :name ',symbol + :expander (lambda (form env) + (declare (ignore form env)) + (movitz::translate-program ',expansion + :cl :muerte.cl))))) + (setf (gethash ',symbol *symbol-macros*) ',expansion) ',symbol)) (defmacro check-type (place type &optional type-string)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Jul '09

19 Jul '09

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory cl-net:/tmp/cvs-serv12296 Modified Files: basic-functions.lisp Log Message: Fix a bug for apply with more than 255 arguments. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/04/21 19:31:10 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2009/07/19 18:32:34 1.28 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.27 2008/04/21 19:31:10 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.28 2009/07/19 18:32:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,8 +270,8 @@ (:subl :esp :ecx) (:shrl 2 :ecx) ;; Encode ECX - (:testb :cl :cl) - (:jns 'ecx-ok) + (:testl #xffffff80 :ecx) + (:jz 'ecx-ok) (:shll 8 :ecx) (:movb #xff :cl) ecx-ok

1 0