[movitz-cvs] CVS update: movitz/compiler-types.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sat Feb 14 22:11:36 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv27008
Modified Files:
compiler-types.lisp
Log Message:
Added encoded-type-singleton, and small changes to encoded-subtypep.
Date: Sat Feb 14 17:11:36 2004
Author: ffjeld
Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.6 movitz/compiler-types.lisp:1.7
--- movitz/compiler-types.lisp:1.6 Sat Feb 14 08:56:19 2004
+++ movitz/compiler-types.lisp Sat Feb 14 17:11:36 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Wed Sep 10 00:40:07 2003
;;;;
-;;;; $Id: compiler-types.lisp,v 1.6 2004/02/14 13:56:19 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.7 2004/02/14 22:11:36 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -56,47 +56,8 @@
(defun type-specifier-singleton (type-specifier)
"If type-specifier is a singleton type, return a singleton list
with the single member of <type-specifier>."
- (let ((old-result (cond
- ((eq 'null type-specifier)
- ;; The type NULL is a singleton.
- (list (movitz-read nil)))
- ((listp type-specifier)
- (case (car type-specifier)
- (eql
- (cdr type-specifier))
- (member
- (when (= 1 (length (cdr type-specifier)))
- (cdr type-specifier)))
- (integer
- (when (and (integerp (second type-specifier))
- (integerp (third type-specifier))
- (= (second type-specifier)
- (third type-specifier)))
- (second type-specifier)))))))
- (new-result
- (multiple-value-bind (code intscope members include complement)
- (type-specifier-encode type-specifier)
- (cond
- ((or complement include (not (= 0 code)))
- nil)
- ((= 1 (length members))
- members)
- ((and (= 1 (length intscope))
- (caar intscope)
- (eql (caar intscope)
- (cdar intscope)))
- (list (movitz-read (caar intscope))))))))
- (check-type old-result list)
- (check-type new-result list)
- (cond
- ((and old-result new-result)
- (assert (movitz-eql (car old-result) (car new-result)))
- new-result)
- ((and (not old-result) (not new-result))
- nil)
- (t (warn "ts-singleton different result: old ~S, new: ~S"
- old-result new-result)
- new-result))))
+ (multiple-value-call #'encoded-type-singleton
+ (type-specifier-encode type-specifier)))
;;;
@@ -444,7 +405,16 @@
(union members0 members1 :test #'movitz-eql))
(union include0 include1 :test #'equal)
nil)))
- (t (error "Not implemented"))))
+ ((and (not complement0) complement1)
+ (values code0
+ integer-range0
+ members0
+ (cons (encoded-type-decode code1 integer-range1 members1 include1 complement1)
+ include0)
+ nil))
+ (t (error "Not implemented: ~S or ~S"
+ (encoded-type-decode code0 integer-range0 members0 include0 complement0)
+ (encoded-type-decode code1 integer-range1 members1 include1 complement1)))))
(defun type-specifier-encode (type-specifier)
@@ -583,13 +553,13 @@
((encoded-allp code1 integer-range1 members1 include1 complement1)
;; type1 is t.
(result-is t t))
- ((and (encoded-emptyp code1 integer-range1 members1 include1 complement1)
- (not (encoded-emptyp code0 integer-range0 members0 include0 complement0)))
- ;; type1 is nil and type0 isn't.
- (result-is nil t))
((encoded-emptyp code0 integer-range0 members0 include0 complement0)
;; type0 is nil, which is a subtype of anything.
(result-is t t))
+ ((and (encoded-emptyp code1 integer-range1 members1 include1 complement1)
+ #+ignore (not (encoded-emptyp code0 integer-range0 members0 include0 complement0)))
+ ;; type1 is nil and type0 isn't.
+ (result-is nil t))
((and (encoded-allp code0 integer-range0 members0 include0 complement0)
(multiple-value-bind (all1 confident)
(encoded-allp code1 integer-range1 members1 include1 complement1)
@@ -611,14 +581,29 @@
((:unknown)
(result-is nil nil))
((t) nil)))
- (when include0
- (result-is nil nil))
- (result-is t t))
+ (if include0
+ (result-is nil nil)
+ (result-is t t)))
((and complement0 complement1)
(encoded-subtypep code1 integer-range1 members1 include1 nil
code0 integer-range0 members0 include0 nil))
(t (result-is nil nil))))))
-
+
+(defun encoded-type-singleton (code intscope members include complement)
+ "If the encoded type is a singleton, return that element in a list."
+ (cond
+ ((or complement include (not (= 0 code)))
+ nil)
+ ((= 1 (length members))
+ members)
+ ((and (= 1 (length intscope))
+ (caar intscope)
+ (eql (caar intscope)
+ (cdar intscope)))
+ (list (movitz-read (caar intscope))))
+ ((and (null members) (null intscope))
+ (warn "Not singleton, nulloton."))))
+
(defun movitz-subtypep (type1 type2)
"Compile-time subtypep."
(multiple-value-call #'encoded-subtypep
More information about the Movitz-cvs
mailing list