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

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

30 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv18377 Modified Files: cons.lisp Log Message: Lifted sublis and nsublis from cmucl. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/04/07 21:33:54 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/04/30 21:38:40 1.13 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.12 2006/04/07 21:33:54 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.13 2006/04/30 21:38:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -275,3 +275,42 @@ (defun acons (key datum alist) "=> new-alist" (cons (cons key datum) alist)) + +(defun sublis (alist tree &key key (test 'eql) test-not) + "Substitutes from alist into tree nondestructively." + (declare (inline assoc)) + (let ((key (or key 'identity)) + (test (if test-not (complement test-not) test))) + (labels ((s (subtree) + (let* ((key-val (funcall key subtree)) + (assoc (assoc key-val alist :test test))) + (cond (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtreE)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (s tree)))) + +(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp)) + "Substitutes new for subtrees matching old." + (declare (inline assoc)) + (let ((key (or key 'identity)) + (test (if test-not (complement test-not) test)) + (temp)) + (labels ((s (subtree) + (cond ((Setq temp (nsublis-macro)) + (cdr temp)) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (Cdr subtree))) + ((atom subtree) + (if (setq temp (assoc (funcall key subtree) alist :test test)) + (setf (cdr last) (cdr temp)))) + (if (setq temp (assoc (funcall key subtree) alist :test test)) + (return (setf (Cdr last) (Cdr temp))) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))))

1 0

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

29 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27802 Modified Files: lists.lisp Log Message: Added (setf first) and (setf rest). --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/04/29 11:30:35 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/04/29 11:41:34 1.14 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.13 2006/04/29 11:30:35 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.14 2006/04/29 11:41:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,10 +25,10 @@ (defun rest (x) (cdr x)) -(defun (setf first) (x y) +(defun (setf first) (y x) (setf (car x) y)) -(defun (setf rest) (x y) +(defun (setf rest) (y x) (setf (cdr x) y)) ;; Compiler-macros for first and rest in basic-macros.lisp. @@ -431,8 +431,6 @@ :test (if test-not (complement test-not) test))) - - (defun subsetp (list-1 list-2 &key (key 'identity) (test 'eql) test-not) "=> generalized-boolean"

1 0

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

29 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27486 Modified Files: lists.lisp Log Message: Added (setf first) and (setf rest). --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2005/08/21 19:00:16 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/04/29 11:30:35 1.13 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.12 2005/08/21 19:00:16 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.13 2006/04/29 11:30:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,6 +25,12 @@ (defun rest (x) (cdr x)) +(defun (setf first) (x y) + (setf (car x) y)) + +(defun (setf rest) (x y) + (setf (cdr x) y)) + ;; Compiler-macros for first and rest in basic-macros.lisp. (defun second (x) (cadr x))

1 0

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

28 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29966 Modified Files: conditions.lisp Log Message: Add simple-condition-format-control and simple-condition-format-arguments readers. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/04/07 21:51:53 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/04/28 23:21:59 1.19 @@ -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.18 2006/04/07 21:51:53 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.19 2006/04/28 23:21:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,7 +59,11 @@ (condition-format-control condition) (condition-format-arguments condition)))))) -(define-condition simple-condition (condition) ()) +(define-condition simple-condition (condition) + ((format-control + :reader simple-condition-format-control) + (format-arguments + :reader simple-condition-format-arguments))) (define-condition serious-condition () ()) (define-condition error (serious-condition) ()) (define-condition warning () ())

1 0

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

28 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29923 Modified Files: more-macros.lisp Log Message: Have the silly load implementation be a macro rather than compiler-macro, since there's no function to back it up. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/28 21:18:48 1.31 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/28 23:21:32 1.32 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.31 2006/04/28 21:18:48 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.32 2006/04/28 23:21:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -431,7 +431,7 @@ (define-unimplemented-macro with-open-file) (define-unimplemented-macro restart-case) -(define-compiler-macro load (filespec &key verbose print if-does-not-exist external-format) +(defmacro load (filespec &key verbose print if-does-not-exist external-format) "hm..." (assert (movitz:movitz-constantp filespec) (filespec) "Can't load a non-constant filename: ~S" filespec)

1 0

[movitz-cvs] CVS movitz
by ffjeld 28 Apr '06

28 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29871 Modified Files: eval.lisp Log Message: If a compiler-macro signals error, print a warning and pretend the compiler-macro declined. --- /project/movitz/cvsroot/movitz/eval.lisp 2005/09/16 22:49:34 1.10 +++ /project/movitz/cvsroot/movitz/eval.lisp 2006/04/28 23:20:47 1.11 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.10 2005/09/16 22:49:34 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.11 2006/04/28 23:20:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,9 +66,11 @@ (cons (let* ((compiler-macro-function (movitz-compiler-macro-function (car form) env)) (compiler-macro-expansion (and compiler-macro-function - (funcall *movitz-macroexpand-hook* - compiler-macro-function - form env)))) + (handler-case + (funcall *movitz-macroexpand-hook* + compiler-macro-function + form env) + (error () form))))) (or (let ((form (translate-program form :cl :muerte.cl))) (case (car form) ((muerte.cl:quote) t)

1 0

[movitz-cvs] CVS movitz
by ffjeld 28 Apr '06

28 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29847 Modified Files: compiler.lisp Log Message: If a compiler-macro signals error, print a warning and pretend the compiler-macro declined. --- /project/movitz/cvsroot/movitz/compiler.lisp 2006/04/10 11:49:41 1.167 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/04/28 23:20:45 1.168 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.167 2006/04/10 11:49:41 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.168 2006/04/28 23:20:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5550,9 +5550,13 @@ (compiler-call (movitz-special-operator-compiler operator) :forward all) (let* ((compiler-macro-function (movitz-compiler-macro-function operator env)) (compiler-macro-expansion (and compiler-macro-function - (funcall *movitz-macroexpand-hook* - compiler-macro-function - form env)))) + (handler-case + (funcall *movitz-macroexpand-hook* + compiler-macro-function + form env) + (error (c) + (warn "Compiler-macro for ~S failed: ~A" operator c) + form))))) (cond ((and compiler-macro-function (not (movitz-env-get operator 'notinline nil env)) @@ -6671,7 +6675,6 @@ (define-extended-code-expander :cons-get (instruction funobj frame-map) (destructuring-bind (op cell dst) (cdr instruction) - (check-type cell lexical-binding) (check-type dst (member :eax :ebx :ecx :edx)) (multiple-value-bind (op-offset fast-op fast-op-ebx) (ecase op @@ -6684,8 +6687,7 @@ (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) (location (new-binding-location (binding-target binding) frame-map)) (binding-is-list-p (binding-store-subtypep binding 'list))) - #+ignore (warn "car of loc ~A bind ~A" - location binding) + #+ignore (warn "~A of loc ~A bind ~A" op location binding) (cond ((and binding-is-list-p (member location '(:eax :ebx :ecx :edx)))

1 0

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

28 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv15466 Modified Files: packages.lisp Log Message: Implement package-nicknames. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2005/08/31 22:32:08 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2006/04/28 21:19:08 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.12 2005/08/31 22:32:08 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.13 2006/04/28 21:19:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,13 +28,17 @@ external-symbols internal-symbols shadowing-symbols-list - use-list) + use-list + nicknames) (defvar *packages*) ; Set by dump-image. (defun package-name (object) (package-object-name (find-package object))) +(defun package-nicknames (package-designator) + (package-object-nicknames (find-package package-designator))) + (defun package-use-list (package-name) (package-object-use-list (find-package package-name)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 28 Apr '06

28 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv15447 Modified Files: image.lisp Log Message: Implement package-nicknames. --- /project/movitz/cvsroot/movitz/image.lisp 2006/04/10 11:48:20 1.105 +++ /project/movitz/cvsroot/movitz/image.lisp 2006/04/28 21:19:06 1.106 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.105 2006/04/10 11:48:20 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.106 2006/04/28 21:19:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1117,7 +1117,7 @@ (pushnew :constant-variable (movitz-symbol-flags symbol)) (setf (movitz-symbol-value symbol) (movitz-read (translate-program (symbol-value (translate-program name :muerte.cl :cl)) - :cl :muerte.cl)))) + :cl :muerte.cl)))) symbol))) (defun make-packages-hash (&optional (*image* *image*)) @@ -1143,16 +1143,20 @@ lisp-package context) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) - (let ((p (funcall 'muerte::make-package-object - :name package-name - :shadowing-symbols-list (package-shadowing-symbols lisp-package) - :external-symbols (make-hash-table :test #'equal) - :internal-symbols (make-hash-table :test #'equal) - :use-list (mapcar #'(lambda (up) - (ensure-package (movitz-package-name (package-name up)) - up context)) - (package-use-list lisp-package))))) + (let* ((nicks (mapcar #'movitz-package-name (package-nicknames lisp-package))) + (p (funcall 'muerte::make-package-object + :name package-name + :shadowing-symbols-list (package-shadowing-symbols lisp-package) + :external-symbols (make-hash-table :test #'equal) + :internal-symbols (make-hash-table :test #'equal) + :nicknames nicks + :use-list (mapcar #'(lambda (up) + (ensure-package (movitz-package-name (package-name up)) + up context)) + (package-use-list lisp-package))))) (setf (gethash package-name packages-hash) p) + (dolist (nick nicks) + (setf (gethash nick packages-hash) p)) p))))) (let ((movitz-cl-package (ensure-package (symbol-name :common-lisp) (find-package :muerte.common-lisp))))

1 0

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

28 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv15406 Modified Files: more-macros.lisp Log Message: Added trivial with-standard-io-syntax macro. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/10 11:54:52 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/28 21:18:48 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.30 2006/04/10 11:54:52 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.31 2006/04/28 21:18:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -440,3 +440,27 @@ (defmacro locally (&body body) `(let () ,@body)) + +(defmacro with-standard-io-syntax (&body body) + `(let ((*package* (find-package :init)) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + #+ignore (*print-miser-width* nil) + #+ignore (*print-pprint-dispatch* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + #+ignore (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'ratio) + (*read-eval* t) + (*read-suppress* nil) + #+ignore (*readtable* nil)) + ,@body))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5221 Modified Files: variables.lisp Log Message: Added some variables. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2005/06/10 23:05:50 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2006/04/10 11:58:27 1.10 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.9 2005/06/10 23:05:50 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.10 2006/04/10 11:58:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,4 +45,28 @@ (defvar *gc-hooks* nil) +(defvar *load-pathname* nil) + + +(defvar most-positive-short-float 1000000) +(defvar most-positive-single-float 1000000) +(defvar most-positive-double-float 1000000) +(defvar most-positive-long-float 1000000) + +(defvar short-float-epsilon 1/1000) +(defvar single-float-epsilon 1/1000) +(defvar double-float-epsilon 1/1000) +(defvar long-float-epsilon 1/1000) + +(defvar short-float-negative-epsilon -1/1000) +(defvar single-float-negative-epsilon -1/1000) +(defvar double-float-negative-epsilon -1/1000) +(defvar long-float-negative-epsilon -1/1000) + + +(defconstant call-arguments-limit #xffff0) +(defconstant lambda-parameters-limit #x1000) ; ? + +(defvar *print-pprint-dispatch* nil) + (declaim (special *build-number*))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5192 Modified Files: typep.lisp Log Message: Improved coerce. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2005/10/25 19:27:46 1.52 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2006/04/10 11:58:15 1.53 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.52 2005/10/25 19:27:46 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.53 2006/04/10 11:58:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -704,7 +704,7 @@ (cond ((typep object result-type) object) - ((member result-type '(list array vector)) + ((member result-type '(list array vector simple-vector string simple-string)) (map result-type #'identity object)) ((and (consp result-type) (eq (car result-type) 'vector))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5157 Modified Files: streams.lisp Log Message: Have finish-output accept a function as stream designator. --- /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp 2004/11/24 16:19:36 1.4 +++ /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp 2006/04/10 11:57:24 1.5 @@ -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.4 2004/11/24 16:19:36 ffjeld Exp $ +;;;; $Id: streams.lisp,v 1.5 2006/04/10 11:57:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -125,6 +125,7 @@ destination, and then returns." (let ((stream (output-stream-designator stream))) (etypecase stream + (function) ; NOP (simple-stream (%finish-output stream)))))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5113 Modified Files: sequences.lisp Log Message: Improved map and remove-if. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/04/02 20:48:34 1.32 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/04/10 11:56:28 1.33 @@ -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.32 2006/04/02 20:48:34 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.33 2006/04/10 11:56:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -716,22 +716,21 @@ (ignore function first-sequence more-sequences)) (error "MAP not implemented.")))) -(defun map-for-string (function first-sequence &rest more-sequences) +(defun map-for-vector (result function first-sequence &rest more-sequences) (numargs-case - (2 (function first-sequence) + (3 (result function first-sequence) (with-funcallable (mapf function) - (let ((result (make-string (length first-sequence)))) - (sequence-dispatch first-sequence - (vector - (do ((i 0 (1+ i))) - ((>= i (length result)) result) - (declare (index i)) - (setf (char result i) (mapf (aref first-sequence i))))) - (list - (do ((i 0 (1+ i))) - ((>= i (length result)) result) - (declare (index i)) - (setf (char result i) (mapf (pop first-sequence))))))))) + (sequence-dispatch first-sequence + (vector + (do ((i 0 (1+ i))) + ((>= i (length result)) result) + (declare (index i)) + (setf (aref result i) (mapf (aref first-sequence i))))) + (list + (do ((i 0 (1+ i))) + ((>= i (length result)) result) + (declare (index i)) + (setf (aref result i) (mapf (pop first-sequence)))))))) (t (function first-sequence &rest more-sequences) (declare (ignore function first-sequence more-sequences)) (error "MAP not implemented.")))) @@ -746,7 +745,13 @@ ((eq 'list result-type) (apply 'map-for-list function first-sequence more-sequences)) ((member result-type '(string simple-string)) - (apply 'map-for-string function first-sequence more-sequences)) + (apply 'map-for-vector + (make-string (length first-sequence)) + function first-sequence more-sequences)) + ((member result-type '(vector simple-vector)) + (apply 'map-for-vector + (make-array (length first-sequence)) + function first-sequence more-sequences)) (t (error "MAP not implemented.")))) (defun fill (sequence item &key (start 0) end) @@ -1253,30 +1258,33 @@ list) (t (with-funcallable (test) (with-funcallable (key) - (if (test (key (car list))) - (list-remove-if test (cdr list) key - (when end (1- end)) - (when count (1- count))) - (do ((i 1 (1+ i)) - (p0 list (cdr p0)) - (p1 (cdr list) (cdr p1))) - ((or (endp p1) (and end (>= i end))) list) - (declare (index i)) - (when (test (key (car p1))) - (return - ;; reiterate from <list> to <p1>, consing up a copy, with - ;; the copy's tail being the recursive call to list-remove. - (do* ((new-list (cons (car list) nil)) - (x (cdr list) (cdr x)) - (new-x new-list)) - ((eq x p1) - (setf (cdr new-x) (list-remove-if test (cdr p1) key - (when end (- end i 1)) - (when count (1- count)))) - new-list) - (setf new-x - (setf (cdr new-x) - (cons (car x) nil))))))))))))) + (and (do () ((or (endp list) + (and end (<= end 0)) + (not (test (key (car list)))) + (and count (<= (decf count) 0))) + list) + (when end (decf end)) + (setf list (cdr list))) + (do ((i 1 (1+ i)) + (p0 list (cdr p0)) + (p1 (cdr list) (cdr p1))) + ((or (endp p1) (and end (>= i end))) list) + (declare (index i)) + (when (test (key (car p1))) + (return + ;; reiterate from <list> to <p1>, consing up a copy, with + ;; the copy's tail being the recursive call to list-remove. + (do* ((new-list (cons (car list) nil)) + (x (cdr list) (cdr x)) + (new-x new-list)) + ((eq x p1) + (setf (cdr new-x) (list-remove-if test (cdr p1) key + (when end (- end i 1)) + (when count (1- count)))) + new-list) + (setf new-x + (setf (cdr new-x) + (cons (car x) nil))))))))))))) (defun remove-if (test sequence &key from-end (start 0) end count (key 'identity)) (sequence-dispatch sequence

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4992 Modified Files: more-macros.lisp Log Message: Added trivial locally macro. Also a mock-up load compiler-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2005/08/26 19:39:26 1.29 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/10 11:54:52 1.30 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.29 2005/08/26 19:39:26 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.30 2006/04/10 11:54:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -431,3 +431,12 @@ (define-unimplemented-macro with-open-file) (define-unimplemented-macro restart-case) +(define-compiler-macro load (filespec &key verbose print if-does-not-exist external-format) + "hm..." + (assert (movitz:movitz-constantp filespec) (filespec) + "Can't load a non-constant filename: ~S" filespec) + (warn "load-compile: ~S" filespec) + `(funcall ',(movitz:movitz-compile-file (format nil "losp/ansi-tests/~A" filespec)))) + +(defmacro locally (&body body) + `(let () ,@body))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4947 Modified Files: los-closette.lisp Log Message: Have find-class compiler-macro accept optional environment arg. Take note that character class contains base-char and extended-char. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2005/08/21 17:55:54 1.35 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2006/04/10 11:52:21 1.36 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.35 2005/08/21 17:55:54 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.36 2006/04/10 11:52:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -99,6 +99,10 @@ (defmacro push-on-end (value location) `(setf ,location (nconc ,location (list ,value)))) + +(defmacro define-method-combination (name &rest options) + (declare (ignore options)) + (warn "Method-combinations not implemented: ~S" name)) ;;; @@ -210,7 +214,8 @@ ;;; -(defun find-class (symbol &optional (errorp t)) +(defun find-class (symbol &optional (errorp t) environment) + (declare (ignore environment)) (let ((class (gethash symbol *class-table*))) (if (and (null class) errorp) (error "No class named ~S." symbol) @@ -951,7 +956,9 @@ (defclass symbol (t) () (:metaclass built-in-class)) (defclass sequence (t) () (:metaclass built-in-class)) (defclass array (t) () (:metaclass built-in-class)) -(defclass character (t) () (:metaclass built-in-class)) +(defclass character (t) () + (:metaclass built-in-class) + (:plist (:subtypes (base-char extended-char)))) (defclass list (sequence) () (:metaclass built-in-class)) (defclass null (symbol list) () (:metaclass built-in-class)) (defclass cons (list) () (:metaclass built-in-class))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4911 Modified Files: basic-macros.lisp Log Message: Have find-class compiler-macro accept optional environment arg. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2005/08/28 20:53:13 1.65 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2006/04/10 11:51:03 1.66 @@ -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.65 2005/08/28 20:53:13 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.66 2006/04/10 11:51:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -914,9 +914,9 @@ (error "Array backquote not implemented.")) (t (list 'quote form)))) -(define-compiler-macro find-class (&whole form &environment env symbol &optional (errorp t)) - (declare (ignore errorp)) - (if (not (movitz:movitz-constantp symbol env)) +(define-compiler-macro find-class (&whole form &environment env symbol &optional (errorp t) (environment nil envp)) + (declare (ignore errorp environment)) + (if (or envp (not (movitz:movitz-constantp symbol env))) form (let* ((type (movitz:movitz-eval symbol env)) (movitz-type (movitz-program type))

1 0

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

10 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4874 Modified Files: arithmetic-macros.lisp Log Message: No need to give cl package prefix inside #.(..) anymore. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2005/09/18 16:20:04 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2006/04/10 11:50:34 1.16 @@ -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.15 2005/09/18 16:20:04 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.16 2006/04/10 11:50:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,7 +216,7 @@ ,@(loop repeat count append `((:addl (:result-register) (:result-register)) (:into))))) - ((< 0 count #.(cl:1- movitz::+movitz-fixnum-bits+)) + ((< 0 count #.(1- movitz::+movitz-fixnum-bits+)) `(with-inline-assembly (:returns :register :side-effects nil :type integer) ,@load-integer (:cmpl ,(ash 1 (- (- 31 0) count))

1 0

[movitz-cvs] CVS movitz
by ffjeld 10 Apr '06

10 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4760 Modified Files: compiler.lisp Log Message: minor tweaks. --- /project/movitz/cvsroot/movitz/compiler.lisp 2005/10/31 09:22:54 1.166 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/04/10 11:49:41 1.167 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.166 2005/10/31 09:22:54 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.167 2006/04/10 11:49:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1400,8 +1400,7 @@ (pathname-directory path)) (path) "Refusing to delete file not in /tmp.") - (delete-file path)))) - (values)) + (delete-file path))))) (defun movitz-compile-file-internal (path &optional (*default-load-priority* @@ -1440,9 +1439,9 @@ (when *compiler-verbose-p* (format *query-io* "~&Movitz Compiling ~S..~%" (cond - ((symbolp form) form) - ((symbolp (car form)) - (xsubseq form 0 2))))) + ((symbolp form) form) + ((symbolp (car form)) + (xsubseq form 0 2))))) (compiler-call #'compile-form :form form :funobj funobj @@ -1452,13 +1451,16 @@ (cond ((null file-code) (setf (image-load-time-funobjs *image*) - (delete funobj (image-load-time-funobjs *image*) :key #'first))) + (delete funobj (image-load-time-funobjs *image*) :key #'first)) + 'muerte::constantly-true) (t (setf (extended-code function-env) file-code (need-normalized-ecx-p function-env) nil (function-envs funobj) (list (cons 'muerte.cl::t function-env)) (funobj-env funobj) funobj-env) - (make-compiled-funobj-pass2 funobj))) - t)))) + (make-compiled-funobj-pass2 funobj) + (let ((name (funobj-name funobj))) + (setf (movitz-env-named-function name) funobj) + name))))))) ;;;;

1 0

[movitz-cvs] CVS movitz
by ffjeld 10 Apr '06

10 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4724 Modified Files: image.lisp Log Message: Read floats by rationalizing. --- /project/movitz/cvsroot/movitz/image.lisp 2005/08/21 13:47:16 1.104 +++ /project/movitz/cvsroot/movitz/image.lisp 2006/04/10 11:48:20 1.105 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.104 2005/08/21 13:47:16 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.105 2006/04/10 11:48:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1495,7 +1495,9 @@ (mapcar #'(lambda (slot) (movitz-read (slot-value expr (if (consp slot) (car slot) slot)))) slot-descriptions)) - movitz-object)))))))) + movitz-object))) + (float ; XXX + (movitz-read (rationalize expr)))))))) ;;;

1 0

[movitz-cvs] CVS movitz
by ffjeld 10 Apr '06

10 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4685 Modified Files: storage-types.lisp Log Message: Added missing update-movitz-object method. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2005/07/21 18:48:33 1.55 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2006/04/10 11:47:41 1.56 @@ -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.55 2005/07/21 18:48:33 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.56 2006/04/10 11:47:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1309,6 +1309,10 @@ (assert (= (movitz-ratio-value object) lisp-object)) object) +(defmethod update-movitz-object ((object movitz-ratio) (lisp-object float)) + (assert (= (movitz-ratio-value object) (rationalize lisp-object))) + object) + (defmethod print-object ((x movitz-ratio) stream) (print-unreadable-object (x stream :type t) (format stream "~D" (slot-value x 'value)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 10 Apr '06

10 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4635 Modified Files: special-operators.lisp Log Message: Just warn rather than error upon non-toplevel declaim. --- /project/movitz/cvsroot/movitz/special-operators.lisp 2005/08/28 21:03:53 1.54 +++ /project/movitz/cvsroot/movitz/special-operators.lisp 2006/04/10 11:47:14 1.55 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.54 2005/08/28 21:03:53 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.55 2006/04/10 11:47:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -598,7 +598,7 @@ (define-special-operator muerte::declaim-compile-time (&form form &top-level-p top-level-p) (unless top-level-p - (error "DECLAIM not at top-level.")) + (warn "DECLAIM not at top-level.")) (let ((declaration-specifiers (cdr form))) (movitz-env-load-declarations declaration-specifiers *movitz-global-environment* :declaim)) (compiler-values ()))

1 0

[movitz-cvs] CVS movitz
by ffjeld 10 Apr '06

10 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4599 Modified Files: procfs-image.lisp Log Message: Invoke debugger with a string only. --- /project/movitz/cvsroot/movitz/procfs-image.lisp 2005/05/03 20:11:43 1.24 +++ /project/movitz/cvsroot/movitz/procfs-image.lisp 2006/04/10 11:46:25 1.25 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.24 2005/05/03 20:11:43 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.25 2006/04/10 11:46:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -319,10 +319,11 @@ (let ((x (eval form))) (format t "~&~W" x) x) - (invoke-debugger "Established Bochs session [pid=~D]. ~S is ~S" - (image-pid image) - '*previous-image* - *previous-image*))))))) + (invoke-debugger + (format nil "Established Bochs session [pid=~D]. ~S is ~S" + (image-pid image) + '*previous-image* + *previous-image*)))))))) #+allegro (top-level:alias ("unbochs" 3) (&optional form)

