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

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28772 Modified Files: typep.lisp Log Message: Recognize "array" as the same as "simple-array". Date: Wed Jul 21 05:49:24 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.28 movitz/losp/muerte/typep.lisp:1.29 --- movitz/losp/muerte/typep.lisp:1.28 Wed Jul 21 05:28:15 2004 +++ movitz/losp/muerte/typep.lisp Wed Jul 21 05:49:24 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.28 2004/07/21 12:28:15 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.29 2004/07/21 12:49:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -268,7 +268,7 @@ (if deriver-function `(typep ,object ',(apply deriver-function (cdr type))) (case (car type) - ((simple-array) + ((simple-array array) (let ((et (second type)) (dim (if (listp (third type)) (length (third type)) @@ -401,10 +401,6 @@ (t (warn "compiling typep ~S [~A]" type (package-name (symbol-package (car type)))))))))) form))))) - -#+ignore -(defun foo (x) - (typep x '(simple-array (unsigned-byte 4)))) (defmacro define-typep (tname lambda &body body) (let ((fname (format nil "~A-~A" 'typep tname)))

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv21280 Modified Files: packet.lisp Log Message: With these modifications, the file is accepted by movitz-compile-file. Date: Wed Jul 21 05:33:54 2004 Author: ffjeld Index: movitz/losp/tmp/packet.lisp diff -u movitz/losp/tmp/packet.lisp:1.1 movitz/losp/tmp/packet.lisp:1.2 --- movitz/losp/tmp/packet.lisp:1.1 Wed Jul 21 05:02:14 2004 +++ movitz/losp/tmp/packet.lisp Wed Jul 21 05:33:54 2004 @@ -270,11 +270,11 @@ ;;; ;;; The read syntax is `#e"ff:00:1:2:3:4'. ;;; -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel #-movitz :load-toplevel #-movitz :execute) (defstruct (ethernet-address (:conc-name #:ethernet-address.) (:print-function print-ethernet-address)) "48-bit Ethernet MAC address." - (octets (ext:required-argument) :type (array octet (6)))) + (octets 0 :type (array octet (6)))) (defun read-ethernet-address (stream &optional c n) "Read an ethernet address in colon-separated syntax. @@ -397,10 +397,10 @@ ;;; ;;; IP addresses also have a special read-syntax: `(a)10.0.0.1'. ;;; -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel #-movitz :load-toplevel #-movitz :execute) (defstruct (ipv4-address (:conc-name #:ipv4-address.) (:print-function print-ipv4-address)) - (octets (ext:required-argument) :type (array octet (4)))) + (octets 0 :type (array octet (4)))) (defun read-ipv4-address (stream &optional c n) "Read an IPv4 address in dotted-quad format. @@ -826,8 +826,8 @@ (structure-accessors name))) (defun structure-accessors (name) - (mapcar #'pcl::slot-definition-defstruct-accessor-symbol - (pcl:class-direct-slots (find-class name)))) + #+cmu (mapcar #'pcl::slot-definition-defstruct-accessor-symbol + (pcl:class-direct-slots (find-class name)))) (export (structure-exports)))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7969 Modified Files: image.lisp Log Message: Fixed movitz-read for structs. Date: Wed Jul 21 05:32:26 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.47 movitz/image.lisp:1.48 --- movitz/image.lisp:1.47 Thu Jul 15 14:06:19 2004 +++ movitz/image.lisp Wed Jul 21 05:32:26 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.47 2004/07/15 21:06:19 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.48 2004/07/21 12:32:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1460,11 +1460,12 @@ (unless slot-descriptions (error "Don't know how to movitz-read struct: ~S" expr)) (let ((movitz-object (make-instance 'movitz-struct - :name (movitz-read (type-of expr)) - :length (length slot-descriptions)))) + :name (movitz-read (type-of expr)) + :length (length slot-descriptions)))) (setf (image-lisp-to-movitz-object *image* expr) movitz-object) (setf (slot-value movitz-object 'slot-values) - (mapcar #'(lambda (slot) (movitz-read (slot-value expr slot))) + (mapcar #'(lambda (slot) + (movitz-read (slot-value expr (if (consp slot) (car slot) slot)))) slot-descriptions)) movitz-object))))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11200 Modified Files: typep.lisp Log Message: In the deftype expander, have the type declaration be mirrored on the host side. Date: Wed Jul 21 05:28:15 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.27 movitz/losp/muerte/typep.lisp:1.28 --- movitz/losp/muerte/typep.lisp:1.27 Sun Jul 18 17:54:34 2004 +++ movitz/losp/muerte/typep.lisp Wed Jul 21 05:28:15 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.27 2004/07/19 00:54:34 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.28 2004/07/21 12:28:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -426,10 +426,11 @@ (list 'typep x '',tname)) (defun ,fname ,lambda ,@body))))) -(defmacro deftype (name lambda &body body) +(defmacro deftype (&whole form name lambda &body body) (let ((fname (intern (format nil "~A-~A" 'deftype name)))) `(progn (eval-when (:compile-toplevel) + ,form (setf (gethash (translate-program ',name :cl :muerte.cl) *compiler-derived-typespecs*) (lambda ,lambda ,@body))

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15555 Modified Files: special-operators-cl.lisp Log Message: When doing eval-when, execute :compile-toplevel (on the host side) after movitz-side :execute and/or :load-toplevel. Why not? Date: Wed Jul 21 05:19:15 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.19 movitz/special-operators-cl.lisp:1.20 --- movitz/special-operators-cl.lisp:1.19 Fri Jun 11 14:34:02 2004 +++ movitz/special-operators-cl.lisp Wed Jul 21 05:19:15 2004 @@ -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.19 2004/06/11 21:34:02 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.20 2004/07/21 12:19:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -864,26 +864,24 @@ (define-special-operator eval-when (&all forward &form form &top-level-p top-level-p) (destructuring-bind (situations &body body) (cdr form) - (when (member :compile-toplevel situations) -;;; (warn "EVAL-WHEN: ~S" `(progn ,@(movitz::translate-program body :muerte.cl :cl -;;; :when :eval -;;; :remove-double-quotes-p t))) - (with-compilation-unit () - (dolist (toplevel-form (translate-program body :muerte.cl :cl - :when :eval - :remove-double-quotes-p t)) - (with-host-environment () - (if *compiler-compile-eval-whens* - (funcall (compile () `(lambda () ,toplevel-form))) - (eval toplevel-form)))))) - (if (or (member :execute situations) - (and (member :load-toplevel situations) - top-level-p)) - (compiler-call #'compile-implicit-progn - :defaults forward - :top-level-p top-level-p - :form body) - (compiler-values ())))) + (multiple-value-prog1 + (if (or (member :execute situations) + (and (member :load-toplevel situations) + top-level-p)) + (compiler-call #'compile-implicit-progn + :defaults forward + :top-level-p top-level-p + :form body) + (compiler-values ())) + (when (member :compile-toplevel situations) + (with-compilation-unit () + (dolist (toplevel-form (translate-program body :muerte.cl :cl + :when :eval + :remove-double-quotes-p t)) + (with-host-environment () + (if *compiler-compile-eval-whens* + (funcall (compile () `(lambda () ,toplevel-form))) + (eval toplevel-form))))))))) (define-special-operator function (&funobj funobj &form form &result-mode result-mode &env env) (destructuring-bind (name)

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp
by Luke Gorrie 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv29764 Added Files: packet.lisp Log Message: Imported packet.lisp "version 2" from small-cl-src mailing list. Date: Wed Jul 21 05:02:15 2004 Author: lgorrie

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4295 Modified Files: inspect.lisp Log Message: Added docstring to objects-equalp, and removed some debugging lines. Date: Wed Jul 21 04:49:48 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.28 movitz/losp/muerte/inspect.lisp:1.29 --- movitz/losp/muerte/inspect.lisp:1.28 Wed Jul 21 04:48:16 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jul 21 04:49:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.28 2004/07/21 11:48:16 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.29 2004/07/21 11:49:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -205,12 +205,8 @@ (structure-object (copy-structure old)))) -(defvar *objects-equalp-last-x*) -(defvar *objects-equalp-last-y*) - (defun objects-equalp (x y) - (setf *objects-equalp-last-x* x - *objects-equalp-last-y* y) + "Basically, this verifies whether x is a shallow-copy of y, or vice versa." (or (eql x y) (if (not (and (typep x 'pointer) (typep y 'pointer)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10288 Modified Files: inspect.lisp Log Message: Added support for symbols in objects-equalp. Date: Wed Jul 21 04:48:16 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.27 movitz/losp/muerte/inspect.lisp:1.28 --- movitz/losp/muerte/inspect.lisp:1.27 Tue Jul 20 16:53:00 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jul 21 04:48:16 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.27 2004/07/20 23:53:00 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.28 2004/07/21 11:48:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -232,6 +232,13 @@ (test funobj-num-jumpers) (dotimes (i (funobj-num-constants x) t) (unless (test funobj-constant-ref i))))) + (symbol + (and (test memref -7 0 :lisp) + (test memref -7 1 :lisp) + (test memref -7 2 :lisp) + (test memref -7 3 :lisp) + (test memref -7 4 :lisp) + (test memref -7 5 :lisp))) (vector (and (typep y 'vector) (test array-element-type)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Luke Gorrie 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5452 Modified Files: arrays.lisp Log Message: Fixed a bug where (make-array '(K)) was mistaken for multi-dimensional (which is not supported). The dimension argument was not allowed to be a cons even if it was really a one-element list. Date: Wed Jul 21 04:47:49 2004 Author: lgorrie Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.37 movitz/losp/muerte/arrays.lisp:1.38 --- movitz/losp/muerte/arrays.lisp:1.37 Tue Jul 20 05:38:59 2004 +++ movitz/losp/muerte/arrays.lisp Wed Jul 21 04:47:49 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.37 2004/07/20 12:38:59 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.38 2004/07/21 11:47:49 lgorrie Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -685,23 +685,25 @@ (defun make-array (dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset) (declare (ignore adjustable displaced-to displaced-index-offset)) - (etypecase dimensions - (cons - (error "Multi-dimensional arrays not supported.")) - (integer - (cond + (let ((size (cond ((integerp dimensions) + dimensions) + ((and (consp dimensions) (null (cdr dimensions))) + (car dimensions)) + (t + (error "Multi-dimensional arrays not supported."))))) + (cond ;; These should be replaced by subtypep sometime. ((eq element-type 'character) - (make-basic-vector%character dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%character size fill-pointer initial-element initial-contents)) ((member element-type '(bit (unsigned-byte 1)) :test #'equal) - (make-basic-vector%bit dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%bit size fill-pointer initial-element initial-contents)) ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) - (make-basic-vector%u8 dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%u8 size fill-pointer initial-element initial-contents)) ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) - (make-basic-vector%u32 dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%u32 size fill-pointer initial-element initial-contents)) ((eq element-type 'code) - (make-basic-vector%code dimensions fill-pointer initial-element initial-contents)) - (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents)))))) + (make-basic-vector%code size fill-pointer initial-element initial-contents)) + (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))) (defun vector (&rest objects) "=> vector"

1 0

[movitz-cvs] CVS update: movitz/bochsrc.txt
by Frode Vatvedt Fjeld 21 Jul '04

21 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19298 Modified Files: bochsrc.txt Log Message: Minor edits. Date: Wed Jul 21 04:45:52 2004 Author: ffjeld Index: movitz/bochsrc.txt diff -u movitz/bochsrc.txt:1.4 movitz/bochsrc.txt:1.5 --- movitz/bochsrc.txt:1.4 Wed Jul 14 17:29:39 2004 +++ movitz/bochsrc.txt Wed Jul 21 04:45:52 2004 @@ -1,6 +1,20 @@ -############################################################### -# bochsrc.txt file for DLX Linux disk image. -############################################################### +###################################################################### +## +## Copyright (C) 2003-2004, +## Department of Computer Science, University of Tromso, Norway. +## +## For distribution policy, see the accompanying file COPYING. +## +## Filename: bochsrc.txt +## Description: Bochs configuration file for frodef's Movitz setup. +## You can use this as a template, but you'll need to +## change the file paths etc. +## Author: Frode Vatvedt Fjeld <frodef(a)acm.org> +## Created at: Wed Jul 21 13:41:59 2004 +## +## $Id: bochsrc.txt,v 1.5 2004/07/21 11:45:52 ffjeld Exp $ +## +###################################################################### # how much memory the emulated machine will have megs: 64 @@ -11,6 +25,9 @@ romimage: file=../../tmp/bochs-cvs/bios/BIOS-bochs-latest, address=0xf0000 vgaromimage: ../../tmp/bochs-cvs/bios/VGABIOS-elpin-2.40 +# This is just to make X11 clipboard pasting into bochs work. +keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map + # what disk images will be used floppya: 1_44=los0-image, status=inserted #floppya: 1_44=grub, status=inserted @@ -18,8 +35,6 @@ #diskc: file=hd10meg.img, cyl=306, heads=4, spt=17 #newharddrivesupport: enabled=1 -# This is just to make X11 clipboard pasting into bochs work. -keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map # choose the boot disk. boot: a

1 0