New implementation of SUBTYPEP.

src/CHANGELOG

@@ -1240,8 +1240,6 @@ ECLS 0.9
 
   - Excesive arguments to NOT or NULL were not detected.
 
-  - (COND) is a valid expression which returns NIL.
-
 * Visible changes:
 
   - No "Bye" message in QUIT.
@@ -1343,6 +1341,13 @@ ECLS 0.9
     implementation is based on a hash table, which means that some
     symbols may not be garbage collected.
 
+  - New condition types PARSE-ERROR, SIMPLE-READER-ERROR and READER-ERROR. The
+    errors from the reader correspond to this later type.
+
+  - New implementation for SUBTYPEP.
+
+  - TYPEP now works with (CONS ...) types.
+
 TODO:
 =====
 

src/clos/builtin.lsp

@@ -47,7 +47,6 @@
 
 (defclass symbol (t) () (:metaclass built-in))
    (defclass null (symbol list) () (:metaclass built-in))
-   (defclass keyword (symbol) () (:metaclass built-in))
 
 (defclass function (t) () (:metaclass built-in))
 
@@ -55,57 +54,6 @@
    (defclass logical-pathname (pathname) () (:metaclass built-in))
 |#
 
-(eval-when (compile load eval)
-  (mapcar #'(lambda (args &aux (class (first args)) (super (cdr args)))
-	      (eval `(defclass ,class ,super () (:metaclass built-in-class))))
-	  '(;(t object)
-	    (sequence t)
-	      (list sequence)
-	        (cons list)
-	    (array t)
-	      (string array sequence)
-	      (vector array sequence)
-	        (bit-vector vector)
-	    (stream t)
-	      (file-stream stream)
-	      (echo-stream stream)
-	      (string-stream stream)
-	      (two-way-stream stream)
-	      (synonym-stream stream)
-	      (broadcast-stream stream)
-	      (concatenated-stream stream)
-	    (character t)
-	    (number t)
-	      (real number)
-	        (rational real)
-		  (integer rational)
-		  (ratio rational)
-	        (float real)
-	      (complex number)
-	    (symbol t)
-	      (null symbol list)
-	      (keyword symbol)
-	    (package t)
-	    (function t)
-	    (pathname t)
-	      (logical-pathname pathname)
-	    (hash-table t)
-	    (random-state)
-	    (readtable))))
-
-;;; Now we protect classes from redefinition:
-(defun setf-find-class (name new-value)
-  (cond
-   ((typep (find-class name nil) 'built-in-class)
-    (error "The class associated to the CL specifier ~S cannot be changed."
-	   name))
-   ((member name '(CLASS BUILT-IN-CLASS) :test #'eq)
-    (error "The kernel CLOS class ~S cannot be changed." name))
-   ((classp new-value)
-    (setf (gethash name si:*class-name-hash-table*) new-value))
-   ((null new-value) (remhash name si:*class-name-hash-table*))
-   (t (error "~A is not a class." new-value))))
-
 ;;; ----------------------------------------------------------------------
 ;;; Methods
 
@@ -227,3 +175,55 @@
     obj))
 
 ;;; ----------------------------------------------------------------------
+
+(eval-when (compile load eval)
+  (mapcar #'(lambda (args &aux (class (first args)) (super (cdr args)))
+	      (eval `(defclass ,class ,super () (:metaclass built-in-class))))
+	  '(;(t object)
+	    (sequence t)
+	      (list sequence)
+	        (cons list)
+	    (array t)
+	      (string array sequence)
+	      (vector array sequence)
+	        (bit-vector vector)
+	    (stream t)
+	      (file-stream stream)
+	      (echo-stream stream)
+	      (string-stream stream)
+	      (two-way-stream stream)
+	      (synonym-stream stream)
+	      (broadcast-stream stream)
+	      (concatenated-stream stream)
+	    (character t)
+	    (number t)
+	      (real number)
+	        (rational real)
+		  (integer rational)
+		  (ratio rational)
+	        (float real)
+	      (complex number)
+	    (symbol t)
+	      (null symbol list)
+	      (keyword symbol)
+	    (package t)
+	    (function t)
+	    (pathname t)
+	      (logical-pathname pathname)
+	    (hash-table t)
+	    (random-state)
+	    (readtable))))
+
+;;; Now we protect classes from redefinition:
+(defun setf-find-class (name new-value)
+  (cond
+   ((typep (find-class name nil) 'built-in-class)
+    (error "The class associated to the CL specifier ~S cannot be changed."
+	   name))
+   ((member name '(CLASS BUILT-IN-CLASS) :test #'eq)
+    (error "The kernel CLOS class ~S cannot be changed." name))
+   ((classp new-value)
+    (setf (gethash name si:*class-name-hash-table*) new-value))
+   ((null new-value) (remhash name si:*class-name-hash-table*))
+   (t (error "~A is not a class." new-value))))
+

src/clos/conditions.lsp

@@ -542,6 +542,12 @@ returns with NIL."
 	     (format stream "Cannot print object ~A readably."
 		     (print-not-readable-object condition)))))
 