1 0

[movitz-cvs] CVS movitz
by ffjeld 10 Apr '06

10 Apr '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4553 Modified Files: movitz.lisp Log Message: Added support for #. reader syntax (i.e. translate muerte.cl to cl package). --- /project/movitz/cvsroot/movitz/movitz.lisp 2004/11/15 14:42:15 1.10 +++ /project/movitz/cvsroot/movitz/movitz.lisp 2006/04/10 11:45:36 1.11 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:52:58 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: movitz.lisp,v 1.10 2004/11/15 14:42:15 ffjeld Exp $ +;;;; $Id: movitz.lisp,v 1.11 2006/04/10 11:45:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,6 +56,12 @@ ,@body (write-char #\> ,stream-var))))) +(defun movitz-syntax-sharp-dot (stream subchar arg) + (declare (ignore arg subchar)) + (let ((form (read stream t nil t))) + (values (unless *read-suppress* + (eval (muerte::translate-program form :muerte.cl :cl)))))) + (defmacro with-movitz-syntax (options &body body) (declare (ignore options)) `(let ((*readtable* (copy-readtable))) @@ -71,6 +77,11 @@ (make-movitz-vector (length data) :element-type 'movitz-unboxed-integer-u8 :initial-contents data)))) + (set-dispatch-macro-character #\# #\. (lambda (stream subchar arg) + (declare (ignore arg subchar)) + (let ((form (read stream t nil t))) + (values (unless *read-suppress* + (eval (muerte::translate-program form :muerte.cl :cl))))))) (set-macro-character #\` (lambda (stream char) (declare (ignore char)) (let ((*bq-level* (1+ *bq-level*)))

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-serv24514 Modified Files: print.lisp Log Message: Added write-to-string. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2005/08/26 19:38:41 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/04/07 21:54:23 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.21 2005/08/26 19:38:41 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.22 2006/04/07 21:54:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -201,6 +201,12 @@ (print-unreadable-object (c *standard-output* :type t :identity t) (format t "(while printing ~Z)" object)))))))) +(defun write-to-string (object &rest args) + (declare (dynamic-extent args)) + (apply 'write object + :stream (make-array 24 :element-type 'character :fill-pointer 0 :adjustable t) + args)) + (defun internal-write (object) (let ((stream *standard-output*)) (cond

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs April 2006