;; CHECK-FUN-NAME defined in proclaim.lisp.
("src/code/force-delayed-defbangstructs")
+ ;; early-full-eval uses !DEFSTRUCT-WITH-ALTERNATE-METACLASS and
+ ;; DEF!METHOD. It split out from the rest of full-eval because
+ ;; defstruct/metaclass fun makes it unslammable, and to define
+ ;; INTERPRETED-FUNCTION before it is used in compiler/main and in the
+ ;; definition of the COMPILED-FUNCTION type.
+ #!+sb-eval
+ ("src/code/early-full-eval")
+
("src/code/typep" :not-host)
("src/compiler/compiler-error")
+ ("src/code/late-deftypes-for-target")
+
("src/code/type-init")
;; Now that the type system is initialized, fix up UNKNOWN types that
;; have crept in.
;; trace table definitions from compiler/trace-table.lisp.
("src/compiler/dump")
- ;; early-full-eval uses !DEFSTRUCT-WITH-ALTERNATE-METACLASS and
- ;; DEF!METHOD. It split out from the rest of full-eval because
- ;; defstruct/metaclass fun makes it unslammable, and to define
- ;; INTERPRETED-FUNCTION before it is used in compiler/main.
- #!+sb-eval
- ("src/code/early-full-eval" :not-host)
-
("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp
("src/code/source-location")
("src/compiler/target-main" :not-host)
"STANDARD-CLASSOID" "CLASSOID-OF"
"MAKE-STANDARD-CLASSOID" "CLASSOID-CELL-TYPEP"
"FIND-CLASSOID-CELL" "EXTRACT-FUN-TYPE"
- "FUNCALLABLE-STRUCTURE-CLASSOID" "%RANDOM-DOUBLE-FLOAT"
+ "%RANDOM-DOUBLE-FLOAT"
#!+long-float "%RANDOM-LONG-FLOAT"
"%RANDOM-SINGLE-FLOAT" "STATIC-CLASSOID"
"%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK" "BIG-RANDOM-CHUNK"
- "MAKE-FUNCALLABLE-STRUCTURE-CLASSOID"
"LAYOUT-CLOS-HASH-MAX" "CLASSOID-CELL-NAME"
"BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES"
"BUILT-IN-CLASSOID-TRANSLATION" "RANDOM-LAYOUT-CLOS-HASH"
"FUNCALLABLE-INSTANCE-FUN" "%FUNCALLABLE-INSTANCE-LAYOUT"
"%SET-FUNCALLABLE-INSTANCE-LAYOUT"
"BASIC-STRUCTURE-CLASSOID" "CLASSOID-CELL-CLASSOID"
- "FUNCALLABLE-STRUCTURE-CLASSOID-P" "REGISTER-LAYOUT"
+ "REGISTER-LAYOUT"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
"MAKE-STATIC-CLASSOID" "INSTANCE-LAMBDA"
"%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL"
;;; FUNCALLABLE-STANDARD-CLASS.
(def!struct (standard-classoid (:include classoid)
(:constructor make-standard-classoid)))
-;;; a metaclass for miscellaneous PCL structure-like objects (at the
-;;; moment, only CTOR objects).
+;;; a metaclass for classes which aren't standardlike but will never
+;;; change either.
(def!struct (static-classoid (:include classoid)
(:constructor make-static-classoid)))
\f
`((setf (structure-classoid-constructor (find-classoid ',name))
#',def-con))))))))
-;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
+;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
+;;; cross-compiler macroexpansion for CL:DEFSTRUCT
(defmacro !expander-for-defstruct (name-and-options
slot-descriptions
expanding-into-code-for-xc-host-p)
(lambda (x)
(sb!xc:typep x 'structure-classoid))
(lambda (x)
- (sb!xc:typep x (find-classoid class))))
+ (sb!xc:typep x (classoid-name (find-classoid class)))))
(fdefinition constructor)))
(setf (classoid-direct-superclasses class)
(case (dd-name info)
(dd-type dd) dd-type)
dd))
+;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
+;;; lisp, installing the information we need to reason about the
+;;; structures (layouts and classoids).
+;;;
+;;; FIXME: we should share the parsing and the DD construction between
+;;; this and the cross-compiler version, but my brain was too small to
+;;; get that right. -- CSR, 2006-09-14
+#+sb-xc-host
+(defmacro !defstruct-with-alternate-metaclass
+ (class-name &key
+ (slot-names (missing-arg))
+ (boa-constructor (missing-arg))
+ (superclass-name (missing-arg))
+ (metaclass-name (missing-arg))
+ (metaclass-constructor (missing-arg))
+ (dd-type (missing-arg))
+ predicate
+ (runtime-type-checks-p t))
+
+ (declare (type (and list (not null)) slot-names))
+ (declare (type (and symbol (not null))
+ boa-constructor
+ superclass-name
+ metaclass-name
+ metaclass-constructor))
+ (declare (type symbol predicate))
+ (declare (type (member structure funcallable-structure) dd-type))
+ (declare (ignore boa-constructor predicate runtime-type-checks))
+
+ (let* ((dd (make-dd-with-alternate-metaclass
+ :class-name class-name
+ :slot-names slot-names
+ :superclass-name superclass-name
+ :metaclass-name metaclass-name
+ :metaclass-constructor metaclass-constructor
+ :dd-type dd-type)))
+ `(progn
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
+
(sb!xc:defmacro !defstruct-with-alternate-metaclass
(class-name &key
(slot-names (missing-arg))
(sb!xc:deftype bit () '(integer 0 1))
-(sb!xc:deftype compiled-function ()
- '(and function #!+sb-eval (not sb!eval:interpreted-function)))
-
(sb!xc:deftype atom () '(not cons))
(sb!xc:deftype base-char ()
;; RECOMPILE restart doesn't work on it. This is the main reason why
;; this stuff is split out into its own file. Also, it lets the
;; INTERPRETED-FUNCTION type be declared before it is used in
-;; compiler/main.
+;; compiler/main and code/deftypes-for-target.
(sb!kernel::!defstruct-with-alternate-metaclass
interpreted-function
:slot-names (name lambda-list env declarations documentation body source-location)
:dd-type funcallable-structure
:runtime-type-checks-p nil)
-(defun make-interpreted-function
- (&key name lambda-list env declarations documentation body source-location)
- (let ((function (%make-interpreted-function
- name lambda-list env declarations documentation body
- source-location)))
- (setf (sb!kernel:funcallable-instance-fun function)
- #'(lambda (&rest args)
- (interpreted-apply function args)))
- function))
-
-(defun interpreted-function-p (function)
- (typep function 'interpreted-function))
-
-(sb!int:def!method print-object ((obj interpreted-function) stream)
- (print-unreadable-object (obj stream
- :identity (not (interpreted-function-name obj)))
- (format stream "~A ~A" '#:interpreted-function
- (interpreted-function-name obj))))
+#-sb-xc-host
+(progn
+ (defun make-interpreted-function
+ (&key name lambda-list env declarations documentation body source-location)
+ (let ((function (%make-interpreted-function
+ name lambda-list env declarations documentation body
+ source-location)))
+ (setf (sb!kernel:funcallable-instance-fun function)
+ #'(lambda (&rest args)
+ (interpreted-apply function args)))
+ function))
+
+ (defun interpreted-function-p (function)
+ (typep function 'interpreted-function))
+
+ (sb!int:def!method print-object ((obj interpreted-function) stream)
+ (print-unreadable-object (obj stream
+ :identity (not (interpreted-function-name obj)))
+ (format stream "~A ~A" '#:interpreted-function
+ (interpreted-function-name obj)))))
--- /dev/null
+(in-package "SB!KERNEL")
+
+(sb!xc:deftype compiled-function ()
+ '(and function #!+sb-eval (not sb!eval:interpreted-function)))
(return (any)))))))))))
(intersection-type
(let ((types (intersection-type-types type))
- (res (any))
- (exact nil))
- (dolist (type types (values res exact))
- (multiple-value-bind (ptype ptype-exact)
+ (res (any)))
+ ;; why NIL for the exact? Well, we assume that the
+ ;; intersection type is in fact doing something for us:
+ ;; that is, that each of the types in the intersection is
+ ;; in fact cutting off some of the type lattice. Since no
+ ;; intersection type is represented by a primitive type and
+ ;; primitive types are mutually exclusive, it follows that
+ ;; no intersection type can represent the entirety of the
+ ;; primitive type. (And NIL is the conservative answer,
+ ;; anyway). -- CSR, 2006-09-14
+ (dolist (type types (values res nil))
+ (multiple-value-bind (ptype)
(primitive-type type)
- (when ptype-exact
- (aver (or (not exact) (eq ptype res)))
- (setq exact t))
- (when (or ptype-exact (and (not exact) (eq res (any))))
- ;; Try to find a narrower representation then
- ;; (any). Takes care of undecidable types in
- ;; intersections with decidable ones.
- (setq res ptype))))))
+ (cond
+ ;; if the result so far is (any), any improvement on
+ ;; the specificity of the primitive type is valid.
+ ((eq res (any))
+ (setq res ptype))
+ ;; if the primitive type returned is (any), the
+ ;; result so far is valid. Likewise, if the
+ ;; primitive type is the same as the result so far,
+ ;; everything is fine.
+ ((or (eq ptype (any)) (eq ptype res)))
+ ;; otherwise, we have something hairy and confusing,
+ ;; such as (and condition funcallable-instance).
+ ;; Punt.
+ (t (return (any))))))))
(member-type
(let* ((members (member-type-members type))
(res (primitive-type-of (first members))))
(assert-t-t
(subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector)
'(or fixnum vector end-of-file parse-error fixnum simple-string)))
+
+#+sb-eval
+(assert-t-t
+ (subtypep '(and function (not compiled-function)
+ (not sb-eval:interpreted-function))
+ nil))
+
;;; success
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.16.29"
+"0.9.16.30"
projects / sbcl.git / commitdiff