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

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24273 Modified Files: read.lisp Log Message: Added *readtable* variable and copy-readtable mockup. --- /project/movitz/cvsroot/movitz/losp/muerte/read.lisp 2005/08/26 19:38:35 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/read.lisp 2006/04/07 21:50:37 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.13 2005/08/26 19:38:35 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.14 2006/04/07 21:50:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,7 +20,11 @@ (in-package muerte) (defvar *read-suppress*) -(defvar *readtable*) +(defvar *readtable* nil) + +(defun copy-readtable (&optional from-readtable to-readtable) + (declare (ignore from-readtable to-readtable)) + nil) (defun substring (string start end) (if (and (zerop start) (= end (length string)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24161 Modified Files: setf.lisp Log Message: Sort of implemented defsetf short form. --- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2004/02/18 14:38:14 1.3 +++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2006/04/07 21:49:47 1.4 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Feb 8 20:43:20 2001 ;;;; -;;;; $Id: setf.lisp,v 1.3 2004/02/18 14:38:14 ffjeld Exp $ +;;;; $Id: setf.lisp,v 1.4 2006/04/07 21:49:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -86,45 +86,54 @@ ;;; `(subseq ,tmp-sequence ,tmp-start ,tmp-end))))) (defmacro defsetf (access-fn &rest more-args) - ;; long form - (destructuring-bind (lambda-list store-variables &body body) - more-args - (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl))) - (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes) - (movitz::decode-macro-lambda-list movitz-lambda) - (assert (null restvar)) - (assert (null envvars)) - (assert (null wholevars)) - (assert (null auxes)) - (assert (null keys)) - (let* ((req-tmps (mapcar (lambda (x) (list x (gensym))) - reqvars)) - (opt-vars (mapcar #'movitz::decode-optional-formal - optionalvars)) - (opt-tmps (mapcar (lambda (x) (list x (gensym))) - opt-vars)) - (tmp-lets (append (mapcar (lambda (rt) - (list (second rt) '(gensym))) - req-tmps) - (mapcar (lambda (rt) - (list (second rt) '(gensym))) - opt-tmps) - `((init-form (list ,@reqvars ,@opt-vars))) - (mapcar (lambda (rt) - (list rt '(gensym))) - store-variables))) - (lambda-lets (append req-tmps opt-tmps))) - `(define-setf-expander ,access-fn ,movitz-lambda - (let ,tmp-lets - (let ,lambda-lets - (values (list ,@(mapcar #'second req-tmps) - ,@(mapcar #'second opt-tmps)) - init-form - (list ,@store-variables) - (progn ,@body) - (list ',access-fn - ,@(mapcar #'first req-tmps) - ,@(mapcar #'first opt-tmps))))))))))) + (cond + ((symbolp (first more-args)) + ;; short form XXX not really good. + `(defun (setf ,access-fn) (fu foo) + (,(first more-args) fu foo))) + (t ;; long form + (destructuring-bind (lambda-list store-variables &body body-decl-docstring) + more-args + (multiple-value-bind (body declarations docstring) + (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare) + (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl))) + (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes) + (movitz::decode-macro-lambda-list movitz-lambda) + (assert (null restvar)) + (assert (null envvars)) + (assert (null wholevars)) + (assert (null auxes)) + (assert (null keys)) + (let* ((req-tmps (mapcar (lambda (x) (list x (gensym))) + reqvars)) + (opt-vars (mapcar #'movitz::decode-optional-formal + optionalvars)) + (opt-tmps (mapcar (lambda (x) (list x (gensym))) + opt-vars)) + (tmp-lets (append (mapcar (lambda (rt) + (list (second rt) '(gensym))) + req-tmps) + (mapcar (lambda (rt) + (list (second rt) '(gensym))) + opt-tmps) + `((init-form (list ,@reqvars ,@opt-vars))) + (mapcar (lambda (rt) + (list rt '(gensym))) + store-variables))) + (lambda-lets (append req-tmps opt-tmps))) + `(define-setf-expander ,access-fn ,movitz-lambda + (declare ,@declarations) + ,@(when docstring (list docstring)) + (let ,tmp-lets + (let ,lambda-lets + (values (list ,@(mapcar #'second req-tmps) + ,@(mapcar #'second opt-tmps)) + init-form + (list ,@store-variables) + (progn ,@body) + (list ',access-fn + ,@(mapcar #'first req-tmps) + ,@(mapcar #'first opt-tmps)))))))))))))) (defmacro define-modify-macro (name lambda-list function &optional documentation)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24108 Added Files: subtypep.lisp Log Message: Added very primitive subtypep. --- /project/movitz/cvsroot/movitz/losp/muerte/subtypep.lisp 2006/04/07 21:48:43 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/subtypep.lisp 2006/04/07 21:48:43 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Copyright (C) 2006, ;; Department of Computer Science, University of Tromso, Norway. ;; ;; For distribution policy, see the accompanying file COPYING. ;; ;; Filename: subtypep.lisp ;; Description: ;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;; Created at: Sun Apr 2 20:47:11 2006 ;; ;; $Id: subtypep.lisp,v 1.1 2006/04/07 21:48:43 ffjeld Exp $ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require :muerte/basic-macros) (provide :muerte/subtypep) (in-package muerte) (defun subtypep (type-1 type-2 &optional environment) "Is type-1 a subtype of type-2? => subtype-p, valid-p" (let ((class-1 (find-class type-1 nil environment)) (class-2 (find-class type-2 nil environment))) (cond ((and class-1 class-2) (values (subclassp class-1 class-2) t)) (class-2 (dolist (c (class-precedence-list class-2) (values nil nil)) (when (member type-1 (getf (class-plist c) :subtypes)) (return (values t t))))) (t (values nil nil)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24089 Modified Files: common-lisp.lisp Log Message: Added very primitive subtypep. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2005/05/03 20:08:14 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2006/04/07 21:48:41 1.14 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.13 2005/05/03 20:08:14 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.14 2006/04/07 21:48:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,6 +52,7 @@ (require :muerte/interrupt) (require :muerte/scavenge) (require :muerte/simple-streams) +(require :muerte/subtypep) (require :muerte/io-port) (require :muerte/cpu-id)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24041 Modified Files: arrays.lisp Log Message: Improve upgraded-array-element-type slightly. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2005/08/24 07:27:47 1.56 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/04/07 21:47:44 1.57 @@ -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.56 2005/08/24 07:27:47 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.57 2006/04/07 21:47:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -105,17 +105,19 @@ (let* ((q (cdr type-specifier)) (min (if q (pop q) '*)) (max (if q (pop q) '*))) - (cond - ((or (eq min '*) (eq max '*)) - t) - ((<= 0 min max 1) - 'bit) - ((<= 0 min max #xff) - '(unsigned-byte 8)) - ((<= 0 min max #xffff) - '(unsigned-byte 16)) - ((<= 0 min max #xffffffff) - '(unsigned-byte 32))))) + (let ((min (if (consp min) (1+ (car min)) min)) + (max (if (consp max) (1- (car max)) max))) + (cond + ((or (eq min '*) (eq max '*)) + t) + ((<= 0 min max 1) + 'bit) + ((<= 0 min max #xff) + '(unsigned-byte 8)) + ((<= 0 min max #xffff) + '(unsigned-byte 16)) + ((<= 0 min max #xffffffff) + '(unsigned-byte 32)))))) (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*))) (if (not deriver) t

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21957 Modified Files: integers.lisp Log Message: Added trivial versions of realpart, imagpart, and rational. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/03/31 20:57:48 1.120 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/04/07 21:35:32 1.121 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.120 2006/03/31 20:57:48 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.121 2006/04/07 21:35:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2250,3 +2250,13 @@ (defun floatp (x) (declare (ignore x)) nil) + +(defun realpart (number) + number) + +(defun imagpart (number) + (declare (ignore number)) + 0) + +(defun rational (number) + number)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21830 Modified Files: cons.lisp Log Message: Added acons. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2005/06/12 21:27:03 1.11 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/04/07 21:33:54 1.12 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.11 2005/06/12 21:27:03 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.12 2006/04/07 21:33:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -271,3 +271,7 @@ (and (te (car tree-1) (car tree-2) test) (te (cdr tree-1) (cdr tree-2) test)))))) (te tree-1 tree-2 (or test (and test-not (complement test-not)) #'eql)))) + +(defun acons (key datum alist) + "=> new-alist" + (cons (cons key datum) alist))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 Apr '06

05 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3301 Modified Files: format.lisp Log Message: Support ~P and ~Newline. --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2005/08/26 19:39:06 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2006/04/05 23:02:22 1.13 @@ -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.12 2005/08/26 19:39:06 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.13 2006/04/05 23:02:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -142,6 +142,24 @@ proceed (incf i) (case (char-upcase (schar control-string i)) + (#\Newline + (when at-sign-p + (write-char #\Newline)) + (unless colon-p + (do ((stop (1- (length control-string)))) + ((or (>= i stop) + (not (member (schar control-string (1+ i)) + '(#\space #\newline #\tab))))) + (incf i)))) + (#\P (let ((arg (if (not colon-p) + (pop args) + (car (nthcdr (1- (do ((i 0 (1+ i)) (p args-head (cdr p))) + ((eq p args) i) ; find arg's position in arg-head. + (assert p))) + args-head))))) + (write-string (if at-sign-p + (if (eql arg 1) "y" "ies") + (if (eql arg 1) "" "s"))))) (#\Z (if at-sign-p (print-word-indirect (pop args) nil) (print-word (pop args) nil)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 03 Apr '06

03 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27835 Modified Files: defstruct.lisp Log Message: Added support for :copier option to defstruct. --- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2004/10/21 20:34:02 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2006/04/03 21:22:39 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.16 2004/10/21 20:34:02 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.17 2006/04/03 21:22:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -199,7 +199,9 @@ (default (:constructor) (intern (concatenate 'string (string 'make-) (string struct-name)))) (default (:predicate 1) - (intern (concatenate 'string (string struct-name) (string '-p))))) + (intern (concatenate 'string (string struct-name) (string '-p)))) + (default (:copier) + (intern (concatenate 'string (string 'copy-) (string struct-name))))) (let* ((struct-type (first (getf options :type))) (superclass (first (getf options :superclass))) (struct-named (first (getf options :named))) @@ -243,6 +245,11 @@ :type type :readonly read-only :location location)))) + ,@(loop for copier in (getf options :copier) + if (and copier (symbolp copier)) + collect + `(defun ,copier (x) + (copy-structure x))) ,@(loop for constructor in (getf options :constructor) if (and constructor (symbolp constructor)) collect

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 Apr '06

02 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5418 Modified Files: sequences.lisp Log Message: Implemented reduce :from-end on lists. Improved remove-duplicates and delete-duplicates not to use O(n) stack. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/25 20:59:16 1.31 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/04/02 20:48:34 1.32 @@ -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.31 2006/03/25 20:59:16 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.32 2006/04/02 20:48:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -126,8 +126,6 @@ (t (function sequence &key (key 'identity) from-end (start 0) (end (length sequence)) (initial-value nil initial-value-p)) - (when from-end - (error "REDUCE from-end is not implemented.")) (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) @@ -140,18 +138,34 @@ (key (elt sequence start)))) (t (sequence-dispatch sequence (list - (do* ((counter (1+ start) (1+ counter)) - (list (nthcdr start sequence)) - (result (funcall-function (if initial-value-p - initial-value + (cond + ((not from-end) + (do* ((counter (1+ start) (1+ counter)) + (list (nthcdr start sequence)) + (result (funcall-function (if initial-value-p + initial-value + (key (pop list))) (key (pop list))) - (key (pop list))) - (funcall-function result (key (pop list))))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))) + (funcall-function result (key (pop list))))) + ((or (null list) + (= end counter)) + result) + (declare (index counter)))) + (from-end + (do* ((counter (1+ start) (1+ counter)) + (list (nreverse (subseq sequence start end))) + (result (funcall-function (key (pop list)) + (if initial-value-p + initial-value + (key (pop list)))) + (funcall-function (key (pop list)) result))) + ((or (null list) + (= end counter)) + result) + (declare (index counter)))))) (vector + (when from-end + (error "REDUCE from-end on vectors is not implemented.")) (with-subvector-accessor (sequence-ref sequence start end) (do* ((index start) (result (funcall-function (if initial-value-p @@ -731,7 +745,7 @@ (apply 'map-for-nil function first-sequence more-sequences)) ((eq 'list result-type) (apply 'map-for-list function first-sequence more-sequences)) - ((eq 'string result-type) + ((member result-type '(string simple-string)) (apply 'map-for-string function first-sequence more-sequences)) (t (error "MAP not implemented.")))) @@ -1390,21 +1404,17 @@ (setf test (complement test-not))) (sequence-dispatch sequence (list - (setf sequence (nthcdr start sequence)) - (when end (decf end start)) - (cond - ((endp sequence) - nil) - ((not from-end) - (let* ((new-end (when end (1- end))) - (tail (remove-duplicates (cdr sequence) :test test :key key :end new-end))) - (cond - ((find (car sequence) (cdr sequence) :test test :key key :end new-end) - tail) - ((eq tail (cdr sequence)) - sequence) - (t (cons (car sequence) tail))))) - (t (error "from-end not implemented.")))) + (let ((list (nthcdr start sequence))) + (cond + ((endp list) + nil) + ((and (not end) (not from-end)) + (do ((r nil)) + ((endp list) (nreverse r)) + (let ((x (pop list))) + (unless (member x list :key key :test test) + (push x r))))) + (t (error "remove-duplicates not implemented."))))) (vector (error "vector remove-duplicates not implemented."))))

1 0