From ffjeld at common-lisp.net Tue May 2 17:12:20 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 13:12:20 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502171220.41AB92E18A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24627 Modified Files: cons.lisp Log Message: Minor tweaks to sublis and nsublis. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/04/30 21:38:40 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/02 17:12:20 1.14 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.13 2006/04/30 21:38:40 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.14 2006/05/02 17:12:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,18 +294,18 @@ (cons car cdr)))))))) (s tree)))) -(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp)) +(defun nsublis (alist tree &key key (test #'eql) test-not) "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)) + (cond ((setq temp (assoc (funcall key subtree) alist :test test)) (cdr temp)) ((atom subtree) subtree) (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) + (subtree subtree (cdr subtree))) ((atom subtree) (if (setq temp (assoc (funcall key subtree) alist :test test)) (setf (cdr last) (cdr temp)))) From ffjeld at common-lisp.net Tue May 2 19:59:55 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 15:59:55 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060502195955.3B33C4507D@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14806 Modified Files: compiler.lisp Log Message: Various tweaks for compiling forms with literal objects as arguments to certain operators. --- /project/movitz/cvsroot/movitz/compiler.lisp 2006/04/28 23:20:45 1.168 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/02 19:59:55 1.169 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.168 2006/04/28 23:20:45 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.169 2006/05/02 19:59:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3889,10 +3889,21 @@ (ecase (operator location) ((:argument-stack) `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) - ((:eax :ebx :edx) + ((:eax :ebx :ecx :edx) (make-immediate-move immediate location)) ((:untagged-fixnum-ecx) (make-immediate-move (movitz-fixnum-value value) :ecx)))))) + (movitz-character + (let ((immediate (movitz-immediate-value value))) + (if (integerp location) + (let ((tmp (chose-free-register protect-registers))) + (append (make-immediate-move immediate tmp) + `((:movl ,tmp (:ebp ,(stack-frame-offset location)))))) + (ecase (operator location) + ((:argument-stack) + `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) + ((:eax :ebx :ecx :edx) + (make-immediate-move immediate location)))))) (movitz-heap-object (etypecase location ((member :eax :ebx :edx) @@ -6676,50 +6687,65 @@ (destructuring-bind (op cell dst) (cdr instruction) (check-type dst (member :eax :ebx :ecx :edx)) - (multiple-value-bind (op-offset fast-op fast-op-ebx) + (multiple-value-bind (op-offset fast-op fast-op-ebx cl-op) (ecase op (:car (values (bt:slot-offset 'movitz-cons 'car) 'fast-car - 'fast-car-ebx)) + 'fast-car-ebx + 'movitz-car)) (:cdr (values (bt:slot-offset 'movitz-cons 'cdr) 'fast-cdr - 'fast-cdr-ebx))) - (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 "~A of loc ~A bind ~A" op location binding) - (cond - ((and binding-is-list-p - (member location '(:eax :ebx :ecx :edx))) - `((,*compiler-nonlocal-lispval-read-segment-prefix* - :movl (,location ,op-offset) ,dst))) - (binding-is-list-p - `(,@(make-load-lexical binding dst funobj nil frame-map) - (,*compiler-nonlocal-lispval-read-segment-prefix* - :movl (,dst ,op-offset) ,dst))) - ((not *compiler-use-cons-reader-segment-protocol-p*) - (cond - ((eq location :ebx) - `((,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset fast-op-ebx))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst))))) - (t `(,@(make-load-lexical binding :eax funobj nil frame-map) - (,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset fast-op))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst))))))) - (t (cond - ((member location '(:ebx :ecx :edx)) - `((,(or *compiler-cons-read-segment-prefix* - *compiler-nonlocal-lispval-read-segment-prefix*) - :movl (:eax ,op-offset) ,dst))) - (t (append (make-load-lexical binding :eax funobj nil frame-map) - `((,(or *compiler-cons-read-segment-prefix* - *compiler-nonlocal-lispval-read-segment-prefix*) - :movl (:eax ,op-offset) ,dst))))))))))) - - + 'fast-cdr-ebx + 'movitz-cdr))) + (let ((binding (binding-target (ensure-local-binding (binding-target cell) funobj)))) + (etypecase binding + (constant-object-binding + (let ((x (constant-object binding))) + (typecase x + (movitz-null + (make-load-constant *movitz-nil* dst funobj frame-map)) + (movitz-cons + (append (make-load-constant x dst funobj frame-map) + `((:movl (,dst ,op-offset) ,dst)))) + (t `(,@(make-load-lexical binding :eax funobj nil frame-map) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst)))))))) + (lexical-binding + (let ((location (new-binding-location (binding-target binding) frame-map)) + (binding-is-list-p (binding-store-subtypep binding 'list))) + #+ignore (warn "~A of loc ~A bind ~A" op location binding) + (cond + ((and binding-is-list-p + (member location '(:eax :ebx :ecx :edx))) + `((,*compiler-nonlocal-lispval-read-segment-prefix* + :movl (,location ,op-offset) ,dst))) + (binding-is-list-p + `(,@(make-load-lexical binding dst funobj nil frame-map) + (,*compiler-nonlocal-lispval-read-segment-prefix* + :movl (,dst ,op-offset) ,dst))) + ((not *compiler-use-cons-reader-segment-protocol-p*) + (cond + ((eq location :ebx) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op-ebx))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst))))) + (t `(,@(make-load-lexical binding :eax funobj nil frame-map) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst))))))) + (t (cond + ((member location '(:ebx :ecx :edx)) + `((,(or *compiler-cons-read-segment-prefix* + *compiler-nonlocal-lispval-read-segment-prefix*) + :movl (:eax ,op-offset) ,dst))) + (t (append (make-load-lexical binding :eax funobj nil frame-map) + `((,(or *compiler-cons-read-segment-prefix* + *compiler-nonlocal-lispval-read-segment-prefix*) + :movl (:eax ,op-offset) ,dst)))))))))))))) ;;;;;;;;;;;;;;;;;; endp @@ -6732,39 +6758,49 @@ (define-extended-code-expander :endp (instruction funobj frame-map) (destructuring-bind (cell result-mode) (cdr instruction) - (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)) - (tmp-register (case location - ((:eax :ebx :ecx :edx) - location)))) - ;; (warn "endp of loc ~A bind ~A" location binding) - (cond - ((and binding-is-list-p - (member location '(:eax :ebx :ecx :edx))) - (make-result-and-returns-glue result-mode :boolean-zf=1 - `((:cmpl :edi ,location)))) - ((eq :boolean-branch-on-true (result-mode-type result-mode)) - (let ((tmp-register (or tmp-register :ecx))) - (append (make-load-lexical binding - (cons :boolean-branch-on-false - (cdr result-mode)) - funobj nil frame-map) - (unless binding-is-list-p - (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))))))))) - (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))))) - `((:cmpl :edi ,tmp-register)) - (make-result-and-returns-glue result-mode :boolean-zf=1)))))))) + (let ((binding (binding-target (ensure-local-binding (binding-target cell) funobj)))) + (etypecase binding + (constant-object-binding + (let ((x (constant-object binding))) + (typecase x + (movitz-cons + (make-load-constant *movitz-nil* result-mode funobj frame-map)) + (movitz-null + (make-load-constant (image-t-symbol *image*) result-mode funobj frame-map)) + (t '((:int 61)))))) + (lexical-binding + (let* ((location (new-binding-location (binding-target binding) frame-map)) + (binding-is-list-p (binding-store-subtypep binding 'list)) + (tmp-register (case location + ((:eax :ebx :ecx :edx) + location)))) + ;; (warn "endp of loc ~A bind ~A" location binding) + (cond + ((and binding-is-list-p + (member location '(:eax :ebx :ecx :edx))) + (make-result-and-returns-glue result-mode :boolean-zf=1 + `((:cmpl :edi ,location)))) + ((eq :boolean-branch-on-true (result-mode-type result-mode)) + (let ((tmp-register (or tmp-register :ecx))) + (append (make-load-lexical binding + (cons :boolean-branch-on-false + (cdr result-mode)) + funobj nil frame-map) + (unless binding-is-list-p + (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))))))))) + (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))))) + `((:cmpl :edi ,tmp-register)) + (make-result-and-returns-glue result-mode :boolean-zf=1))))))))))) ;;;;;;;;;;;;;;;;;; incf-lexvar @@ -6867,11 +6903,23 @@ (type1 (and (binding-store-type term1) (apply #'encoded-type-decode (binding-store-type term1)))) (singleton0 (and type0 (type-specifier-singleton type0))) - (singleton1 (and type1 (type-specifier-singleton type1)))) - (append (unless (and singleton0 (typep (car singleton0) 'movitz-fixnum)) - (list term0)) - (unless (and singleton1 (typep (car singleton1) 'movitz-fixnum)) - (list term1))))) + (singleton1 (and type1 (type-specifier-singleton type1))) + (singleton-sum (and singleton0 singleton1 + (type-specifier-singleton + (apply #'encoded-integer-types-add + (append (binding-store-type term0) + (binding-store-type term1))))))) + (cond + (singleton-sum + (let ((b (make-instance 'constant-object-binding + :name (gensym "constant-sum") + :object (car singleton-sum)))) + (movitz-env-add-binding (binding-env term0) b) + (list b))) + (t (append (unless (and singleton0 (typep (car singleton0) 'movitz-fixnum)) + (list term0)) + (unless (and singleton1 (typep (car singleton1) 'movitz-fixnum)) + (list term1))))))) (define-extended-code-expander :add (instruction funobj frame-map) (destructuring-bind (term0 term1 destination) From ffjeld at common-lisp.net Tue May 2 20:00:20 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:00:20 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200020.A91D748145@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16035 Modified Files: arrays.lisp Log Message: Added bit and sbit accessors. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/04/07 21:47:44 1.57 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/02 20:00:20 1.58 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.57 2006/04/07 21:47:44 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.58 2006/05/02 20:00:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -620,6 +620,153 @@ (defun (setf char%unsafe) (value string index) (setf (char%unsafe string index) value)) +;;; bit accessors + +(defun bit (array &rest subscripts) + (numargs-case + (2 (array index) + (etypecase array + (indirect-vector + (with-indirect-vector (indirect array :check-type nil) + (aref (indirect displaced-to) (+ index (indirect displaced-offset))))) + (simple-bit-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) array index) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:cmpl :ebx + (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))) + (:jbe '(:sub-program (out-of-bounds) + (:compile-form (:result-mode :ignore) + (error "Index ~D is beyond vector length ~D." + index + (memref array + (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))) + :bit + (:movl :ebx :ecx) + (:movl :eax :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :eax :eax) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jnc 'return) + (:addl ,movitz:+movitz-fixnum-factor+ :eax) + return))) + (do-it))))) + (t (vector &rest subscripts) + (declare (ignore vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + +(defun sbit (array &rest subscripts) + (numargs-case + (2 (array index) + (check-type array simple-bit-vector) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) array index) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:cmpl :ebx + (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))) + (:jbe '(:sub-program (out-of-bounds) + (:compile-form (:result-mode :ignore) + (error "Index ~D is beyond vector length ~D." + index + (memref array + (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))) + :bit + (:movl :ebx :ecx) + (:movl :eax :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :eax :eax) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jnc 'return) + (:addl ,movitz:+movitz-fixnum-factor+ :eax) + return))) + (do-it))) + (t (vector &rest subscripts) + (declare (ignore vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + + +(defun (setf bit) (value vector &rest subscripts) + (numargs-case + (3 (value vector index) + (check-type value bit) + (etypecase vector + (indirect-vector + (with-indirect-vector (indirect vector :check-type nil) + (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset))) + value))) + (simple-bit-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:compile-form (:result-mode :edx) index) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (not-an-index) + (:compile-form (:result-mode :ignore) + (error "Not a vector index: ~S." index)))) + (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :edx) + (:jnc '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Index ~S out of range." index)))) + (:movl :edx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + + (:testl :eax :eax) + (:jnz 'set-one-bit) + (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + set-one-bit + (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + return))) + (do-it))))) + (t (value vector &rest subscripts) + (declare (ignore value vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + +(defun (setf sbit) (value vector &rest subscripts) + (numargs-case + (3 (value vector index) + (check-type value bit) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:compile-form (:result-mode :edx) index) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (not-an-index) + (:compile-form (:result-mode :ignore) + (error "Not a vector index: ~S." index)))) + (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :edx) + (:jnc '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Index ~S out of range." index)))) + (:movl :edx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + + (:testl :eax :eax) + (:jnz 'set-one-bit) + (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + set-one-bit + (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + return))) + (do-it))) + (t (value vector &rest subscripts) + (declare (ignore value vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + ;;; u8 accessors (define-compiler-macro u8ref%unsafe (vector index) From ffjeld at common-lisp.net Tue May 2 20:01:01 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:01:01 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200101.96C1048145@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16294 Modified Files: cons.lisp Log Message: Added the subst family of functions. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/02 17:12:20 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/02 20:01:01 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.14 2006/05/02 17:12:20 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.15 2006/05/02 20:01:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -288,7 +288,7 @@ ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) - (if (and (eq car (car subtreE)) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr)))))))) @@ -310,7 +310,68 @@ (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))) + (return (setf (Cdr last) (cdr temp))) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree)))) + +(defun subst (new old tree &key key (test 'eql) test-not) + "=> new-tree" + (let ((test (if test-not (complement test-not) test)) + (key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall test old (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (cons (do-subst (car subtree)) + (do-subst (cdr subtree))))))) + (do-subst tree)))) + +(defun subst-if (new predicate tree &key key) + "=> new-tree" + (let ((key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall predicate (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (cons (do-subst (car subtree)) + (do-subst (cdr subtree))))))) + (do-subst tree)))) + +(defun subst-if-not (new predicate tree &key key) + (subst-if new (complement predicate) tree :key key)) + +(defun nsubst (new old tree &key key (test 'eql) test-not) + (let ((test (if test-not (complement test-not) test)) + (key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall test old (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (setf (car subtree) (do-subst (car subtree)) + (cdr subtree) (do-subst (cdr subtree))) + subtree)))) + (do-subst tree)))) + +(defun nsubst-if (new predicate tree &key key) + "=> new-tree" + (let ((key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall predicate (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (setf (car subtree) (do-subst (car subtree)) + (cdr subtree) (do-subst (cdr subtree))) + subtree)))) + (do-subst tree)))) + +(defun nsubst-if-not (new predicate tree &key key) + (nsubst-if new (complement predicate) tree :key key)) From ffjeld at common-lisp.net Tue May 2 20:01:46 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:01:46 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200146.2BD4448145@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16336 Modified Files: functions.lisp Log Message: Fix constantly compiler-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2006/04/07 21:52:17 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2006/05/02 20:01:46 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.30 2006/04/07 21:52:17 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.31 2006/05/02 20:01:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,17 +44,11 @@ (case (translate-program value :muerte.cl :cl) ((t) `(function constantly-true)) ((nil) `(function constantly-false)) - (t `(make-prototyped-function (constantly ,value) - constantly-prototype - (value ,value)))))) - (t (let ((value-var (gensym "constantly-value-"))) - `(let ((,value-var ,value-form)) - (lambda (&rest ignore) - (declare (ignore ignore)) - ,value-var)))))) + (t form)))) + (t form))) (defun constantly (x) - (compiler-macro-call constantly x)) + (lambda () x)) (defun complement-prototype (&rest args) (declare (dynamic-extent args)) From ffjeld at common-lisp.net Tue May 2 20:02:13 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:02:13 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200213.740AA62010@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16528 Modified Files: integers.lisp Log Message: Added realp. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/04/07 21:35:32 1.121 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/05/02 20:02:09 1.122 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.121 2006/04/07 21:35:32 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.122 2006/05/02 20:02:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2260,3 +2260,6 @@ (defun rational (number) number) + +(defun realp (x) + (typep x 'real)) From ffjeld at common-lisp.net Tue May 2 20:03:15 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:03:15 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200315.4EF743106B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16690 Modified Files: interrupt.lisp Log Message: Map int 101 to "illegal keyword argument" error. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2005/09/01 22:53:53 1.49 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/02 20:03:15 1.50 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.49 2005/09/01 22:53:53 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.50 2006/05/02 20:03:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -391,6 +391,10 @@ (ldb (byte 8 24) (dit-frame-ref nil dit-frame :ecx :unsigned-byte32)) code)))) + (101 + (error 'program-error + :format-control "Illegal keyword argument [eax: ~S]" + :format-arguments (list (dereference $eax)))) (108 (error 'throw-error :tag (dereference $eax))) (110 From ffjeld at common-lisp.net Tue May 2 20:03:47 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:03:47 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200347.C7FF63106B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16739 Modified Files: more-macros.lisp Log Message: Improve pushnew to accept test-not. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/28 23:21:32 1.32 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/02 20:03:47 1.33 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.32 2006/04/28 23:21:32 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.33 2006/05/02 20:03:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,22 +63,27 @@ `(setq ,place (cons ,item ,place)) form)) -(defmacro pushnew (&environment env item place &key (key ''identity) (test ''eq) test-not) - (when test-not - (error "Test-not not supported.")) - (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) - (get-setf-expansion place env) - (assert (= 1 (length store-vars)) () - "Can't pushnew a place with ~D cells." (length store-vars)) - (let ((store-var (first store-vars)) - (item-var (gensym "push-item-"))) - `(let ((,item-var ,item) - ,@(mapcar #'list tmp-vars tmp-var-init-forms)) - (let ((old-value ,getter-form)) - (if (not (member ,item-var old-value :key ,key :test ,test)) - (let ((,store-var (cons ,item-var old-value))) - ,setter-form) - old-value)))))) +(defmacro pushnew (&environment env item place &key (key nil keyp) (test nil testp) (test-not nil test-notp)) + (let ((testing + (cond + (testp (list :test test)) + (test-notp (list :test-not test-not)))) + (keying + (cond + (keyp (list :key key))))) + (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) + (get-setf-expansion place env) + (assert (= 1 (length store-vars)) () + "Can't pushnew a place with ~D cells." (length store-vars)) + (let ((store-var (first store-vars)) + (item-var (gensym "push-item-"))) + `(let ((,item-var ,item) + ,@(mapcar #'list tmp-vars tmp-var-init-forms)) + (let ((old-value ,getter-form)) + (if (not (member ,item-var old-value , at keying , at testing)) + (let ((,store-var (cons ,item-var old-value))) + ,setter-form) + old-value))))))) (defmacro remf (&environment env place indicator) (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) From ffjeld at common-lisp.net Tue May 2 20:04:15 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 2 May 2006 16:04:15 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060502200415.9313B3106B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16773 Modified Files: print.lisp Log Message: Fix write-to-string to actually return string. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/04/07 21:54:23 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/05/02 20:04:15 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.22 2006/04/07 21:54:23 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.23 2006/05/02 20:04:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -203,9 +203,9 @@ (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)) + (let ((string (make-array 24 :element-type 'character :fill-pointer 0 :adjustable t))) + (apply 'write object :stream string args) + string)) (defun internal-write (object) (let ((stream *standard-output*)) From ffjeld at common-lisp.net Wed May 3 22:20:02 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 3 May 2006 18:20:02 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060503222002.7153C650CD@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26386 Modified Files: lists.lisp Log Message: Fix member to accept nil key. Fix copy-list to accept dotted list. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/04/29 11:41:34 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/03 22:20:02 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.14 2006/04/29 11:41:34 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.15 2006/05/03 22:20:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,20 +112,21 @@ ;; That fact justifies this implementation.) (when (and (eq fast slow) (> n 0)) (return nil)))) -(defun member (item list &key (key 'identity) (test 'eql)) +(defun member (item list &key key (test 'eql)) (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 'identity) (test 'eql)) - (with-funcallable (key) - (with-funcallable (test) - (do ((p list (cdr p))) - ((endp p) nil) - (when (test item (key (car p))) - (return p)))))))) + (t (item list &key key (test 'eql)) + (let ((key (or key 'identity))) + (with-funcallable (key) + (with-funcallable (test) + (do ((p list (cdr p))) + ((endp p) nil) + (when (test item (key (car p))) + (return p))))))))) (defun last (list &optional (n 1)) ;; from the hyperspec.. @@ -198,10 +199,10 @@ (defun copy-list (list) (if (null list) nil - (let ((new-list (cons (pop list) nil))) + (let ((new-list (cons (pop list) list))) (do ((new-tail new-list (cdr new-tail))) - ((null list) new-list) - (setf (cdr new-tail) (cons (pop list) nil)))))) + ((atom list) new-list) + (setf (cdr new-tail) (cons (pop list) list)))))) (defun list (&rest objects) (numargs-case From ffjeld at common-lisp.net Fri May 5 18:14:41 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 14:14:41 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060505181441.40F0358323@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12742 Modified Files: arrays.lisp Log Message: Added bitref%unsafe accessor. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/02 20:00:20 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/05 18:14:41 1.59 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.58 2006/05/02 20:00:20 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.59 2006/05/05 18:14:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -694,6 +694,26 @@ (declare (ignore vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) +(defun bitref%unsafe (array index) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) array index) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + :bit + (:movl :ebx :ecx) + (:movl :eax :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :eax :eax) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jnc 'return) + (:addl ,movitz:+movitz-fixnum-factor+ :eax) + return))) + (do-it))) + (defun (setf bit) (value vector &rest subscripts) (numargs-case @@ -767,6 +787,30 @@ (declare (ignore value vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) +(defun (setf bitref%unsafe) (value vector index) + (macrolet + ((do-it () + `(progn + (check-type value bit) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:compile-form (:result-mode :edx) index) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (not-an-index) + (:compile-form (:result-mode :ignore) + (error "Not a vector index: ~S." index)))) + (:movl :edx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + + (:testl :eax :eax) + (:jnz 'set-one-bit) + (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + set-one-bit + (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + return)))) + (do-it))) + ;;; u8 accessors (define-compiler-macro u8ref%unsafe (vector index) @@ -830,7 +874,9 @@ (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) (values vector #'u32ref%unsafe #'(setf u32ref%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :code) - (values vector #'u8ref%unsafe #'(setf u8ref%unsafe))) + (values vector #'u8ref%unsafe #'(setf u8ref%unsafe))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit) + (values vector #'bitref%unsafe #'(setf bitref%unsafe))) (t (warn "don't know about vector's element-type: ~S" vector) (values vector #'aref #'(setf aref))))))) From ffjeld at common-lisp.net Fri May 5 18:33:08 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 14:33:08 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060505183308.D7E5F65003@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16015 Modified Files: more-macros.lisp Log Message: Fixed bug in member compiler-macro: Order of arguments to test was reversed. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/02 20:03:47 1.33 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/05 18:33:08 1.34 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.33 2006/05/02 20:03:47 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.34 2006/05/05 18:33:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -155,14 +155,14 @@ `(do ((item ,item) (p ,list (cdr p))) ((endp p) nil) - (when (,test (car p) item) + (when (,test item (car p)) (return p)))) ((and test (symbolp test) key (symbolp key)) `(do ((item ,item) (p ,list (cdr p))) ((endp p) nil) - (when (,test (car p) (,key item)) + (when (,test (,key item) (car p)) (return p)))) (t form)))) From ffjeld at common-lisp.net Fri May 5 18:37:32 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 14:37:32 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060505183732.7D6E767001@common-lisp.net> 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) , add bindings to ." (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 is special, return a fresh variable-name that takes '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))))))))))) From ffjeld at common-lisp.net Fri May 5 18:37:34 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 14:37:34 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060505183734.EA5596700C@common-lisp.net> 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 From ffjeld at common-lisp.net Fri May 5 18:37:38 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 14:37:38 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060505183738.252AC710EB@common-lisp.net> 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. From ffjeld at common-lisp.net Fri May 5 18:39:52 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 14:39:52 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060505183952.45FFF111CC@common-lisp.net> 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 ;;;; 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 From ffjeld at common-lisp.net Fri May 5 20:42:04 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 16:42:04 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060505204204.6DDBF4610C@common-lisp.net> 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 ;;;; 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)))) From ffjeld at common-lisp.net Fri May 5 21:39:02 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 5 May 2006 17:39:02 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060505213902.42E7D6400A@common-lisp.net> 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))) From ffjeld at common-lisp.net Sat May 6 19:36:50 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 15:36:50 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506193650.2227F69002@common-lisp.net> 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)) From ffjeld at common-lisp.net Sat May 6 20:29:09 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 16:29:09 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506202909.1673215001@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Sat May 6 20:29:11 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 16:29:11 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506202911.086D716008@common-lisp.net> 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) , at forms))))))) (defmacro etypecase (keyform &rest clauses) - `(typecase ,keyform , at 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 , at 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. From ffjeld at common-lisp.net Sat May 6 20:30:53 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 16:30:53 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506203053.1417718005@common-lisp.net> 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))) From ffjeld at common-lisp.net Sat May 6 20:30:55 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 16:30:55 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506203055.66EE51800A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14898 Modified Files: lists.lisp Log Message: Moved adjoin to cons.lisp. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/06 19:36:50 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/06 20:30:54 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.17 2006/05/06 19:36:50 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.18 2006/05/06 20:30:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -442,10 +442,4 @@ (unless (member x list-2 :key key :test test) (return nil))))) -(defun adjoin (item list &key (key 'identity) (test 'eql) test-not) - "=> new-list" - (let ((test (if test-not (complement test-not) test))) - (if (member (funcall key item) list :test test) - list - (cons item list)))) From ffjeld at common-lisp.net Sat May 6 20:31:23 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 16:31:23 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506203123.BB3BE2000F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14958 Modified Files: more-macros.lisp Log Message: Rewrite more-macros to use adjoin. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/05 20:42:04 1.35 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/06 20:31:23 1.36 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.35 2006/05/05 20:42:04 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.36 2006/05/06 20:31:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -62,29 +62,19 @@ (not (typep (movitz::movitz-binding place env) 'movitz::symbol-macro-binding))) `(setq ,place (cons ,item ,place)) form)) - -(defmacro pushnew (&environment env item place &key (key nil keyp) (test nil testp) (test-not nil test-notp)) - (let ((testing - (cond - (testp (list :test test)) - (test-notp (list :test-not test-not)))) - (keying - (cond - (keyp (list :key key))))) - (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) - (get-setf-expansion place env) - (assert (= 1 (length store-vars)) () - "Can't pushnew a place with ~D cells." (length store-vars)) - (let ((store-var (first store-vars)) - (item-var (gensym "push-item-"))) - `(let ((,item-var ,item) - ,@(mapcar #'list tmp-vars tmp-var-init-forms)) - (let ((old-value ,getter-form)) - (if (not (member ,item-var old-value , at keying , at testing)) - (let ((,store-var (cons ,item-var old-value))) - ,setter-form) - old-value))))))) - + +(defmacro pushnew (&environment env item place &rest key-test-args) + (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) + (get-setf-expansion place env) + (assert (= 1 (length store-vars)) () + "Can't pushnew a place with ~D cells." (length store-vars)) + (let ((store-var (first store-vars)) + (item-var (gensym "push-item-"))) + `(let ((,item-var ,item) + ,@(mapcar #'list tmp-vars tmp-var-init-forms)) + (let ((,store-var (adjoin ,item-var ,getter-form , at key-test-args))) + ,setter-form))))) + (defmacro remf (&environment env place indicator) (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) (get-setf-expansion place env) From ffjeld at common-lisp.net Sat May 6 21:15:44 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 17:15:44 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506211544.8807849034@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv20274 Modified Files: basic-macros.lisp Log Message: Added mechanism for throwing type-error in 4 bytes of machine code. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2006/04/10 11:51:03 1.66 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2006/05/06 21:15:44 1.67 @@ -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.66 2006/04/10 11:51:03 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.67 2006/05/06 21:15:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -630,7 +630,8 @@ (:testb 7 :cl) (:jnz '(:sub-program () (:movl :ebx :eax) - (:int 61))) + (:xorl :ecx :ecx) + (:int 69))) (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix* :movl :eax (:ebx -1))))) @@ -650,7 +651,8 @@ (:testb 7 :cl) (:jnz '(:sub-program () (:movl :ebx :eax) - (:int 61))) + (:xorl :ecx :ecx) + (:int 69))) (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix* :movl :eax (:ebx 3))))) @@ -659,7 +661,9 @@ (:compile-two-forms (:eax :ebx) ,cons ,object) (:leal (:eax -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 61))) + (:jnz '(:sub-program () + (:xorl :ecx :ecx) + (:int 69))) (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix* :movl :ebx (:eax -1)))) @@ -668,7 +672,9 @@ (:compile-two-forms (:eax :ebx) ,cons ,object) (:leal (:eax -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 61))) + (:jnz '(:sub-program () + (:xorl :ecx :ecx) + (:int 69))) (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix* :movl :ebx (:eax 3)))) From ffjeld at common-lisp.net Sat May 6 21:15:47 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 6 May 2006 17:15:47 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060506211547.1854553010@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv20303 Modified Files: interrupt.lisp Log Message: Added mechanism for throwing type-error in 4 bytes of machine code. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/05 18:39:52 1.51 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/06 21:15:46 1.52 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.51 2006/05/05 18:39:52 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.52 2006/05/06 21:15:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -334,6 +334,10 @@ $eip $eax $ebx $ecx $edx) (dotimes (i 100000) (with-inline-assembly (:returns :nothing) (:nop)))) + (69 (error 'type-error + :datum (dereference $eax) + :expected-type (aref #(cons) + (dereference $ecx :unsigned-byte8)))) (70 (error "Unaligned memref access.")) ((5 55) (let* ((old-bottom (prog1 (%run-time-context-slot nil 'stack-bottom) From ffjeld at common-lisp.net Sun May 7 18:34:30 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 7 May 2006 14:34:30 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060507183430.D542E5C169@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv18080 Modified Files: environment.lisp Log Message: Ignore declarations ftype and optimize. --- /project/movitz/cvsroot/movitz/environment.lisp 2006/05/05 18:37:34 1.16 +++ /project/movitz/cvsroot/movitz/environment.lisp 2006/05/07 18:34:30 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.16 2006/05/05 18:37:34 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.17 2006/05/07 18:34:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -359,6 +359,8 @@ (defun movitz-env-load-declarations (declarations environment context) (loop for (declaration-identifier . data) in declarations do (case declaration-identifier + ((muerte.cl::ftype muerte.cl::optimize) + nil) ; ignore for now (muerte.cl::ignore (dolist (var data) (check-type var symbol) From ffjeld at common-lisp.net Sun May 7 18:47:14 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 7 May 2006 14:47:14 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060507184714.5ED8D6400A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19772 Modified Files: conditions.lisp Log Message: Avoid recursive error if *break-on-signals* is faulty. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/05/06 20:29:08 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/05/07 18:47:14 1.21 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.20 2006/05/06 20:29:08 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.21 2006/05/07 18:47:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -242,17 +242,18 @@ (cpl (class-precedence-list class)) (condition nil) (bos-type *break-on-signals*)) - (when (typecase bos-type - (null nil) - (symbol - (let ((bos-class (find-class bos-type nil))) - (if (not bos-class) - (typep (class-prototype-value class) bos-type) - (member bos-class cpl)))) - (list - (typep (class-prototype-value class) bos-type)) - (t (member bos-type cpl))) - (break "Signalling ~S" datum)) + (let ((*break-on-signals* nil)) ; avoid recursive error if *b-o-s* is faulty. + (when (typecase bos-type + (null nil) + (symbol + (let ((bos-class (find-class bos-type nil))) + (if (not bos-class) + (typep (class-prototype-value class) bos-type) + (member bos-class cpl)))) + (list + (typep (class-prototype-value class) bos-type)) + (t (member bos-type cpl))) + (break "Signalling ~S" datum))) (macrolet ((invoke-handler (handler) `(funcall ,handler (or condition From ffjeld at common-lisp.net Tue May 9 19:56:02 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 9 May 2006 15:56:02 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20060509195602.DDFCBD002@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19943 Modified Files: conditions.lisp Log Message: Avoid recursive error if *break-on-signals* is not a type-specifier. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/05/07 18:47:14 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/05/09 19:56:02 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.21 2006/05/07 18:47:14 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.22 2006/05/09 19:56:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -242,18 +242,19 @@ (cpl (class-precedence-list class)) (condition nil) (bos-type *break-on-signals*)) - (let ((*break-on-signals* nil)) ; avoid recursive error if *b-o-s* is faulty. - (when (typecase bos-type - (null nil) - (symbol - (let ((bos-class (find-class bos-type nil))) - (if (not bos-class) - (typep (class-prototype-value class) bos-type) - (member bos-class cpl)))) - (list - (typep (class-prototype-value class) bos-type)) - (t (member bos-type cpl))) - (break "Signalling ~S" datum))) + (with-simple-restart (continue "Ignore *break-on-signals*.") + (let ((*break-on-signals* nil)) ; avoid recursive error if *b-o-s* is faulty. + (when (typecase bos-type + (null nil) + (symbol + (let ((bos-class (find-class bos-type nil))) + (if (not bos-class) + (typep (class-prototype-value class) bos-type) + (member bos-class cpl)))) + (list + (typep (class-prototype-value class) bos-type)) + (t (member bos-type cpl))) + (break "Signalling ~S" datum)))) (macrolet ((invoke-handler (handler) `(funcall ,handler (or condition From ffjeld at common-lisp.net Mon May 15 19:49:23 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 15 May 2006 15:49:23 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060515194923.363221A001@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7295 Modified Files: procfs-image.lisp Log Message: Move funobj-name to storage-types.lisp. --- /project/movitz/cvsroot/movitz/procfs-image.lisp 2006/04/10 11:46:25 1.25 +++ /project/movitz/cvsroot/movitz/procfs-image.lisp 2006/05/15 19:49:23 1.26 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.25 2006/04/10 11:46:25 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.26 2006/05/15 19:49:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -238,11 +238,6 @@ do (format t "~& => "))) (values)) -(defun funobj-name (x) - (typecase x - (movitz-funobj - (movitz-funobj-name x)))) - (defun stack-frame (image) (do-stack-frame (image-register32 image :ebp) 0)) From ffjeld at common-lisp.net Mon May 15 19:49:25 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 15 May 2006 15:49:25 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060515194925.D8F633106A@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7318 Modified Files: storage-types.lisp Log Message: Move funobj-name to storage-types.lisp. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2006/04/10 11:47:41 1.56 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2006/05/15 19:49:25 1.57 @@ -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.56 2006/04/10 11:47:41 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.57 2006/05/15 19:49:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -820,6 +820,11 @@ :lambda-list lambda-list :name name)) +(defun funobj-name (x) + (typecase x + (movitz-funobj + (movitz-funobj-name x)))) + ;;; (define-binary-class movitz-funobj-standard-gf (movitz-funobj) From ffjeld at common-lisp.net Fri May 26 18:39:48 2006 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 26 May 2006 14:39:48 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20060526183948.39F3250006@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv10563 Modified Files: compiler.lisp Log Message: For funobjs with &key arguments, have the keyword constants be reliably placed in proper sequence at the tail end of the funobj-constants list. This in preparation for improved &key arguments parsing. --- /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/05 18:37:32 1.170 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/26 18:39:48 1.171 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.170 2006/05/05 18:37:32 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.171 2006/05/26 18:39:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -768,13 +768,18 @@ (defun finalize-funobj (funobj) "Calculate funobj's constants, jumpers." - (loop with all-constants-plist = () and all-jumper-sets = () + (loop with all-key-args-constants = nil + with all-constants-plist = () and all-jumper-sets = () for (nil . function-env) in (function-envs funobj) - ;; (borrowed-bindings body-code) in code-specs + ;; (borrowed-bindings body-code) in code-specs as body-code = (extended-code function-env) - as (const-plist jumper-sets) = + as (const-plist jumper-sets key-args-constants) = (multiple-value-list (find-code-constants-and-jumpers body-code)) - do (loop for (constant usage) on const-plist by #'cddr + do (when key-args-constants + (assert (not all-key-args-constants) () + "only one &key parsing allowed per funobj.") + (setf all-key-args-constants key-args-constants)) + (loop for (constant usage) on const-plist by #'cddr do (incf (getf all-constants-plist constant 0) usage)) (loop for (name set) on jumper-sets by #'cddr do (assert (not (getf all-jumper-sets name)) () @@ -783,6 +788,7 @@ finally (multiple-value-bind (const-list num-jumpers jumpers-map) (layout-funobj-vector all-constants-plist + all-key-args-constants all-jumper-sets (length (borrowed-bindings funobj))) (setf (movitz-funobj-num-jumpers funobj) num-jumpers @@ -2704,7 +2710,7 @@ (defun find-code-constants-and-jumpers (code &key include-programs) "Return code's constants (a plist of constants and their usage-counts) and jumper-sets." - (let (jumper-sets constants) + (let (jumper-sets constants key-args-set) (labels ((process-binding (binding) "Some bindings are really references to constants." (typecase binding @@ -2743,6 +2749,8 @@ (assert (not (getf jumper-sets name)) () "Duplicate jumper declaration for ~S." name) (setf (getf jumper-sets name) set))) + (:declare-key-arg-set + (setf key-args-set (cdr instruction))) (t (when (listp instruction) (dolist (binding (find-read-bindings instruction)) (process-binding binding))))) @@ -2750,9 +2758,21 @@ (when sub (process sub)))))) (process code) (map nil #'process include-programs)) - (values constants jumper-sets))) + (if (not key-args-set) + (values constants jumper-sets nil) + (loop with key-args-constants = nil + for (object count) on constants by #'cddr + if (not (member object key-args-set)) + append (list object count) into non-key-constants + else + do (setf key-args-constants + (merge 'list key-args-constants (list (cons object count)) #'< + :key (lambda (x) + (position (car x) key-args-set)))) + finally + (return (values non-key-constants jumper-sets key-args-constants)))))) -(defun layout-funobj-vector (constants jumper-sets num-borrowing-slots) +(defun layout-funobj-vector (constants key-args-constants jumper-sets num-borrowing-slots) (let* ((jumpers (loop with x for set in (cdr jumper-sets) by #'cddr unless (search set x) @@ -2762,11 +2782,12 @@ (values (append jumpers (make-list num-borrowing-slots :initial-element *movitz-nil*) (mapcar (lambda (x) (movitz-read (car x))) - (sort (loop for (constant count) on constants by #'cddr - unless (or (eq constant *movitz-nil*) - (eq constant (image-t-symbol *image*))) - collect (cons constant count)) - #'< :key #'cdr))) + (append (sort (loop for (constant count) on constants by #'cddr + unless (or (eq constant *movitz-nil*) + (eq constant (image-t-symbol *image*))) + collect (cons constant count)) + #'< :key #'cdr) + key-args-constants))) num-jumpers (loop for (name set) on jumper-sets by #'cddr collect (cons name set))))) @@ -2808,6 +2829,8 @@ (t (case (instruction-is i) ((nil) (return nil)) ; a label, most likely + ((:declare-key-arg-set :declare-label-set) + nil) ((:lexical-control-transfer :load-lambda) (return nil)) ; not sure about these. ((:call) @@ -4014,7 +4037,9 @@ (list* (append pf (car sub-instr)) (cdr sub-instr))) (t (list* pf sub-instr)))))))) - (:declare-label-set nil) + ((:declare-label-set + :declare-key-arg-set) + nil) (:local-function-init (destructuring-bind (function-binding) (operands instruction) @@ -4956,63 +4981,72 @@ (t #+ignore (pushnew (movitz-print (movitz-funobj-name funobj)) (aref *xx* (length key-vars))) - (loop with rest-binding = (movitz-binding rest-var env) - for key-var in key-vars - as key-var-name = (decode-keyword-formal key-var) - as binding = (movitz-binding key-var-name env) - as supplied-p-var = (optional-function-argument-supplied-p-var binding) - as supplied-p-binding = (movitz-binding supplied-p-var env) - and keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name)) - and keyword-not-supplied-label = (gensym) - do (assert binding) - if (not (movitz-constantp (optional-function-argument-init-form binding))) - append - `((:init-lexvar ,binding) - (:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx) - (:load-lexical ,rest-binding :ebx) - (:call (:edi ,(global-constant-offset 'keyword-search))) - (:jz ',keyword-not-supplied-label) - (:store-lexical ,binding :eax :type t) - ,@(when supplied-p-var - `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) - (:init-lexvar ,supplied-p-binding - :init-with-register :eax - :init-with-type (eql ,(image-t-symbol *image*))))) - (:jmp ',keyword-ok-label) - ,keyword-not-supplied-label - ,@(when supplied-p-var - `((:store-lexical ,supplied-p-binding :edi :type null))) - ,@(compiler-call #'compile-form - :form (optional-function-argument-init-form binding) - :env env - :funobj funobj - :result-mode binding) - ,keyword-ok-label) - else append - (append (when supplied-p-var - `((:init-lexvar ,supplied-p-binding - :init-with-register :edi - :init-with-type null))) - (compiler-call #'compile-form - :form (list 'muerte.cl:quote - (eval-form (optional-function-argument-init-form binding) - env)) - :env env - :funobj funobj - :result-mode :eax) - `((:load-constant - ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx) - (:load-lexical ,rest-binding :ebx) - (:call (:edi ,(global-constant-offset 'keyword-search)))) - (when supplied-p-var - `((:jz ',keyword-not-supplied-label) - (:movl (:edi ,(global-constant-offset 't-symbol)) :ebx) - (:store-lexical ,supplied-p-binding :ebx - :type (eql ,(image-t-symbol *image*))) - ,keyword-not-supplied-label)) - `((:init-lexvar ,binding - :init-with-register :eax - :init-with-type t))))))) + #+ignore + (when key-vars + (warn "KEY-FUN: ~D" (length key-vars))) + (append + `((:declare-key-arg-set ,@(mapcar (lambda (k) + (movitz-read + (keyword-function-argument-keyword-name + (movitz-binding (decode-keyword-formal k) env)))) + key-vars))) + (loop with rest-binding = (movitz-binding rest-var env) + for key-var in key-vars + as key-var-name = (decode-keyword-formal key-var) + as binding = (movitz-binding key-var-name env) + as supplied-p-var = (optional-function-argument-supplied-p-var binding) + as supplied-p-binding = (movitz-binding supplied-p-var env) + and keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name)) + and keyword-not-supplied-label = (gensym) + do (assert binding) + if (not (movitz-constantp (optional-function-argument-init-form binding))) + append + `((:init-lexvar ,binding) + (:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx) + (:load-lexical ,rest-binding :ebx) + (:call (:edi ,(global-constant-offset 'keyword-search))) + (:jz ',keyword-not-supplied-label) + (:store-lexical ,binding :eax :type t) + ,@(when supplied-p-var + `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) + (:init-lexvar ,supplied-p-binding + :init-with-register :eax + :init-with-type (eql ,(image-t-symbol *image*))))) + (:jmp ',keyword-ok-label) + ,keyword-not-supplied-label + ,@(when supplied-p-var + `((:store-lexical ,supplied-p-binding :edi :type null))) + ,@(compiler-call #'compile-form + :form (optional-function-argument-init-form binding) + :env env + :funobj funobj + :result-mode binding) + ,keyword-ok-label) + else append + (append (when supplied-p-var + `((:init-lexvar ,supplied-p-binding + :init-with-register :edi + :init-with-type null))) + (compiler-call #'compile-form + :form (list 'muerte.cl:quote + (eval-form (optional-function-argument-init-form binding) + env)) + :env env + :funobj funobj + :result-mode :eax) + `((:load-constant + ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx) + (:load-lexical ,rest-binding :ebx) + (:call (:edi ,(global-constant-offset 'keyword-search)))) + (when supplied-p-var + `((:jz ',keyword-not-supplied-label) + (:movl (:edi ,(global-constant-offset 't-symbol)) :ebx) + (:store-lexical ,supplied-p-binding :ebx + :type (eql ,(image-t-symbol *image*))) + ,keyword-not-supplied-label)) + `((:init-lexvar ,binding + :init-with-register :eax + :init-with-type t)))))))) need-normalized-ecx-p))) (defun make-special-funarg-shadowing (env function-body)