Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code late-deftypes-for-target.lisp, NONE, 1.1 class.lisp, 1.72, 1.73 defstruct.lisp, 1.82, 1.83 deftypes-for-target.lisp, 1.25, 1.26 early-full-eval.lisp, 1.2, 1.3
|
From: Christophe R. <cr...@us...> - 2006-09-14 21:10:50
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv4113/src/code Modified Files: class.lisp defstruct.lisp deftypes-for-target.lisp early-full-eval.lisp Added Files: late-deftypes-for-target.lisp Log Message: 0.9.16.30: A couple of type-system fixups for #+sb-eval ... we have to have sb-eval:interpreted-function defined on the host, so that the deftype for COMPILED-FUNCTION does not involve any unknown types. So ... make !defstruct-with-alternate-metaclass compilable by the host compiler, similarly to sb-xc:defstruct. Don't quite do it properly: put a FIXME note in for posterity. ... move early-full-eval.lisp earlier in the build, and split out the definition for compiled-function from deftypes-for-target to late-deftypes-for-target (after the interpreted-function class is defined) ... (declare (type compiled-function x)) should do a type check for compiled-function, not for simply FUNCTION. ... the problem was actually in PRIMITIVE-TYPE on intersection types; the computation was fairly bogus. Make it less bogus. ... also delete some stale classoid symbols. --- NEW FILE: late-deftypes-for-target.lisp --- (in-package "SB!KERNEL") (sb!xc:deftype compiled-function () '(and function #!+sb-eval (not sb!eval:interpreted-function))) Index: class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v retrieving revision 1.72 retrieving revision 1.73 diff -u -d -r1.72 -r1.73 --- class.lisp 13 Sep 2006 15:59:32 -0000 1.72 +++ class.lisp 14 Sep 2006 21:10:44 -0000 1.73 @@ -950,8 +950,8 @@ ;;; 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))) Index: defstruct.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v retrieving revision 1.82 retrieving revision 1.83 diff -u -d -r1.82 -r1.83 --- defstruct.lisp 7 Apr 2006 11:41:46 -0000 1.82 +++ defstruct.lisp 14 Sep 2006 21:10:44 -0000 1.83 @@ -333,7 +333,8 @@ `((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) @@ -1158,7 +1159,7 @@ (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) @@ -1551,6 +1552,47 @@ (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)) Index: deftypes-for-target.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/deftypes-for-target.lisp,v retrieving revision 1.25 retrieving revision 1.26 diff -u -d -r1.25 -r1.26 --- deftypes-for-target.lisp 13 Sep 2006 15:59:32 -0000 1.25 +++ deftypes-for-target.lisp 14 Sep 2006 21:10:44 -0000 1.26 @@ -56,9 +56,6 @@ (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 () Index: early-full-eval.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-full-eval.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- early-full-eval.lisp 13 Sep 2006 15:59:32 -0000 1.2 +++ early-full-eval.lisp 14 Sep 2006 21:10:44 -0000 1.3 @@ -25,7 +25,7 @@ ;; 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) @@ -36,21 +36,23 @@ :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)) +#-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)) + (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!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))))) |