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

[movitz-cvs] CVS movitz
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv18477 Modified Files: parse.lisp Log Message: Have decode-normal-lambda-list return unlimited maxargs (nil) when &key is present (because there can always be :allow-other-keys t). --- /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 19:46:12 1.8 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 21:09:47 1.9 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.8 2008/04/21 19:46:12 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.9 2008/04/21 21:09:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,18 +25,20 @@ second the list of declaration-specifiers." (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol) (pop forms)) - while declaration-form - append (cdr declaration-form) into declarations - finally (return (values forms declarations)))) + if (declare-form-p (car forms) declare-symbol) + append (cdr (pop forms)) into declarations + else return (values forms declarations))) (defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the non-declarations forms, second the declarations, ~ and third the documentation string." - (let ((docstring (when (and (cdr forms) (stringp (car forms))) - (pop forms)))) - (multiple-value-bind (body declarations) - (parse-declarations-and-body forms declare-symbol) - (values body declarations docstring)))) + (loop with docstring = nil + if (declare-form-p (car forms) declare-symbol) + append (cdr (pop forms)) into declarations + else if (and (stringp (car forms)) + (cdr forms)) + do (setf docstring (pop forms)) + else return (values forms declarations docstring))) (defun parse-macro-lambda-list (lambda-list) (let* ((whole-var (when (eq '&whole (car lambda-list)) @@ -153,6 +155,7 @@ (defun muerte::host-program (program) (translate-program program :muerte.cl :common-lisp))) + (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p) "3.4.1 Ordinary Lambda Lists. Returns the requireds, &optionals, &rests, &keys, and &aux formal variables, @@ -210,7 +213,9 @@ (not allow-other-keys-p) (+ (length requireds) (length optionals)))) - (minargs (length requireds))) + (minargs (length requireds)) + (keys-p (not (eq :missing + (getf results (key) :missing))))) (return (values requireds optionals (first rests) @@ -218,7 +223,8 @@ auxes allow-other-keys-p minargs - maxargs + (unless keys-p + maxargs) edx-var (cond ((or (eql maxargs minargs) @@ -228,8 +234,7 @@ ((evenp (+ (length requireds) (length optionals))) :even) (t :odd)) - (not (eq :missing - (getf results (key) :missing))))))))))) + keys-p)))))))) (defun decode-optional-formal (formal) "3.4.1.2 Specifiers for optional parameters.

1 0

[movitz-cvs] CVS movitz
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27432 Modified Files: parse.lisp Log Message: parse-macro-lambda-list. --- /project/movitz/cvsroot/movitz/parse.lisp 2007/02/01 19:37:41 1.7 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 19:46:12 1.8 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.7 2007/02/01 19:37:41 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.8 2008/04/21 19:46:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,6 +38,33 @@ (parse-declarations-and-body forms declare-symbol) (values body declarations docstring)))) +(defun parse-macro-lambda-list (lambda-list) + (let* ((whole-var (when (eq '&whole (car lambda-list)) + (pop lambda-list) + (pop lambda-list))) + (env-var nil) + (operator-var (gensym)) + (destructuring-lambda-list + (do ((l lambda-list) + (r nil)) + ((atom l) + (cons operator-var + (nreconc r l))) + (let ((x (pop l))) + (if (eq x '&environment) + (setf env-var (pop l)) + (push x r))))) + (ignore-env-var + (when (not env-var) + (gensym)))) + (values destructuring-lambda-list + whole-var + (or env-var + ignore-env-var) + (when ignore-env-var + (list ignore-env-var)) + (list operator-var)))) + (defun unfold-circular-list (list) "If LIST is circular (through cdr), return (a copy of) the non-circular portion of LIST, and the index (in LIST) of the cons-cell pointed to by (cdr (last LIST))." (flet ((find-cdr (l c end)

1 0

[movitz-cvs] CVS movitz
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27370 Modified Files: packages.lisp Log Message: parse-macro-lambda-list. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/04/02 20:49:33 1.59 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/04/21 19:46:02 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.59 2008/04/02 20:49:33 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.60 2008/04/21 19:46:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1234,6 +1234,7 @@ #:decode-keyword-formal #:parse-declarations-and-body #:parse-docstring-declarations-and-body + #:parse-macro-lambda-list #:compute-function-block-name #:movitz-accessor @@ -1391,6 +1392,7 @@ muerte::decode-keyword-formal muerte::parse-declarations-and-body muerte::parse-docstring-declarations-and-body + muerte::parse-macro-lambda-list muerte::unfold-circular-list muerte::compute-function-block-name ))

1 0

[movitz-cvs] CVS movitz
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27310 Modified Files: image.lisp Log Message: Tweak stack cushion. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/17 19:27:43 1.122 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/21 19:45:51 1.123 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.122 2008/04/17 19:27:43 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.123 2008/04/21 19:45:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1022,7 +1022,7 @@ (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) (write-binary 'word stream stack-vector-word) (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) - (write-binary 'lu32 stream (+ 8 (* 6 4096) ; cushion + (write-binary 'lu32 stream (+ 8 (* 8 4096) ; cushion (- stack-vector-word (tag :other)))) (set-file-position stream (global-slot-position 'stack-top) 'stack-top) (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other))

1 0

[movitz-cvs] CVS movitz
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27251 Modified Files: compiler.lisp Log Message: Don't break on constant EQL. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/17 19:09:28 1.203 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/21 19:45:36 1.204 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.203 2008/04/17 19:09:28 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.204 2008/04/21 19:45:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -7248,7 +7248,7 @@ (:boolean-branch-on-false (when (not eql) `((:jmp ',(operands return-mode))))) - (t (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))))) + (t (warn "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))))) ((and x-singleton (eq :untagged-fixnum-ecx y-loc)) (let ((value (etypecase (car x-singleton)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27017 Modified Files: variables.lisp Log Message: Add misc. standard variables. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/03/21 22:30:40 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/04/21 19:44:13 1.13 @@ -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.12 2008/03/21 22:30:40 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.13 2008/04/21 19:44:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,6 +35,7 @@ (defvar +++ nil) (defvar *read-base* 10) +(defvar *read-eval* t) (defvar *package* nil) (defvar *macroexpand-hook* 'funcall) @@ -63,11 +64,38 @@ (defvar single-float-negative-epsilon -1/1000) (defvar double-float-negative-epsilon -1/1000) (defvar long-float-negative-epsilon -1/1000) +(defvar long-float-epsilon 1/10000) +(defconstant most-negative-short-float most-negative-fixnum) +(defconstant most-negative-single-float most-negative-fixnum) +(defconstant most-negative-long-float most-negative-fixnum) +(defconstant most-negative-double-float most-negative-fixnum) + +(defconstant least-positive-short-float 1/100000) +(defconstant least-positive-single-float 1/100000) +(defconstant least-positive-double-float 1/100000) +(defconstant least-positive-long-float 1/100000) + +(defconstant least-negative-short-float -1/100000) +(defconstant least-negative-single-float -1/100000) +(defconstant least-negative-double-float -1/100000) +(defconstant least-negative-long-float -1/100000) (defconstant call-arguments-limit 512) (defconstant lambda-parameters-limit 512) ; ? (defvar *print-pprint-dispatch* nil) -(declaim (special *build-number*)) +(defvar *build-number*) ; set at bootup + +(defvar *features* '(:movitz)) +(defvar *modules* nil) + +(defvar *compile-file-pathname* nil) +(defvar *compile-file-truename* nil) +(defvar *compile-print* nil) +(defvar *compile-verbose* nil) +(defvar *load-print* nil) +(defvar *load-verbose* nil) +(defvar *load-truename* nil) +(defvar *default-pathname-defaults* #p"")

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26953 Modified Files: typep.lisp Log Message: Misc. types. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/09 18:02:47 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/21 19:43:57 1.59 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.58 2008/04/09 18:02:47 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.59 2008/04/21 19:43:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -601,7 +601,9 @@ (or (eq xdim '*) (eql xdim adim))) dimension-spec (array-dimensions x))))))) - + +(defun arrayp (x) + (typep x 'array)) (define-simple-typep (atom atom) (x) (typep x 'atom)) @@ -706,6 +708,18 @@ (deftype float () 'real) +(deftype short-float () + 'real) + +(deftype long-float () + 'real) + +(deftype single-float () + 'real) + +(deftype double-float () + 'real) + (defun type-of (x) (class-name (class-of x)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26874 Modified Files: symbols.lisp Log Message: Check-type in gentemp. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2008/04/09 18:02:31 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2008/04/21 19:43:47 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.30 2008/04/09 18:02:31 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.31 2008/04/21 19:43:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -247,6 +247,7 @@ (defvar *gentemp-counter* 0) (defun gentemp (&optional (prefix "T") (package *package*)) + (check-type prefix string) (intern (do ((name #0=(format nil "~A~D" prefix *gentemp-counter*) #0#)) ((not (find-symbol name package)) name) (incf *gentemp-counter*))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26807 Modified Files: strings.lisp Log Message: Add deftype string-designator. --- /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/17 19:36:09 1.4 +++ /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/21 19:43:30 1.5 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 17:05:25 2001 ;;;; -;;;; $Id: strings.lisp,v 1.4 2008/04/17 19:36:09 ffjeld Exp $ +;;;; $Id: strings.lisp,v 1.5 2008/04/21 19:43:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,6 +21,9 @@ (in-package muerte) +(deftype string-designator () + '(or string symbol character)) + (defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2) (setf string1 (string string1) end1 (or end1 (length string1)) @@ -56,7 +59,9 @@ (string name) (symbol (symbol-name name)) (character (make-string 1 :initial-element name)) - (t (error "Not a string designator: ~S" name)))) + (t (error 'type-error + :datum name + :expected-type 'string-designator)))) (defun make-string (size &key initial-element (element-type 'character)) (if (not initial-element)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26713 Modified Files: streams.lisp Log Message: Various stream classes. --- /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp 2006/04/10 11:57:24 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp 2008/04/21 19:42:57 1.6 @@ -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.5 2006/04/10 11:57:24 ffjeld Exp $ +;;;; $Id: streams.lisp,v 1.6 2008/04/21 19:42:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -129,3 +129,46 @@ (simple-stream (%finish-output stream))))) +(defclass string-stream (stream) ()) + +(defun make-string-input-stream (string &optional (start 0) (end nil)) + ) + +(defun make-string-output-stream ()) + + +(defclass broadcast-stream (stream) + ((streams + :reader concatenated-stream-streams + :initarg :streams))) + +(defclass concatenated-stream (stream) + ((streams + :reader concatenated-stream-streams + :initarg :streams))) + +(defclass echo-stream (stream) + ((input-stream + :reader echo-stream-input-stream + :initarg :input-stream) + (output-stream + :reader echo-stream-output-stream + :initarg :output-stream))) + +(defclass file-stream (stream) + ()) + +(defclass synonym-stream (stream) + ((symbol + :initarg :symbol + :reader synonym-stream-symbol))) + +(defclass two-way-stream (stream) + ((input + :initarg :input + :reader two-way-stream-input-stream) + (output + :initarg :output + :reader two-way-stream-output-stream))) + +

1 0