movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: movitz/losp/muerte/read.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1376 Modified Files: read.lisp Log Message: Added bit-vector #* read syntax. Date: Thu Jul 8 06:38:16 2004 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.4 movitz/losp/muerte/read.lisp:1.5 --- movitz/losp/muerte/read.lisp:1.4 Fri Apr 23 08:01:56 2004 +++ movitz/losp/muerte/read.lisp Thu Jul 8 06:38:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.4 2004/04/23 15:01:56 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.5 2004/07/08 13:38:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -266,6 +266,18 @@ (values (make-array (length contents-list) :initial-contents contents-list) form-end + string end))) + (#\* (let* ((token-end (find-token-end string :start (incf i) :end end)) + (bit-vector (make-array (- token-end i) :element-type 'bit))) + (do ((p i (1+ p)) + (q 0 (1+ q))) + ((>= p token-end)) + (case (schar string p) + (#\0 (setf (aref bit-vector q) 0)) + (#\1 (setf (aref bit-vector q) 1)) + (t (error "Illegal bit-vector element: ~S" (schar string p))))) + (values bit-vector + token-end string end))) (#\s (multiple-value-bind (struct-form form-end) (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26461 Modified Files: storage-types.lisp Log Message: Removed some dead code. Date: Thu Jul 8 05:01:52 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.25 movitz/storage-types.lisp:1.26 --- movitz/storage-types.lisp:1.25 Wed Jul 7 10:37:06 2004 +++ movitz/storage-types.lisp Thu Jul 8 05:01:51 2004 @@ -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.25 2004/07/07 17:37:06 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.26 2004/07/08 12:01:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -830,13 +830,6 @@ "Unable to resolve jumper ~S." data) (write-binary 'u32 stream (+ x (movitz-intern-code-vector (movitz-funobj-code-vector obj))))))))) - -;;;(defmethod print-object ((obj movitz-funobj) stream) -;;; (format stream "#<MOVITZ-FUNOBJ ~<ll: ~A~> ~<const: ~A~> ~<code: ~A~>>" -;;; (movitz-funobj-lambda-list obj) -;;; (movitz-funobj-const-list obj) -;;; (movitz-funobj-code-vector obj)) -;;; (call-next-method)) (defmethod print-object ((object movitz-funobj) stream) (if (not (slot-boundp object 'name))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26915 Modified Files: typep.lisp Log Message: Cleaning up some minor stuff after the migration to the new vectors. Also, inform typep that basic-vector corresponds to simple-arrays. Date: Thu Jul 8 04:30:41 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.21 movitz/losp/muerte/typep.lisp:1.22 --- movitz/losp/muerte/typep.lisp:1.21 Wed Jul 7 10:37:34 2004 +++ movitz/losp/muerte/typep.lisp Thu Jul 8 04:30:41 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.21 2004/07/07 17:37:34 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.22 2004/07/08 11:30:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -234,12 +234,13 @@ ((function compiled-function) (make-other-typep :funobj)) ((basic-vector) + (break "Basic-vector typep?") + (make-other-typep :basic-vector)) + ((vector simple-array array) (make-other-typep :basic-vector)) - ((vector array) - `(typep ,object 'basic-vector)) (simple-vector (make-basic-vector-typep :any-t)) - (string + ((string simple-string) (make-basic-vector-typep :character)) (vector-u8 (make-basic-vector-typep :u8)) @@ -262,6 +263,12 @@ (if deriver-function `(typep ,object ',(apply deriver-function (cdr type))) (case (car type) + ((simple-array) + (let ((et (cadr type))) + (cond + ((movitz:movitz-subtypep et '(unsigned-byte 8)) + (make-basic-vector-typep :u8)) + (t (make-basic-vector-typep :any-t))))) ((integer) (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) (cdr type) @@ -383,7 +390,7 @@ #+ignore (defun foo (x) - (typep x '(cons * symbol))) + (typep x '(simple-array (unsigned-byte 4)))) (defmacro define-typep (tname lambda &body body) (let ((fname (format nil "~A-~A" 'typep tname)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26445 Modified Files: sequences.lisp Log Message: Cleaning up some minor stuff after the migration to the new vectors. Also, inform typep that basic-vector corresponds to simple-arrays. Date: Thu Jul 8 04:30:36 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.13 movitz/losp/muerte/sequences.lisp:1.14 --- movitz/losp/muerte/sequences.lisp:1.13 Wed Jul 7 10:37:38 2004 +++ movitz/losp/muerte/sequences.lisp Thu Jul 8 04:30:36 2004 @@ -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.13 2004/07/07 17:37:38 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.14 2004/07/08 11:30:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,7 +55,7 @@ (defun length (sequence) (etypecase sequence - (basic-vector + (simple-array (macrolet ((do-it () `(with-inline-assembly (:returns :eax)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25492 Modified Files: primitive-functions.lisp Log Message: Cleaning up some minor stuff after the migration to the new vectors. Also, inform typep that basic-vector corresponds to simple-arrays. Date: Thu Jul 8 04:30:27 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.24 movitz/losp/muerte/primitive-functions.lisp:1.25 --- movitz/losp/muerte/primitive-functions.lisp:1.24 Thu Jun 17 02:49:23 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jul 8 04:30:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.24 2004/06/17 09:49:23 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.25 2004/07/08 11:30:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -658,8 +658,6 @@ (movitz-accessor object movitz-funobj-standard-gf standard-gf-class)) (string (find-class 'string)) - (basic-vector - (find-class 'vector)) (vector (find-class 'vector)) (function

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22240 Modified Files: integers.lisp Log Message: Cleaning up some minor stuff after the migration to the new vectors. Also, inform typep that basic-vector corresponds to simple-arrays. Date: Thu Jul 8 04:30:20 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.38 movitz/losp/muerte/integers.lisp:1.39 --- movitz/losp/muerte/integers.lisp:1.38 Fri Jun 11 16:26:38 2004 +++ movitz/losp/muerte/integers.lisp Thu Jul 8 04:30:20 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.38 2004/06/11 23:26:38 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.39 2004/07/08 11:30:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1213,8 +1213,7 @@ 'retry-jumper) (:edi (:edi-offset atomically-status)))) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) - :eax) ; Number of words + (:leal ((:ecx 4) 4) :eax) ; Number of words (:call-global-constant get-cons-pointer) ; New bignum into EAX @@ -1548,6 +1547,50 @@ (numargs-case (1 (x) x) (2 (x y) + (number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) x y) + (:xorl :ebx :eax))) + ((positive-fixnum positive-bignum) + (macrolet + ((do-it () + `(let ((r (copy-bignum y))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) y x) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx))))) + (do-it))) + ((positive-bignum positive-fixnum) + (macrolet + ((do-it () + `(let ((r (copy-bignum x))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) r y) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))) + (do-it))) + ((positive-bignum positive-bignum) + (if (< (%bignum-bigits x) (%bignum-bigits y)) + (logior y x) + (let ((r (copy-bignum x))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) r y) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* -1 movitz:+movitz-fixnum-factor+)) + :edx) ; EDX is loop counter + or-loop + (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:orl :ecx + (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:subl 4 :edx) + (:jnc 'or-loop)))) + (do-it)))))) (number-double-dispatch (x y) (((eql 0) t) y) ((t (eql 0)) x)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19746 Modified Files: arrays.lisp Log Message: Cleaning up some minor stuff after the migration to the new vectors. Also, inform typep that basic-vector corresponds to simple-arrays. Date: Thu Jul 8 04:30:14 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.30 movitz/losp/muerte/arrays.lisp:1.31 --- movitz/losp/muerte/arrays.lisp:1.30 Wed Jul 7 10:37:15 2004 +++ movitz/losp/muerte/arrays.lisp Thu Jul 8 04:30:14 2004 @@ -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.30 2004/07/07 17:37:15 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.31 2004/07/08 11:30:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,34 +68,16 @@ (#.(bt:enum-value 'movitz::movitz-vector-element-type :code) 'code))) -;;;(defmacro vector-dimension (vector) -;;; `(movitz-accessor-u16 ,vector movitz-vector num-elements)) - (defun array-dimension (array axis-number) (etypecase array - (basic-vector - (assert (zerop axis-number)) - (movitz-accessor array movitz-basic-vector num-elements)) - #+ignore - (vector + (simple-array (assert (zerop axis-number)) - (vector-dimension array)))) + (movitz-accessor array movitz-basic-vector num-elements)))) (defun shrink-vector (vector new-size) (set-movitz-accessor-u16 vector movitz-vector num-elements new-size) vector) - -;;;(define-compiler-macro vector-fill-pointer (vector) -;;; `(movitz-accessor-u16 ,vector movitz-vector fill-pointer) -;;; #+ignore `(with-inline-assembly (:returns :untagged-fixnum-ecx) -;;; (:compile-form (:result-mode :eax) ,vector) -;;; (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer)) -;;; :ecx))) -;;; -;;;(defun vector-fill-pointer (vector) -;;; (vector-fill-pointer vector)) - (define-compiler-macro %basic-vector-has-fill-pointer-p (vector) "Does the basic-vector have a fill-pointer?" `(with-inline-assembly (:returns :boolean-zf=1) @@ -114,14 +96,13 @@ (defun array-has-fill-pointer-p (array) (etypecase array - (basic-vector + (simple-array (%basic-vector-has-fill-pointer-p array)) - (vector t) (array nil))) (defun fill-pointer (vector) (etypecase vector - (basic-vector + (simple-array (assert (%basic-vector-has-fill-pointer-p vector) (vector) "Vector has no fill-pointer.") (%basic-vector-fill-pointer vector)))) @@ -129,7 +110,7 @@ (defun (setf fill-pointer) (new-fill-pointer vector) (etypecase vector - (basic-vector + (simple-array (macrolet ((do-it () `(with-inline-assembly (:returns :eax) @@ -147,13 +128,7 @@ (:compile-form (:result-mode :ignore) (error "Illegal fill-pointer: ~W." new-fill-pointer)))) (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer)))))) - (do-it))) - #+ignore - (vector - (assert (<= new-fill-pointer (vector-dimension vector))) - (setf (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0 - :unsigned-byte16) - new-fill-pointer)))) + (do-it))))) (defun vector-aref%unsafe (vector index) "No type-checking of <vector> or <index>." @@ -225,7 +200,7 @@ (numargs-case (2 (array index) (etypecase array - (basic-vector + (simple-array (macrolet ((do-it () `(with-inline-assembly (:returns :eax) @@ -289,7 +264,7 @@ (numargs-case (3 (value vector index) (etypecase vector - (basic-vector + (simple-array (macrolet ((do-it () `(with-inline-assembly (:returns :eax) @@ -378,7 +353,7 @@ (defun svref (simple-vector index) (etypecase simple-vector - (basic-vector + (simple-vector (macrolet ((do-it () `(with-inline-assembly (:returns :eax) @@ -403,7 +378,7 @@ (defun (setf svref) (value simple-vector index) (etypecase simple-vector - (basic-vector + (simple-vector (macrolet ((do-it () `(with-inline-assembly (:returns :eax) @@ -662,26 +637,7 @@ (make-basic-vector%u32 dimensions fill-pointer initial-element initial-contents)) ((eq element-type 'code) (make-basic-vector%code dimensions fill-pointer initial-element initial-contents)) - (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents) - #+ignore - (let ((array (malloc-words dimensions))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:basic-vector-type-tag :any-t)) - (setf (fill-pointer array) - (case fill-pointer - ((nil t) dimensions) - (t fill-pointer))) - (cond - (initial-contents - (replace array initial-contents)) - (initial-element - (dotimes (i dimensions) - (setf (svref%unsafe array i) initial-element)))) - array)))))) + (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents)))))) (defun vector (&rest objects) "=> vector"

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9109 Modified Files: packages.lisp Log Message: Added movitz-subtypep. Date: Thu Jul 8 04:28:34 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.27 movitz/packages.lisp:1.28 --- movitz/packages.lisp:1.27 Thu Jun 17 02:49:03 2004 +++ movitz/packages.lisp Thu Jul 8 04:28:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.27 2004/06/17 09:49:03 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.28 2004/07/08 11:28:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1299,6 +1299,7 @@ #:*default-image-init-file* #:movitz-constantp #:movitz-eval + #:movitz-subtypep #:movitz-compile-file

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6843 Modified Files: compiler-types.lisp Log Message: Improved handling of integer types. Date: Thu Jul 8 04:27:19 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.15 movitz/compiler-types.lisp:1.16 --- movitz/compiler-types.lisp:1.15 Tue Jun 29 16:17:22 2004 +++ movitz/compiler-types.lisp Thu Jul 8 04:27:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.15 2004/06/29 23:17:22 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.16 2004/07/08 11:27:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,7 +60,7 @@ (multiple-value-call #'encoded-type-singleton (type-specifier-encode type-specifier))) -;;; +;;; A numscope is a subset of the integers. (defun make-numscope (&optional minimum maximum) (check-type minimum (or number null)) @@ -195,6 +195,14 @@ epsilon) epsilon))) +(defun numscope-equalp (range0 range1) + ;; Numscopes should always be kept on canonical form. + (equal range0 range1)) + +(defun numscope-subsetp (range0 range1) + "Is range0 included in range1?" + (numscope-equalp range1 (numscope-union range0 range1))) + (defun numscope-allp (range) "Does this numscope include every number?" (let ((x (car range))) @@ -205,7 +213,7 @@ ;;; (defparameter *tb-bitmap* - '(hash-table character function cons keyword symbol vector array integer :tail) + '(hash-table character function cons keyword symbol vector array :tail) "The union of these types must be t.") (defun basic-typep (x type) @@ -243,11 +251,37 @@ (case x (symbol (logior code (code 'keyword))) (array (logior code (code 'vector))) - ;; (number (logior code (code 'integer))) (t code))))))) (reduce #'logior (mapcar #'code types) :initial-value (code first-type))))) +(defun type-values (codes &key integer-range members include complement) + ;; Members: A list of objects explicitly included in type. + ;; Include: A list of (non-encodable) type-specs included in type. + (check-type include list) + (check-type members list) + (check-type integer-range list) + (let ((new-intscope integer-range) + (new-members ())) + (dolist (member members) ; move integer members into integer-range + (let ((member (movitz-read member))) + (etypecase member + (movitz-fixnum + (setf new-intscope + (numscope-union new-intscope + (make-numscope (movitz-fixnum-value member) + (movitz-fixnum-value member))))) + (movitz-object + (pushnew member new-members :test #'movitz-eql))))) + (let ((new-code (if (atom codes) + (type-code codes) + (apply #'type-code codes)))) + (values new-code + new-intscope + new-members + include + complement)))) + (defun encoded-type-decode (code integer-range members include complement) (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*))))) (= mask (logand mask code))) @@ -277,38 +311,6 @@ (t (if (not complement) (cons 'or sub-specs) (list 'not (cons 'or sub-specs)))))))) - -(defun type-values (codes &key integer-range members include complement) - ;; Members: A list of objects explicitly included in type. - ;; Include: A list of (non-encodable) type-specs included in type. - (check-type include list) - (check-type members list) - (check-type integer-range list) - (let ((new-intscope integer-range) - (new-members ())) - (dolist (member members) ; move integer members into integer-range - (let ((member (movitz-read member))) - (etypecase member - (movitz-fixnum - (setf new-intscope - (numscope-union new-intscope - (make-numscope (movitz-fixnum-value member) - (movitz-fixnum-value member))))) - (movitz-object - (pushnew member new-members :test #'movitz-eql))))) - (let ((new-code (logior (if (atom codes) - (type-code codes) - (apply #'type-code codes)) - (if (numscope-allp new-intscope) - (type-code 'integer) - 0)))) - (values new-code - (if (type-code-p 'integer new-code) - (make-numscope nil nil) - new-intscope) - new-members - include - complement)))) (defun star-is-t (x) (if (eq x '*) t x)) @@ -326,13 +328,9 @@ ((typep x 'movitz-nil) (type-code-p 'symbol code)) ((basic-typep x 'fixnum) - (or (type-code-p 'integer code) - (and integer-range - (numscope-memberp integer-range (movitz-fixnum-value x))))) + (numscope-memberp integer-range (movitz-fixnum-value x))) ((basic-typep x 'bignum) - (or (type-code-p 'integer code) - (and integer-range - (numscope-memberp integer-range (movitz-bignum-value x))))) + (numscope-memberp integer-range (movitz-bignum-value x))) (t (dolist (bt '(symbol character function cons hash-table vector) (error "Cant decide typep for ~S." x)) (when (basic-typep x bt) @@ -411,13 +409,9 @@ (values code0 integer-range0 members0 include0 complement0)) ((and (not complement0) (not complement1)) (let* ((new-inumscope (numscope-union integer-range0 integer-range1)) - (new-code (logior code0 code1 (if (numscope-allp new-inumscope) - (type-code 'integer) - 0)))) + (new-code (logior code0 code1))) (values new-code - (if (type-code-p 'integer new-code) - nil - new-inumscope) + new-inumscope (remove-if (lambda (x) (or (encoded-typep nil t x code0 integer-range0 nil include0 nil) (encoded-typep nil t x code1 integer-range1 nil include1 nil))) @@ -447,8 +441,10 @@ (bignum (type-specifier-encode `(or (integer * ,(1- +movitz-most-negative-fixnum+)) (integer ,(1+ +movitz-most-positive-fixnum+) *)))) - ((t nil cons symbol keyword function array vector integer hash-table character) + ((t nil cons symbol keyword function array vector hash-table character) (type-values type-specifier)) + ((integer) + (type-values () :integer-range (make-numscope))) (null (type-values () :members '(nil))) (list @@ -574,7 +570,11 @@ ((null include) (values nil t)) (t (values nil nil)))) - + +(defun encoded-integerp (code integer-range members include complement) + "Is the encoded-type a subset/subtype of integer?" + (declare (ignore integer-range)) + (and (= 0 code) (null members) (null include) (not complement))) (defun encoded-subtypep (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1) @@ -599,14 +599,18 @@ (and (not all1) confident))) ;; type0 is t, and type1 isn't. (result-is nil t)) + ((and (encoded-integerp code0 integer-range0 members0 include0 complement0) + (not complement1) + (numscope-subsetp integer-range0 integer-range1)) + ;; type0 is an integer type which is included in type1. + (result-is t t)) ((and (not complement0) (not complement1)) (dolist (st *tb-bitmap*) (when (type-code-p st code0) (unless (type-code-p st code1) (result-is nil t)))) - (when integer-range0 - (unless (type-code-p 'integer code1) - (result-is nil nil))) + (unless (numscope-subsetp integer-range0 integer-range1) + (result-is nil t)) (dolist (m members0) (ecase (encoded-typep nil :unknown m code1 integer-range1 members1 include1 nil) ((nil)

1 0

[movitz-cvs] CVS update: movitz/doc/ChangeLog
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv14336 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jul 7 17:16:36 2004 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.4 movitz/doc/ChangeLog:1.5 --- movitz/doc/ChangeLog:1.4 Sun Apr 18 05:33:10 2004 +++ movitz/doc/ChangeLog Wed Jul 7 17:16:36 2004 @@ -1,3 +1,10 @@ +2004-07-08 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Migration to the new basic-vector data-structure is completed + (though not thoroughly debugged). The los0-gc.lisp example GC is + updated to reflect this, and now supports any newspace-size upto + 2GB. + 2004-04-18 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * The bootloader no longer initializes the VGA subssystem, since

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