May 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/x86-pc/serial.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv21517 Modified Files: serial.lisp Log Message: Header update. Date: Thu May 20 14:16:13 2004 Author: ffjeld Index: movitz/losp/x86-pc/serial.lisp diff -u movitz/losp/x86-pc/serial.lisp:1.1.1.1 movitz/losp/x86-pc/serial.lisp:1.2 --- movitz/losp/x86-pc/serial.lisp:1.1.1.1 Tue Jan 13 06:05:06 2004 +++ movitz/losp/x86-pc/serial.lisp Thu May 20 14:16:13 2004 @@ -1,16 +1,16 @@ ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2001-2004, -;;;; Department of Computer Science, University of Tromsø, Norway. +;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: serial.lisp -;;;; Description: +;;;; Description: Serial port interfacing. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 11 14:42:12 2002 ;;;; -;;;; $Id: serial.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $ +;;;; $Id: serial.lisp,v 1.2 2004/05/20 18:16:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/streams.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15328 Modified Files: streams.lisp Log Message: Also here prefer vector-push-extend over vector-push. Date: Thu May 20 14:13:55 2004 Author: ffjeld Index: movitz/losp/muerte/streams.lisp diff -u movitz/losp/muerte/streams.lisp:1.2 movitz/losp/muerte/streams.lisp:1.3 --- movitz/losp/muerte/streams.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/streams.lisp Thu May 20 14:13:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Jun 30 14:33:15 2003 ;;;; -;;;; $Id: streams.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: streams.lisp,v 1.3 2004/05/20 18:13:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,7 +24,7 @@ (:no-clos-fallback stream-no-clos)) (defmethod stream-write-char ((stream string) character) - (vector-push character stream) + (vector-push-extend character stream) character) (defmethod stream-write-char ((stream function) character) @@ -100,10 +100,10 @@ (string (case (funobj-name *forward-generic-function*) (stream-write-char - (vector-push (car args) stream) + (vector-push-extend (car args) stream) (car args)) (stream-fresh-line - (vector-push #\newline stream) + (vector-push-extend #\newline stream) t))) (function (apply stream (funobj-name *forward-generic-function*) args))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18368 Modified Files: simple-streams.lisp Log Message: Use vector-push-extend rather than vector-push when write-char to a string. Date: Thu May 20 13:48:34 2004 Author: ffjeld Index: movitz/losp/muerte/simple-streams.lisp diff -u movitz/losp/muerte/simple-streams.lisp:1.4 movitz/losp/muerte/simple-streams.lisp:1.5 --- movitz/losp/muerte/simple-streams.lisp:1.4 Wed Feb 18 09:39:37 2004 +++ movitz/losp/muerte/simple-streams.lisp Thu May 20 13:48:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 29 13:39:43 2003 ;;;; -;;;; $Id: simple-streams.lisp,v 1.4 2004/02/18 14:39:37 ffjeld Exp $ +;;;; $Id: simple-streams.lisp,v 1.5 2004/05/20 17:48:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -427,7 +427,7 @@ (%check stream :output) (funcall-stm-handler-2 j-write-char character (sm melded-stream stream)))) (string - (vector-push character stream)))) + (vector-push-extend character stream)))) (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5246 Modified Files: sequences.lisp Log Message: Added a simple position-if-not. Date: Thu May 20 13:48:04 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.7 movitz/losp/muerte/sequences.lisp:1.8 --- movitz/losp/muerte/sequences.lisp:1.7 Fri Apr 23 11:02:20 2004 +++ movitz/losp/muerte/sequences.lisp Thu May 20 13:48:04 2004 @@ -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.7 2004/04/23 15:02:20 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.8 2004/05/20 17:48:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -290,6 +290,9 @@ (let ((next-i (position-if predicate p :key key :from-end t))) (if next-i (+ i 1 next-i) i))))))))))))))) +(defun position-if-not (predicate sequence &rest key-args) + (declare (dynamic-extent key-args)) + (apply #'position-if (complement predicate) sequence key-args)) (defun nreverse (sequence) (sequence-dispatch sequence

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3082 Modified Files: format.lisp Log Message: For (format nil ...) make initial output string somewhat longer. Date: Thu May 20 13:47:24 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.4 movitz/losp/muerte/format.lisp:1.5 --- movitz/losp/muerte/format.lisp:1.4 Tue Apr 13 10:21:57 2004 +++ movitz/losp/muerte/format.lisp Thu May 20 13:47:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.4 2004/04/13 14:21:57 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.5 2004/05/20 17:47:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,7 @@ (declare (dynamic-extent args)) (let ((destination (case destination - ((nil) (make-array (* 2 (length control)) + ((nil) (make-array (* 3 (length control)) :element-type 'character :fill-pointer 0)) ((t) *standard-output*)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31939 Modified Files: basic-macros.lisp Log Message: Make defpackage :use list translate the common-lisp package to the muerte.common-lisp package, so as to better support movitz-compiling the same code as normal. Date: Thu May 20 13:43:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.17 movitz/losp/muerte/basic-macros.lisp:1.18 --- movitz/losp/muerte/basic-macros.lisp:1.17 Mon Apr 19 11:06:26 2004 +++ movitz/losp/muerte/basic-macros.lisp Thu May 20 13:43:46 2004 @@ -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.17 2004/04/19 15:06:26 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.18 2004/05/20 17:43:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,12 +65,19 @@ (defmacro defpackage (package-name &rest options) (pushnew '(:use) options :key #'car) (let ((uses (cdr (assoc :use options)))) + (setf uses (mapcar (lambda (use) + (if (member use '(:cl :common-lisp) :test #'string=) + :muerte.cl + use)) + uses)) (when (or (null uses) (member :muerte.cl uses :test #'string=) (member :muerte.common-lisp uses :test #'string=)) - (push '(:shadowing-import-from :common-lisp nil) options))) - `(eval-when (:compile-toplevel) - (defpackage ,package-name ,@options))) + (push '(:shadowing-import-from :common-lisp nil) options)) + (let ((movitz-options (cons (cons :use uses) + (remove :use options :key #'car)))) + `(eval-when (:compile-toplevel) + (defpackage ,package-name ,@movitz-options))))) (defmacro cond (&rest clauses) (if (null clauses)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23259 Modified Files: arrays.lisp Log Message: A slightly improved vector-push-extend. Date: Thu May 20 13:41:46 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.18 movitz/losp/muerte/arrays.lisp:1.19 --- movitz/losp/muerte/arrays.lisp:1.18 Fri Apr 23 10:59:55 2004 +++ movitz/losp/muerte/arrays.lisp Thu May 20 13:41:46 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.18 2004/04/23 14:59:55 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.19 2004/05/20 17:41:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,7 +611,16 @@ (defun vector-push-extend (new-element vector &optional extension) (declare (ignore extension)) - (vector-push new-element vector)) + (check-type vector vector) + (let ((p (vector-fill-pointer vector))) + (declare (type (unsigned-byte 16) p)) + (cond + ((< p (vector-dimension vector)) + (setf (aref vector p) new-element + (fill-pointer vector) (1+ p))) + (t (error "Vector-push extending not implemented yet."))) + p)) + (define-compiler-macro bvref-u16 (&whole form vector offset index &environment env) (let ((actual-index (and (movitz:movitz-constantp index env)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1920 Modified Files: integers.lisp Log Message: Added floor. Date: Wed May 19 11:42:08 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.9 movitz/losp/muerte/integers.lisp:1.10 --- movitz/losp/muerte/integers.lisp:1.9 Wed May 19 11:09:05 2004 +++ movitz/losp/muerte/integers.lisp Wed May 19 11:42:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.10 2004/05/19 15:42:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1132,3 +1132,19 @@ (gcd gcd (car rest))) (rest (cdr numbers) (cdr rest))) ((null rest) gcd))))) + +(defun floor (n &optional (divisor 1)) + "This is floor written in terms of truncate." + (numargs-case + (1 (n) n) + (2 (n divisor) + (multiple-value-bind (q r) + (truncate n divisor) + (cond + ((<= 0 q) + (values q r)) + ((= 0 r) + (values q 0)) + (t (values (1- q) (+ r divisor)))))) + (t (n &optional (divisor 1)) + (floor n divisor)))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24256 Modified Files: integers.lisp Log Message: Added gcd, mainly borrowed from cmucl. Date: Wed May 19 11:09:07 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.8 movitz/losp/muerte/integers.lisp:1.9 --- movitz/losp/muerte/integers.lisp:1.8 Fri Apr 23 09:02:22 2004 +++ movitz/losp/muerte/integers.lisp Wed May 19 11:09:05 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.8 2004/04/23 13:02:22 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1103,3 +1103,32 @@ (defun minus-if (x y) (if (integerp x) (- x y) x)) +(defun gcd (&rest numbers) + (numargs-case + (1 (u) u) + (2 (u v) + ;; Code borrowed from CMUCL. + (do ((k 0 (1+ k)) + (u (abs u) (ash u -1)) + (v (abs v) (ash v -1))) + ((oddp (logior u v)) + (do ((temp (if (oddp u) (- v) (ash u -1)) + (ash temp -1))) + (nil) + (declare (fixnum temp)) + (when (oddp temp) + (if (plusp temp) + (setq u temp) + (setq v (- temp))) + (setq temp (- u v)) + (when (zerop temp) + (let ((res (ash u k))) + (declare (type (signed-byte 31) res) + (optimize (inhibit-warnings 3))) + (return res)))))))) + (t (&rest numbers) + (declare (dynamic-extent numbers)) + (do ((gcd (car numbers) + (gcd gcd (car rest))) + (rest (cdr numbers) (cdr rest))) + ((null rest) gcd)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4421 Modified Files: los-closette-compiler.lisp Log Message: Accept (but ignore) the :documentation class option. Date: Wed May 19 11:02:50 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.12 movitz/losp/muerte/los-closette-compiler.lisp:1.13 --- movitz/losp/muerte/los-closette-compiler.lisp:1.12 Mon Apr 19 18:38:22 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Wed May 19 11:02:50 2004 @@ -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.12 2004/04/19 22:38:22 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.13 2004/05/19 15:02:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -674,8 +674,9 @@ (apply #'initialize-class-object class all-keys))) (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots - default-initargs-function) - (declare (ignore metaclass)) + default-initargs-function + documentation) + (declare (ignore metaclass documentation)) (let ((class (std-allocate-instance *the-class-standard-class*))) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ())

1 0