+(define-condition parse-error (error) ())
+
+(define-condition reader-error (parse-error stream-error) ())
+
+(define-condition simple-reader-error (simple-condition reader-error) ())
+
 #+nil
 (defun simple-condition-class-p (type)
   (typep type 'SIMPLE-CONDITION-CLASS))

src/clos/defclass.lsp

@@ -145,6 +145,9 @@
       (setq instance-slots (nreverse instance-slots)
 	    shared-slots (nreverse shared-slots))
       (cond
+	;; This is for bootstrap reasons
+	((eq metaclass-name 'CLASS)
+	 `(,@ (generate-slot-accessors class-name instance-slots shared-slots)))
 	;; since slot-value is inherited from 'STANDARD-OBJECT
 	((subtypep metaclass-name 'STANDARD-CLASS)
 	 (generate-optional-slot-accessors

src/cmp/cmpdefs.lsp

@@ -42,6 +42,8 @@
 			;;; During Pass2, the index into the closure env
 )
 
+(deftype OBJECT () `(not (or fixnum character short-float long-float)))
+
 (defstruct (var (:include ref))
 ;  name		;;; Variable name.
 ;  (ref 0 :type fixnum)
@@ -68,7 +70,7 @@
   (type t)	;;; Type of the variable.
   (index -1)    ;;; position in *vars*. Used by similar.
   )
-(deftype var () '(satisfies var-p))
+;(deftype var () '(satisfies var-p))
 
 ;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE
 ;;; Here are examples of function FOO for the 3 cases:
@@ -112,7 +114,7 @@
   closure		;;; During Pass2, T if env is used inside the function
   var			;;; the variable holding the funob
   )
-(deftype fun () '(satisifes fun-p))
+;(deftype fun () '(satisfies fun-p))
 
 (defstruct (blk (:include ref))
 ;  name			;;; Block name.
@@ -129,7 +131,7 @@
   destination		;;; Where the value of the block to go.
   var			;;; Variable containing the block ID.
   )
-(deftype blk () '(satisfies blk-p))
+;(deftype blk () '(satisfies blk-p))
 
 (defstruct (tag (:include ref))
 ;  name			;;; Tag name.
@@ -143,7 +145,7 @@
   var			;;; Variable containing frame ID.
   index			;;; An integer denoting the label.
   )
-(deftype tag () '(satisfies tag-p))
+;(deftype tag () '(satisfies tag-p))
 
 (defstruct (info)
   (changed-vars nil)	;;; List of var-objects changed by the form.
@@ -161,7 +163,7 @@
 ;;;	add-info) so that we can determine exactly which frame is used
 ;;;	in the body of a function.
   )
-(deftype info () '(satisfies info-p))
+;(deftype info () '(satisfies info-p))
 
 ;;;
 ;;; VARIABLES

src/cmp/cmpmain.lsp

@@ -187,6 +187,8 @@ int init_~A(cl_object cblock)
     (ecase target
       (:program
        (setq output-name (namestring output-name))
+       (format t +lisp-program-main+ init-name prologue-code init-name
+	       epilogue-code)
        (with-open-file (c-file c-name :direction :output)
 	 (format c-file +lisp-program-main+ init-name prologue-code init-name
 		 epilogue-code))

src/cmp/cmptag.lsp

@@ -118,7 +118,7 @@
 	(list 'PROGN info (nreverse (cons (c1nil) body1))))))
 
 (defun c2tagbody (tag-loc body)
-  (declare (type variable tag-loc))
+  (declare (type var tag-loc))
   (if (null (var-kind tag-loc))
       ;; only local goto's
       (let ((label (next-label)))

src/cmp/cmptype.lsp

@@ -66,8 +66,7 @@
 	((SIMPLE-ARRAY ARRAY)
 	 (cond ((endp type-args) '(ARRAY *))		; Beppe
 	       ((eq '* (car type-args)) t)
-	       (t (let ((element-type
-			 (sys::type-for-array (car type-args))))
+	       (t (let ((element-type (upgraded-array-element-type (car type-args))))
 		    (if (and (cdr type-args)
 			     (not (eq (second type-args) '*))
 			     (= (length (second type-args)) 1))
@@ -76,16 +75,15 @@
 			(BIT 'BIT-VECTOR)
 			(t (list 'VECTOR element-type)))
 		      (list 'ARRAY element-type))))))
-	(INTEGER
-	 (if (sys::sub-interval-p type-args
-				  '#.(list most-negative-fixnum
-					   most-positive-fixnum))
-	   'FIXNUM
-	   t))
+	(INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t))
 	((SHORT-FLOAT SINGLE-FLOAT) 'SHORT-FLOAT)
 	((LONG-FLOAT DOUBLE-FLOAT) 'LONG-FLOAT)
 	((STREAM) 'STREAM)	; Beppe
-	(t (cond #+clos
+	(t (cond ((eq type-name 'VALUES)
+		  (if (null (cdr type-args))
+		    (list 'VALUES (type-filter (car type-args)))
+		    t))
+		 #+clos
 		 ((subtypep type 'STANDARD-OBJECT) type)
 		 #+clos
 		 ((subtypep type 'STRUCTURE-OBJECT) type) 
@@ -97,10 +95,6 @@
 			       (ARRAY SHORT-FLOAT) (ARRAY LONG-FLOAT)
 			       (ARRAY T))) ; Beppe
 		    (when (subtypep type v) (return v))))
-		 ((eq type-name 'VALUES)
-		  (if (null (cdr type-args))
-		    (list 'VALUES (type-filter (car type-args)))
-		    t))
 		 ((and (eq type-name 'SATISFIES) ; Beppe
 		       (symbolp (car type-args))
 		       (get-sysprop (car type-args) 'TYPE-FILTER)))

src/cmp/sysfun.lsp

@@ -49,7 +49,8 @@
 		 (mapcar #'(lambda (x) (if (eql x '*) '* (type-filter x)))
 			 arg-types)))
   (when (and return-type (not (eq 'T return-type)))
-    (put-sysprop fname 'return-type (type-filter return-type)))
+    (put-sysprop fname 'return-type
+		 (if (eql return-type '*) '* (type-filter return-type))))
   (when never-change-special-var-p (put-sysprop fname 'no-sp-change t))
   (when predicate (put-sysprop fname 'predicate t))
   (rem-sysprop fname ':inline-always)
@@ -1082,7 +1083,7 @@ type_of(#0)==t_bitvector"))
 	    encode-universal-time get-decoded-time isqrt abs phase signum cis asin
 	    acos asinh acosh atanh rational ffloor fceiling ftruncate fround
 	    logtest byte byte-size byte-position ldb ldb-test mask-field dpb
-	    deposit-field typep subtypep coerce type-for-array make-sequence
+	    deposit-field upgraded-array-element-type typep subtypep coerce make-sequence
 	    concatenate map some every notany notevery map-into reduce fill
 	    replace remove remove-if remove-if-not delete delete-if delete-if-not
 	    count count-if count-if-not substitute substitute-if substitute-if-not

src/lsp/arraylib.lsp

@@ -41,7 +41,7 @@ in raw-major indexing is actually the reference to the (I + DISPLACED-INDEX-
 OFFSET)th element of the given array.If the STATIC argument is supplied
 with a non-nil value, then the body of the array is allocated as a
 contiguous block."
-  (setq element-type (type-for-array element-type))
+  (setq element-type (upgraded-array-element-type element-type))
 
   (if (or (integerp dimensions)
 	  (when (= (length dimensions) 1)

src/lsp/seq.lsp

@@ -18,27 +18,23 @@
 Creates and returns a sequence of the given TYPE and LENGTH.  If INITIAL-
 ELEMENT is given, then it becomes the elements of the created sequence.  The
 default value of INITIAL-ELEMENT depends on TYPE."
+  (when (subtypep type 'LIST)
+    (return-from make-sequence
+      (if iesp
+	  (make-list size :initial-element initial-element)
+	  (make-list size))))
   (setq element-type
-        (cond ((eq type 'LIST)
-               (return-from make-sequence
-                (if iesp
-                    (make-list size :initial-element initial-element)
-                    (make-list size))))
-              ((or (eq type 'SIMPLE-STRING) (eq type 'STRING)) 'BASE-CHAR)
-              ((or (eq type 'SIMPLE-BIT-VECTOR) (eq type 'BIT-VECTOR)) 'BIT)
-              ((or (eq type 'SIMPLE-VECTOR) (eq type 'VECTOR)) t)
-              (t
-	       (multiple-value-bind (name args)
-		   (normalize-type type)
-		 (when (eq name 'LIST)
-		   (return-from make-sequence
-                      (if iesp
-                          (make-list size :initial-element initial-element)
-                          (make-list size))))
-		 (unless (or (eq name 'ARRAY)
-			     (eq name 'SIMPLE-ARRAY))
-                       (error "~S is not a sequence type." type))
-		 (or (car args) t)))))
+	(dolist (i '((SIMPLE-STRING . BASE-CHAR)
+		     (STRING . BASE-CHAR)
+		     (BIT-VECTOR . BIT)
+		     ((VECTOR BYTE8) . BYTE8)
+		     ((VECTOR INTEGER8) . INTEGER8)
+		     ((VECTOR SHORT-FLOAT) . SHORT-FLOAT)
+		     ((VECTOR LONG-FLOAT) . LONG-FLOAT)
+		     (VECTOR . T))
+		 (error "Not a valid sequence type ~S." type))
+	  (when (subtypep type (car i))
+	    (return (cdr i)))))
   (setq sequence (sys:make-vector element-type size nil nil nil nil))
   (when iesp
         (do ((i 0 (1+ i))

src/lsp/seqlib.lsp

@@ -19,7 +19,7 @@
   (cond ((listp sequence) 'list)
         ((stringp sequence) 'string)
         ((bit-vector-p sequence) 'bit-vector)
-        ((vectorp sequence) (list 'array (array-element-type sequence)))
+        ((vectorp sequence) (list 'vector (array-element-type sequence)))
         (t (error "~S is not a sequence." sequence))))
 
 (declaim (ftype (function (t t t t) t) call-test))