movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5005 Modified Files: arithmetic-macros.lisp Log Message: Rearranged some code to have movitz build cleanly. Date: Wed Aug 24 09:31:34 2005 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.10 movitz/losp/muerte/arithmetic-macros.lisp:1.11 --- movitz/losp/muerte/arithmetic-macros.lisp:1.10 Sat Aug 20 22:23:34 2005 +++ movitz/losp/muerte/arithmetic-macros.lisp Wed Aug 24 09:31:34 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.10 2005/08/20 20:23:34 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.11 2005/08/24 07:31:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,8 @@ (in-package muerte) +;;; + (defmacro number-double-dispatch ((x y) &rest clauses) `(let ((x ,x) (y ,y)) (cond ,@(loop for ((x-type y-type) . then-body) in clauses @@ -499,3 +501,115 @@ (define-compiler-macro %ratio-denominator (x) `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'denominator))) +;;; + +(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name) + `(progn + ,(when condition + `(define-compiler-macro ,2op-name (n1 n2 &environment env) + (cond + ((and (movitz:movitz-constantp n1 env) + (movitz:movitz-constantp n2 env)) + (list ',2op-name (movitz:movitz-eval n1 env) (movitz:movitz-eval n2 env))) + ((movitz:movitz-constantp n1 env) + (let ((n1 (movitz::movitz-eval n1 env))) + (check-type n1 number) + (if (typep n1 '(signed-byte 30)) + `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-fixnum-real)) + `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-two-reals))))) + ((movitz:movitz-constantp n2 env) + (let ((n2 (movitz:movitz-eval n2 env))) + (check-type n2 number) + (if (typep n2 '(signed-byte 30)) + `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-real-fixnum)) + `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-two-reals))))) + (t `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-two-reals)))))) + + (defun ,2op-name (n1 n2) + (,2op-name n1 n2)) + + (define-compiler-macro ,name (&whole form number &rest more-numbers) + (case (length more-numbers) + (0 `(progn ,number t)) + (1 `(,',2op-name ,number ,(first more-numbers))) + ,@(when 3op-name + `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers))))) + (t #+ignore (when (= 2 (length more-numbers)) + (warn "3op: ~S" form)) + `(and (,',2op-name ,number ,(first more-numbers)) + (,',name ,@more-numbers))))) + + ,(when defun-p + `(defun ,name (number &rest more-numbers) + (declare (dynamic-extent more-numbers)) + (cond + ((null more-numbers) + (check-type number fixnum) + t) + ((not (cdr more-numbers)) + (,2op-name number (first more-numbers))) + (t (and (,2op-name number (first more-numbers)) + (do ((p more-numbers (cdr p))) + ((not (cdr p)) t) + (unless (,2op-name (car p) (cadr p)) + (return nil)))))))))) + +(define-number-relational >= >=%2op :boolean-greater-equal) +(define-number-relational > >%2op :boolean-greater) +(define-number-relational < <%2op :boolean-less) +(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op) + +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + ;; The funcall is a hack not to invoke compiler machinery + ;; that depends on the unsigned-byte type being defined. + (list 'integer 0 (funcall '- (ash 1 size) 1))) + (t (error "Illegal size for unsigned-byte.")))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(define-typep rational (x &optional (lower-limit '*) (upper-limit '*)) + (and (typep x 'rational) + (or (eq lower-limit '*) + (<= lower-limit x)) + (or (eq upper-limit '*) + (<= x upper-limit)))) + +(deftype real (&optional (lower-limit '*) (upper-limit '*)) + `(or (integer ,lower-limit ,upper-limit) + (rational ,lower-limit ,upper-limit))) + + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + +(deftype index (&optional (step 1)) + `(integer 0 ,(- #x1fffffff step)))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4621 Modified Files: compiler.lisp Log Message: Working on add and type inference. Date: Wed Aug 24 09:30:46 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.156 movitz/compiler.lisp:1.157 --- movitz/compiler.lisp:1.156 Tue Aug 23 23:42:07 2005 +++ movitz/compiler.lisp Wed Aug 24 09:30:45 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.156 2005/08/23 21:42:07 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.157 2005/08/24 07:30:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -7023,26 +7023,75 @@ (binding-lended-p (binding-target term1))))) (t (warn "Unknown fixnum add: ~S" instruction) (make-default-add)))) - #+ignore ((and (movitz-subtypep result-type '(unsigned-byte 32)) (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum)) - (cond - ((and (not (binding-lended-p (binding-target term0))) - (not (binding-lended-p (binding-target term1))) - (not (and (bindingp destination) - (binding-lended-p (binding-target destination))))) + (flet ((mkadd (src srcloc destreg) + (if (integerp srcloc) + `((:addl (:ebp ,(stack-frame-offset srcloc)) + ,destreg)) + (ecase (operator srcloc) + ((:eax :ebx :ecx :edx) + `((:addl ,srcloc ,destreg))) + ((:argument-stack) + `((:addl (:ebx ,(argument-stack-offset src)) + ,destreg))) + )))) (cond ((and (not constant0) (not constant1) - (member destination-location '(:eax :ebx :edx))) - (print-code instruction - (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map) - `((,*compiler-local-segment-prefix* - :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0)))) - ))) - (t (make-default-add)))) - (t (make-default-add)))) + (not (binding-lended-p (binding-target term0))) + (not (binding-lended-p (binding-target term1))) + (not (and (bindingp destination) + (binding-lended-p (binding-target destination))))) + (cond +;;; ((and (not (eq loc0 :untagged-fixnum-ecx)) +;;; (not (eq loc1 :untagged-fixnum-ecx)) +;;; (not (eq destination-location :untagged-fixnum-ecx))) +;;; (let ((tmpreg (cond +;;; ((member destination-location '(:eax :ebx :ecx :edx)) +;;; destination-location) +;;; ((some (lambda (x) (and (not (eq x loc0)) (not (eq x loc1)))) +;;; '(:ecx :edx :eax :ebx))) +;;; (t :ecx))) +;;; (no-overflow (gensym "no-overflow-"))) +;;; (append (make-load-lexical term0 :eax funobj nil frame-map) +;;; (mkadd term1 loc1 :eax) +;;; `((:jnc ',no-overflow) +;;; (:movl :eax :ecx) +;;; (:rcrl 1 :ecx) +;;; (:shrl 1 :ecx) +;;; (,*compiler-local-segment-prefix* +;;; :call (:edi ,(global-constant-offset 'box-u32-ecx))) +;;; ,no-overflow)) + (t (make-default-add) + #+ignore + (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map) + `((,*compiler-local-segment-prefix* + :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0)))) + (make-load-lexical term1 :untagged-fixnum-ecx funobj nil frame-map) + `((,*compiler-local-segment-prefix* + :addl (:edi ,(global-constant-offset 'raw-scratch0)) :ecx)) + (if (integerp destination-location) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))) + (:movl :eax (:ebp ,(stack-frame-offset destination-location)))) + (ecase (operator destination-location) + ((:untagged-fixnum-ecx) + nil) + ((:eax) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))))) + ((:ebx :ecx :edx) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))) + (:movl :eax ,destination-location))) + ((:argument-stack) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))) + (:movl :eax (:ebp ,(argument-stack-offset + (binding-target destination)))))))))))) + (t (make-default-add))))) (t (make-default-add))))))))) ;;;;;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4368 Modified Files: memref.lisp Log Message: Added (require typep) so we can do some type-inferring. Date: Wed Aug 24 09:30:14 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.47 movitz/losp/muerte/memref.lisp:1.48 --- movitz/losp/muerte/memref.lisp:1.47 Tue May 24 08:33:35 2005 +++ movitz/losp/muerte/memref.lisp Wed Aug 24 09:30:14 2005 @@ -10,10 +10,11 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.47 2005/05/24 06:33:35 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.48 2005/08/24 07:30:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ +(require :muerte/typep) (provide :muerte/memref) (in-package muerte)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4168 Modified Files: packages.lisp Log Message: Added some (declare index) to hash-table-iter-vars. Date: Wed Aug 24 09:29:41 2005 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.10 movitz/losp/muerte/packages.lisp:1.11 --- movitz/losp/muerte/packages.lisp:1.10 Mon May 30 00:03:06 2005 +++ movitz/losp/muerte/packages.lisp Wed Aug 24 09:29:40 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.10 2005/05/29 22:03:06 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.11 2005/08/24 07:29:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -143,7 +143,8 @@ (setf ,package-hash-var internals) (go ,loop-tag)))))))))) -(defmacro do-external-symbols ((var &optional (package *package*) result-form) &body declarations-and-body) +(defmacro do-external-symbols + ((var &optional (package *package*) result-form) &body declarations-and-body) (let ((next-var (gensym)) (more-var (gensym)) (key-var (gensym))) @@ -170,6 +171,7 @@ (t (let ((x (pop ,use-list-var))) (and x (package-object-external-symbols x))))))) ((not ,hash-table-var) ,result-form) + (declare (index ,state-var)) (with-hash-table-iterator (,next-var ,hash-table-var) (do () (nil) (multiple-value-bind (,more-var ,key-var ,var) (,next-var) @@ -177,7 +179,6 @@ (if ,more-var (let () ,@declarations-and-body) (return)))))))) - (defun apropos (string &optional package) (flet ((apropos-symbol (symbol string)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4141 Modified Files: sequences.lisp Log Message: Fixed typo decare -> declare. Date: Wed Aug 24 09:29:00 2005 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.26 movitz/losp/muerte/sequences.lisp:1.27 --- movitz/losp/muerte/sequences.lisp:1.26 Tue Aug 23 19:58:19 2005 +++ movitz/losp/muerte/sequences.lisp Wed Aug 24 09:28:59 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.26 2005/08/23 17:58:19 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.27 2005/08/24 07:28:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -813,12 +813,12 @@ (do ((i start1 (1+ i)) (j start2 (1+ j))) ((>= i end1) sequence-1) - (decare (index i j)) + (declare (index i j)) (setf (sequence-1-ref i) (sequence-2-ref j)))) (t (do ((i start1 (1+ i)) (j start2 (1+ j))) ((>= j end2) sequence-1) - (decare (index i j)) + (declare (index i j)) (setf (sequence-1-ref i) (sequence-2-ref j)))))))) (list (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4084 Modified Files: environment.lisp Log Message: Print CPU cycles with ~:D. Date: Wed Aug 24 09:28:21 2005 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.12 movitz/losp/muerte/environment.lisp:1.13 --- movitz/losp/muerte/environment.lisp:1.12 Wed Apr 20 08:53:20 2005 +++ movitz/losp/muerte/environment.lisp Wed Aug 24 09:28:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.12 2005/04/20 06:53:20 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.13 2005/08/24 07:28:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -140,7 +140,7 @@ (clumps (and start-mem (- (malloc-cons-pointer) start-mem))) (delta-time (+ (ash (- end-time-hi start-time-hi) 29) (- end-time-lo start-time-lo skew)))) - (format t "~&;; CPU cycles: ~D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" + (format t "~&;; CPU cycles: ~:D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" delta-time clumps clumps)))) (defmacro time (form)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4053 Modified Files: arrays.lisp Log Message: Fixed fill-pointer declaration for vector-push. Date: Wed Aug 24 09:27:48 2005 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.55 movitz/losp/muerte/arrays.lisp:1.56 --- movitz/losp/muerte/arrays.lisp:1.55 Sat Aug 20 22:24:11 2005 +++ movitz/losp/muerte/arrays.lisp Wed Aug 24 09:27:47 2005 @@ -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.55 2005/08/20 20:24:11 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.56 2005/08/24 07:27:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1010,7 +1010,7 @@ (defun vector-push (new-element vector) (check-type vector vector) (let ((p (fill-pointer vector))) - (declare (type (unsigned-byte 16) p)) + (declare (index p)) (when (< p (array-dimension vector 0)) (setf (aref vector p) new-element (fill-pointer vector) (1+ p))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp
by ffjeld＠common-lisp.net 24 Aug '05

24 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4000 Modified Files: hash-tables.lisp Log Message: Added index declarations. Date: Wed Aug 24 09:19:37 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.9 movitz/losp/muerte/hash-tables.lisp:1.10 --- movitz/losp/muerte/hash-tables.lisp:1.9 Sun Aug 21 19:56:40 2005 +++ movitz/losp/muerte/hash-tables.lisp Wed Aug 24 09:19:37 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.9 2005/08/21 17:56:40 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.10 2005/08/24 07:19:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,17 +51,19 @@ (defun hash-table-iterator (bucket index) (when index - (do ((length (array-dimension bucket 0))) - ((>= index length) nil) - (unless (eq (svref%unsafe bucket index) '--no-hash-key--) - (return (+ index 2))) - (incf index 2)))) + (let ((index (check-the (index 2) index))) + (do ((length (array-dimension bucket 0))) + ((>= index length) nil) + (unless (eq (svref%unsafe bucket index) '--no-hash-key--) + (return (+ index 2))) + (incf index 2))))) (defmacro with-hash-table-iterator ((name hash-table) &body declarations-and-body) (let ((bucket-var (gensym "bucket-var-")) (bucket-index-var (gensym "bucket-index-var-"))) `(let* ((,bucket-var (hash-table-bucket ,hash-table)) (,bucket-index-var 0)) + (declare (type (index 2) ,bucket-index-var)) (macrolet ((,name () `(when (setq ,',bucket-index-var (hash-table-iterator ,',bucket-var ,',bucket-index-var)) @@ -138,6 +140,7 @@ (bucket-length (array-dimension bucket 0)) (start-i2 (rem (ash (sxhash-eq key0) 1) bucket-length)) (i2 start-i2)) + (declare ((index 2) i2)) (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond @@ -156,6 +159,7 @@ (start-i2 (rem (ash (logxor (sxhash-eq key0) (sxhash-eq key1)) 1) bucket-length)) (i2 start-i2)) + (declare ((index 2) i2)) (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond @@ -174,6 +178,7 @@ (bucket-length (length bucket)) (index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length))) (nil) + (declare ((index 2) index2)) (let ((k (svref%unsafe bucket index2))) (cond ((eq k '--no-hash-key--)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 23 Aug '05

23 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29692 Modified Files: compiler.lisp Log Message: Fixed a bug in analyze-bindings where declared types where not taken into account in certain situations, preventing proper type inference. Date: Tue Aug 23 23:42:08 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.155 movitz/compiler.lisp:1.156 --- movitz/compiler.lisp:1.155 Tue Aug 23 01:05:35 2005 +++ movitz/compiler.lisp Tue Aug 23 23:42:07 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.155 2005/08/22 23:05:35 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.156 2005/08/23 21:42:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -455,11 +455,18 @@ (binding-store-type binding))) ((typep binding 'function-argument) t) + ((let ((analysis (gethash binding binding-usage))) + (assert (and (and analysis + (null (type-analysis-thunks analysis)))) + (binding) + "Can't resolve unresolved binding ~S." binding))) + (*compiler-trust-user-type-declarations-p* + (let ((analysis (gethash binding binding-usage))) + (multiple-value-call #'encoded-type-decode + (apply #'encoded-types-and + (append (type-analysis-declared-encoded-type analysis) + (type-analysis-encoded-type analysis)))))) (t (let ((analysis (gethash binding binding-usage))) - (assert (and (and analysis - (null (type-analysis-thunks analysis)))) - (binding) - "Can't resolve unresolved binding ~S." binding) (apply #'encoded-type-decode (type-analysis-encoded-type analysis)))))) (type-is-t (type-specifier) @@ -523,8 +530,22 @@ if (not (every #'binding-resolved-p thunk-args)) collect (cons thunk thunk-args) else - do (setf (type-analysis-encoded-type analysis) - (multiple-value-list + do #+ignore + (warn "because ~S=>~S->~S completing ~S: ~S and ~S" + thunk thunk-args + (mapcar #'binding-resolve thunk-args) + binding + (type-analysis-declared-encoded-type analysis) + (multiple-value-list + (multiple-value-call + #'encoded-types-or + (values-list + (type-analysis-encoded-type analysis)) + (type-specifier-encode + (apply thunk (mapcar #'binding-resolve + thunk-args)))))) + (setf (type-analysis-encoded-type analysis) + (multiple-value-list (multiple-value-call #'encoded-types-and (values-list @@ -5564,6 +5585,8 @@ #+ignore (when (and (eq result-mode :function) (eq operator (movitz-print (movitz-funobj-name funobj)))) (warn "Tail-recursive call detected.")) + (when (eq operator 'muerte.cl::declare) + (break "Compiling funcall to ~S" 'muerte.cl::declare)) (pushnew (cons operator muerte.cl::*compile-file-pathname*) (image-called-functions *image*) :key #'first) @@ -6406,6 +6429,10 @@ (values binding init-with-type) ) ((and init-with-type (not (bindingp init-with-type))) (values binding init-with-type)) + ((and init-with-type + (bindingp init-with-type) + (binding-store-type init-with-type)) + (apply #'encoded-type-decode (binding-store-type init-with-type))) (t (values binding t (lambda (x) x) (list init-with-register)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by ffjeld＠common-lisp.net 23 Aug '05

23 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14835 Modified Files: sequences.lisp Log Message: Fixed typo: delcare -> declare. Date: Tue Aug 23 19:58:19 2005 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.25 movitz/losp/muerte/sequences.lisp:1.26 --- movitz/losp/muerte/sequences.lisp:1.25 Tue Aug 23 18:09:02 2005 +++ movitz/losp/muerte/sequences.lisp Tue Aug 23 19:58:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.25 2005/08/23 16:09:02 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.26 2005/08/23 17:58:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -797,7 +797,7 @@ (q (nthcdr (- length start2 size) reverse-list) (cdr q)) (i 0 (1+ i))) ((>= i size) (nreverse reverse-list)) - (delcare (index i)) + (declare (index i)) (setf (car p) (car q)))))))) ;; (not (eq sequence-1 sequence-2)) .. (t (sequence-dispatch sequence-1

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