movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

02 May '06

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 <frodef(a)acm.org> ;;;; 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)

1 0

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

02 May '06

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)

1 0

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

02 May '06

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))))

1 0

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

30 Apr '06

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

1 0

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

29 Apr '06

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

1 0

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

29 Apr '06

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

1 0

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

28 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29966 Modified Files: conditions.lisp Log Message: Add simple-condition-format-control and simple-condition-format-arguments readers. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/04/07 21:51:53 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/04/28 23:21:59 1.19 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.18 2006/04/07 21:51:53 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.19 2006/04/28 23:21:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,7 +59,11 @@ (condition-format-control condition) (condition-format-arguments condition)))))) -(define-condition simple-condition (condition) ()) +(define-condition simple-condition (condition) + ((format-control + :reader simple-condition-format-control) + (format-arguments + :reader simple-condition-format-arguments))) (define-condition serious-condition () ()) (define-condition error (serious-condition) ()) (define-condition warning () ())

1 0

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

28 Apr '06

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

1 0

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

28 Apr '06

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

1 0

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

28 Apr '06

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

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs