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

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

06 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14881 Modified Files: cons.lisp Log Message: Moved adjoin to cons.lisp. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/02 20:01:01 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/06 20:30:53 1.16 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.15 2006/05/02 20:01:01 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.16 2006/05/06 20:30:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -375,3 +375,12 @@ (defun nsubst-if-not (new predicate tree &key key) (nsubst-if new (complement predicate) tree :key key)) + + +(defun adjoin (item list &key key (test 'eql) test-not) + "=> new-list + Tests whether item is the same as an existing element of list. If the item is not an existing element, adjoin adds it to +list (as if by cons) and returns the resulting list; otherwise, nothing is added and the original list is returned." + (if (member item list :key key :test test :test-not test-not) + list + (cons item list)))

1 0

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

06 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13407 Modified Files: typep.lisp Log Message: Tweak etypecase-error. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2006/04/10 11:58:15 1.53 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2006/05/06 20:29:10 1.54 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.53 2006/04/10 11:58:15 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.54 2006/05/06 20:29:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,11 +38,10 @@ else collect `((typep ,key-var ',type) ,@forms))))))) (defmacro etypecase (keyform &rest clauses) - `(typecase ,keyform ,@clauses - (t (error "~S fell through an etypecase where the legal types were ~S." - ,keyform - ',(loop for c in clauses - collect (car c)))))) + (let ((key-var (make-symbol "etypecase-key-var-"))) + `(let ((,key-var ,keyform)) + (typecase ,key-var ,@clauses + (t (etypecase-error ,key-var ',(loop for c in clauses collect (car c)))))))) (define-compile-time-variable *simple-typespecs* ;; map symbol typespecs to typep-functions.

1 0

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

06 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13391 Modified Files: conditions.lisp Log Message: Tweak etypecase-error. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/04/28 23:21:59 1.19 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/05/06 20:29:08 1.20 @@ -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.19 2006/04/28 23:21:59 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.20 2006/05/06 20:29:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -115,6 +115,18 @@ (type-error-datum c) (type-error-expected-type c))))) +(define-condition etypecase-error (type-error) + () + (:report (lambda (c s) + (format s "The object '~S' fell through an etypecase where the legal types were ~S." + (type-error-datum c) + (type-error-expected-type c))))) + +(defun etypecase-error (datum expecteds) + (error 'etypecase-error + :datum datum + :expected-type (cons 'or expecteds))) + (define-condition control-error (error) ()) (define-condition throw-error (control-error)

1 0

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

06 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8161 Modified Files: lists.lisp Log Message: For member, apply key to item too. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/05 21:39:02 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/06 19:36:50 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.16 2006/05/05 21:39:02 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.17 2006/05/06 19:36:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -125,7 +125,7 @@ (with-funcallable (test (or (and test-not (complement test-not)) test)) (do ((p list (cdr p))) ((endp p) nil) - (when (test item (key (car p))) + (when (test (key item) (key (car p))) (return p))))))))) (defun last (list &optional (n 1))

1 0

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

05 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4536 Modified Files: lists.lisp Log Message: Added test-not to member. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/03 22:20:02 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/05 21:39:02 1.16 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.15 2006/05/03 22:20:02 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.16 2006/05/05 21:39:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,17 +112,17 @@ ;; That fact justifies this implementation.) (when (and (eq fast slow) (> n 0)) (return nil)))) -(defun member (item list &key key (test 'eql)) +(defun member (item list &key key (test 'eql) test-not) (numargs-case (2 (item list) (do ((p list (cdr p))) ((endp p) nil) (when (eql item (car p)) (return p)))) - (t (item list &key key (test 'eql)) + (t (item list &key key (test 'eql) test-not) (let ((key (or key 'identity))) (with-funcallable (key) - (with-funcallable (test) + (with-funcallable (test (or (and test-not (complement test-not)) test)) (do ((p list (cdr p))) ((endp p) nil) (when (test item (key (car p)))

1 0

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

05 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30338 Modified Files: more-macros.lisp Log Message: Fixed member compiler-macro: apply key to both list and item. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/05 18:33:08 1.34 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/05 20:42:04 1.35 @@ -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.34 2006/05/05 18:33:08 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.35 2006/05/05 20:42:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -162,7 +162,7 @@ `(do ((item ,item) (p ,list (cdr p))) ((endp p) nil) - (when (,test (,key item) (car p)) + (when (,test (,key item) (,key (car p))) (return p)))) (t form))))

1 0

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

05 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16312 Modified Files: interrupt.lisp Log Message: Have int 102 signal missing keyword argument error. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/02 20:03:15 1.50 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/05 18:39:52 1.51 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.50 2006/05/02 20:03:15 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.51 2006/05/05 18:39:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -395,6 +395,10 @@ (error 'program-error :format-control "Illegal keyword argument [eax: ~S]" :format-arguments (list (dereference $eax)))) + (102 + (error 'program-error + :format-control "Missing keyword argument for ~S." + :format-arguments (list (dereference (+ dit-frame (dit-frame-index :esi)))))) (108 (error 'throw-error :tag (dereference $eax))) (110

1 0

[movitz-cvs] CVS movitz
by ffjeld 05 May '06

05 May '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv16205 Modified Files: parse.lisp Log Message: For &key args parsing, check that we have an even number of keyword/value args. --- /project/movitz/cvsroot/movitz/parse.lisp 2004/12/09 14:09:58 1.5 +++ /project/movitz/cvsroot/movitz/parse.lisp 2006/05/05 18:37:37 1.6 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.5 2004/12/09 14:09:58 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.6 2006/05/05 18:37:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -145,8 +145,8 @@ (key () '(fourth program)) (aux () '(fifth program)) (allow-other-keys () '(if host-symbols-p - '&allow-other-keys - 'muerte.cl::&allow-other-keys))) + '&allow-other-keys + 'muerte.cl::&allow-other-keys))) (loop for formal in lambda-list with program = (if host-symbols-p '(requireds &optional &rest &key &aux) @@ -177,19 +177,29 @@ (auxes (nreverse (getf results (aux))))) (when (> (length rests) 1) (error "There can only be one &REST formal parameter.")) - (return (values requireds - optionals - (first rests) - keys - auxes - allow-other-keys-p - (length requireds) ; minimum num. of arguments - (and (null rests) ; max num. of arguments, or nil. + (let ((maxargs (and (null rests) ; max num. of arguments, or nil. + (null keys) (not allow-other-keys-p) (+ (length requireds) - (length optionals) - (* 2 (length keys)))) - edx-var))))))) + (length optionals)))) + (minargs (length requireds))) + (return (values requireds + optionals + (first rests) + keys + auxes + allow-other-keys-p + minargs + maxargs + edx-var + (cond + ((or (eql maxargs minargs) + (eq :no-key (getf results (key) :no-key))) + nil) + ((assert (not maxargs))) + ((evenp (+ (length requireds) (length optionals))) + :even) + (t :odd)))))))))) (defun decode-optional-formal (formal) "3.4.1.2 Specifiers for optional parameters.

1 0

[movitz-cvs] CVS movitz
by ffjeld 05 May '06

05 May '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv16191 Modified Files: environment.lisp Log Message: For &key args parsing, check that we have an even number of keyword/value args. --- /project/movitz/cvsroot/movitz/environment.lisp 2005/10/31 20:30:32 1.15 +++ /project/movitz/cvsroot/movitz/environment.lisp 2006/05/05 18:37:34 1.16 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.15 2005/10/31 20:30:32 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.16 2006/05/05 18:37:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -186,6 +186,9 @@ (max-args :initform nil :accessor max-args) + (oddeven-args + :initform nil + :accessor oddeven-args) (allow-other-keys-p :accessor allow-other-keys-p) (edx-var

1 0

[movitz-cvs] CVS movitz
by ffjeld 05 May '06

05 May '06

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv16165 Modified Files: compiler.lisp Log Message: For &key args parsing, check that we have an even number of keyword/value args. --- /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/02 19:59:55 1.169 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/05 18:37:32 1.170 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.169 2006/05/02 19:59:55 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.170 2006/05/05 18:37:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -4257,11 +4257,12 @@ (defun add-bindings-from-lambda-list (lambda-list env) "From a (normal) <lambda-list>, add bindings to <env>." (let ((arg-pos 0)) - (multiple-value-bind (required-vars optional-vars rest-var key-vars auxes allow-p min-args max-args edx-var) + (multiple-value-bind (required-vars optional-vars rest-var key-vars auxes allow-p min-args max-args edx-var oddeven) (decode-normal-lambda-list lambda-list) (declare (ignore auxes)) (setf (min-args env) min-args (max-args env) max-args + (oddeven-args env) oddeven (allow-other-keys-p env) allow-p) (flet ((shadow-when-special (formal env) "Iff <formal> is special, return a fresh variable-name that takes <formal>'s place @@ -4590,22 +4591,37 @@ eax-ebx-code (make-stack-setup-code stack-setup-size) (when need-normalized-ecx-p - (cond - ;; normalize arg-count in ecx.. - ((and max-args (= min-args max-args)) - (error "huh?")) - ((and max-args (<= 0 min-args max-args #x7f)) - `((:andl #x7f :ecx))) - ((>= min-args #x80) - `((:shrl 8 :ecx))) - (t (let ((normalize (make-symbol "normalize-ecx")) - (normalize-done (make-symbol "normalize-ecx-done"))) - `((:testb :cl :cl) - (:js '(:sub-program (,normalize) - (:shrl 8 :ecx) - (:jmp ',normalize-done))) - (:andl #x7f :ecx) - ,normalize-done))))) + (let ((oddeven-ok (gensym "oddeven-ok-"))) + (append (cond + ;; normalize arg-count in ecx.. + ((and max-args (= min-args max-args)) + (error "huh?")) + ((and max-args (<= 0 min-args max-args #x7f)) + `((:andl #x7f :ecx))) + ((>= min-args #x80) + `((:shrl 8 :ecx))) + (t (let ((normalize (make-symbol "normalize-ecx")) + (normalize-done (make-symbol "normalize-ecx-done"))) + `((:testb :cl :cl) + (:js '(:sub-program (,normalize) + (:shrl 8 :ecx) + (:jmp ',normalize-done))) + (:andl #x7f :ecx) + ,normalize-done)))) + (when (and (oddeven-args env) + (optional-vars env)) + `((:cmpl ,(length (optional-vars env)) :ecx) + (:jbe ',oddeven-ok))) + (case (oddeven-args env) + (:even + `((:testb 1 :cl) + (:jnz '(:sub-program () (:int 102))))) + (:odd + `((:testb 1 :cl) + (:jz '(:sub-program () (:int 102)))))) + (when (and (oddeven-args env) + (optional-vars env)) + (list oddeven-ok))))) (when edx-needs-saving-p `((:movl :edx (:ebp ,(stack-frame-offset (new-binding-location (edx-var env) frame-map)))))) eax-ebx-code-post-stackframe @@ -6790,15 +6806,15 @@ (append (make-load-lexical binding tmp-register funobj nil frame-map) `((:leal (,tmp-register -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program (,(gensym "endp-not-cons-")) - (:int 66))))))))) + (:jnz '(:sub-program (,(gensym "endp-not-list-")) + (:int 61))))))))) (t (let ((tmp-register (or tmp-register :eax))) (append (make-load-lexical binding tmp-register funobj nil frame-map) (unless binding-is-list-p `((:leal (,tmp-register -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program (,(gensym "endp-not-cons-")) - (:int 66))))) + (:jnz '(:sub-program (,(gensym "endp-not-list-")) + (:int 61))))) `((:cmpl :edi ,tmp-register)) (make-result-and-returns-glue result-mode :boolean-zf=1)))))))))))

1 0